From 478d3482fef6ae7be0a2ebd6d7fdcb407a3f4209 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 25 Nov 2020 13:32:39 -0700 Subject: [PATCH 001/115] Update .gitmodules and submodule pointers for ccpp-framework and ccpp-physics for gsl/develop branch --- .gitmodules | 8 ++++---- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index d253f6966..4760351ce 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NCAR/ccpp-framework - branch = master + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NCAR/ccpp-physics - branch = master + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index f1dc8d6f0..16271557a 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit f1dc8d6f038e590508c272070f673d1fd7ea566f +Subproject commit 16271557a692b2c6871bf4e2209b8035a9addc52 diff --git a/ccpp/physics b/ccpp/physics index 4e39b50a2..d12329a9a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4e39b50a248fc093c055fc6a8ae245065da7c730 +Subproject commit d12329a9ada515766ccb81771e8ba299ea3a8464 From bd71c2afd1195e9e25962ec94bdb5e41de349769 Mon Sep 17 00:00:00 2001 From: DomHeinzeller <58610420+DomHeinzeller@users.noreply.github.com> Date: Tue, 1 Dec 2020 10:06:50 -0700 Subject: [PATCH 002/115] RUC ice for gsl/develop (replaces #54 and #56) (#60) Implementation of RUC LSM ice model in CCPP * Squash-merge climbfuji:rucice_gfsv16dzmin into gsl/develop * Fix bug in gfsphysics/GFS_layer/GFS_typedefs.F90 from merge * Remove lsm_ruc_sfc_sice from suite FV3_GSD_v0_unified_ugwp_suite and update submodule pointer for ccpp-physics * Remove sfc_sice from ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml * Update submodule pointer for ccpp-physics * Revert change to .gitmodules and update submodule pointer for ccpp-physics Co-authored-by: Dom Heinzeller --- ccpp/config/ccpp_prebuild_config.py | 1 - ccpp/physics | 2 +- ccpp/suites/suite_FV3_GSD_SAR.xml | 3 - ccpp/suites/suite_FV3_GSD_v0.xml | 3 - ccpp/suites/suite_FV3_GSD_v0_drag_suite.xml | 3 - ccpp/suites/suite_FV3_GSD_v0_mynnsfc.xml | 3 - .../suite_FV3_GSD_v0_unified_ugwp_suite.xml | 3 - ccpp/suites/suite_FV3_HRRR.xml | 3 - ccpp/suites/suite_FV3_RAP.xml | 3 - gfsphysics/GFS_layer/GFS_diagnostics.F90 | 12 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 110 ++++++++++-------- gfsphysics/GFS_layer/GFS_typedefs.meta | 66 +++++++---- io/FV3GFS_io.F90 | 85 +++++++++----- 13 files changed, 168 insertions(+), 129 deletions(-) diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index f954a07f5..f649535ac 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -171,7 +171,6 @@ 'ccpp/physics/physics/sfc_diag.f', 'ccpp/physics/physics/sfc_diag_post.F90', 'ccpp/physics/physics/sfc_drv_ruc.F90', - 'ccpp/physics/physics/lsm_ruc_sfc_sice_interstitial.F90', 'ccpp/physics/physics/sfc_cice.f', 'ccpp/physics/physics/sfc_diff.f', 'ccpp/physics/physics/sfc_drv.f', diff --git a/ccpp/physics b/ccpp/physics index d12329a9a..bafcc9ebb 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d12329a9ada515766ccb81771e8ba299ea3a8464 +Subproject commit bafcc9ebb6788696666e7592cf7577db81e5fbbe diff --git a/ccpp/suites/suite_FV3_GSD_SAR.xml b/ccpp/suites/suite_FV3_GSD_SAR.xml index 08541847a..29f6d3707 100644 --- a/ccpp/suites/suite_FV3_GSD_SAR.xml +++ b/ccpp/suites/suite_FV3_GSD_SAR.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_GSD_v0.xml b/ccpp/suites/suite_FV3_GSD_v0.xml index 06c4d7dcd..7838db77b 100644 --- a/ccpp/suites/suite_FV3_GSD_v0.xml +++ b/ccpp/suites/suite_FV3_GSD_v0.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_GSD_v0_drag_suite.xml b/ccpp/suites/suite_FV3_GSD_v0_drag_suite.xml index 7d55abfd2..21d45de21 100644 --- a/ccpp/suites/suite_FV3_GSD_v0_drag_suite.xml +++ b/ccpp/suites/suite_FV3_GSD_v0_drag_suite.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_GSD_v0_mynnsfc.xml b/ccpp/suites/suite_FV3_GSD_v0_mynnsfc.xml index b3b629550..d19d991f2 100644 --- a/ccpp/suites/suite_FV3_GSD_v0_mynnsfc.xml +++ b/ccpp/suites/suite_FV3_GSD_v0_mynnsfc.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml b/ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml index 8a717abc3..8a8d69b88 100644 --- a/ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml +++ b/ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_HRRR.xml b/ccpp/suites/suite_FV3_HRRR.xml index 4487b8e27..c74fe17f8 100644 --- a/ccpp/suites/suite_FV3_HRRR.xml +++ b/ccpp/suites/suite_FV3_HRRR.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_RAP.xml b/ccpp/suites/suite_FV3_RAP.xml index 9440efa69..da3fe46bf 100644 --- a/ccpp/suites/suite_FV3_RAP.xml +++ b/ccpp/suites/suite_FV3_RAP.xml @@ -45,9 +45,6 @@ sfc_nst sfc_nst_post lsm_ruc - lsm_ruc_sfc_sice_pre - sfc_sice - lsm_ruc_sfc_sice_post GFS_surface_loop_control_part2 diff --git a/gfsphysics/GFS_layer/GFS_diagnostics.F90 b/gfsphysics/GFS_layer/GFS_diagnostics.F90 index a289df88a..cf19c7cd3 100644 --- a/gfsphysics/GFS_layer/GFS_diagnostics.F90 +++ b/gfsphysics/GFS_layer/GFS_diagnostics.F90 @@ -3030,24 +3030,24 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop if (Model%lsm == Model%lsm_ruc) then idx = idx + 1 ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'snowfall_acc' - ExtDiag(idx)%desc = 'total accumulated frozen precipitation' + ExtDiag(idx)%name = 'snowfall_acc_land' + ExtDiag(idx)%desc = 'total accumulated frozen precipitation over land' ExtDiag(idx)%unit = 'kg m-2' ExtDiag(idx)%mod_name = 'gfs_sfc' allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%snowfallac(:) + ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%snowfallac_land(:) enddo idx = idx + 1 ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'swe_snowfall_acc' - ExtDiag(idx)%desc = 'accumulated water equivalent of frozen precipitation' + ExtDiag(idx)%name = 'snowfall_acc_ice' + ExtDiag(idx)%desc = 'total accumulated frozen precipitation over ice' ExtDiag(idx)%unit = 'kg m-2' ExtDiag(idx)%mod_name = 'gfs_sfc' allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%acsnow(:) + ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%snowfallac_ice(:) enddo endif #endif diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index b5b50b6af..2fef16ee4 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -255,7 +255,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: semisbase(:) => null() !< background surface emissivity !--- In (radiation only) - real (kind=kind_phys), pointer :: sncovr (:) => null() !< snow cover in fraction + real (kind=kind_phys), pointer :: sncovr (:) => null() !< snow cover in fraction over land + real (kind=kind_phys), pointer :: sncovr_ice (:) => null() !< snow cover in fraction over ice (RUC LSM only) 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 @@ -365,20 +366,22 @@ module GFS_typedefs #ifdef CCPP ! Soil properties for RUC LSM (number of levels different from NOAH 4-layer model) - real (kind=kind_phys), pointer :: wetness(:) => null() !< normalized soil wetness for lsm - real (kind=kind_phys), pointer :: sh2o(:,:) => null() !< volume fraction of unfrozen soil moisture for lsm - real (kind=kind_phys), pointer :: keepsmfr(:,:) => null() !< RUC LSM: frozen moisture in soil - real (kind=kind_phys), pointer :: smois(:,:) => null() !< volumetric fraction of soil moisture for lsm - real (kind=kind_phys), pointer :: tslb(:,:) => null() !< soil temperature for land surface model - real (kind=kind_phys), pointer :: flag_frsoil(:,:) => null() !< RUC LSM: flag for frozen soil physics + real (kind=kind_phys), pointer :: wetness(:) => null() !< normalized soil wetness for lsm + real (kind=kind_phys), pointer :: sh2o(:,:) => null() !< volume fraction of unfrozen soil moisture for lsm + real (kind=kind_phys), pointer :: keepsmfr(:,:) => null() !< RUC LSM: frozen moisture in soil + real (kind=kind_phys), pointer :: smois(:,:) => null() !< volumetric fraction of soil moisture for lsm + real (kind=kind_phys), pointer :: tslb(:,:) => null() !< soil temperature for land surface model + real (kind=kind_phys), pointer :: flag_frsoil(:,:) => null() !< RUC LSM: flag for frozen soil physics ! - real (kind=kind_phys), pointer :: clw_surf(:) => null() !< RUC LSM: moist cloud water mixing ratio at surface - real (kind=kind_phys), pointer :: qwv_surf(:) => null() !< RUC LSM: water vapor mixing ratio at surface - real (kind=kind_phys), pointer :: cndm_surf(:) => null() !< RUC LSM: surface condensation mass - real (kind=kind_phys), pointer :: rhofr(:) => null() !< RUC LSM: density of frozen precipitation - real (kind=kind_phys), pointer :: tsnow(:) => null() !< RUC LSM: snow temperature at the bottom of the first soil layer - real (kind=kind_phys), pointer :: snowfallac(:) => null() !< ruc lsm diagnostics - real (kind=kind_phys), pointer :: acsnow(:) => null() !< ruc lsm diagnostics + real (kind=kind_phys), pointer :: clw_surf_land(:) => null() !< RUC LSM: moist cloud water mixing ratio at surface over land + real (kind=kind_phys), pointer :: clw_surf_ice(:) => null() !< RUC LSM: moist cloud water mixing ratio at surface over ice + real (kind=kind_phys), pointer :: qwv_surf_land(:) => null() !< RUC LSM: water vapor mixing ratio at surface over land + real (kind=kind_phys), pointer :: qwv_surf_ice(:) => null() !< RUC LSM: water vapor mixing ratio at surface over ice + real (kind=kind_phys), pointer :: rhofr(:) => null() !< RUC LSM: density of frozen precipitation + real (kind=kind_phys), pointer :: tsnow_land(:) => null() !< RUC LSM: snow temperature at the bottom of the first snow layer over land + real (kind=kind_phys), pointer :: tsnow_ice(:) => null() !< RUC LSM: snow temperature at the bottom of the first snow layer over ice + real (kind=kind_phys), pointer :: snowfallac_land(:) => null() !< ruc lsm diagnostics over land + real (kind=kind_phys), pointer :: snowfallac_ice(:) => null() !< ruc lsm diagnostics over ice ! MYNN surface layer real (kind=kind_phys), pointer :: ustm (:) => null() !u* including drag @@ -804,7 +807,6 @@ module GFS_typedefs integer :: isot !< isot = 0 => Zobler soil type ( 9 category) !< isot = 1 => STATSGO soil type (19 category, AKA 'STAS'(?)) !< isot = 2 => STAS-RUC soil type (19 category, NOAH WRFv4 only) - integer :: kice=2 !< number of layers in sice #ifdef CCPP integer :: lsoil_lsm !< number of soil layers internal to land surface model integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model @@ -821,6 +823,9 @@ module GFS_typedefs integer :: iopt_thcnd !< option to treat thermal conductivity in Noah LSM (new in 3.8) !< = 1, original (default) !< = 2, McCumber and Pielke for silt loam and sandy loam + integer :: kice !< number of layers in ice model +#else + integer :: kice=2 !< number of layers in sice #endif ! -- the Noah MP options @@ -1422,7 +1427,7 @@ module GFS_typedefs !--- 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 :: 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 @@ -1768,13 +1773,11 @@ module GFS_typedefs real (kind=kind_phys), pointer :: cld1d(:) => null() !< real (kind=kind_phys), pointer :: clouds(:,:,:) => null() !< real (kind=kind_phys), pointer :: clw(:,:,:) => null() !< - real (kind=kind_phys), pointer :: clw_surf(:) => null() !< real (kind=kind_phys), pointer :: clx(:,:) => null() !< real (kind=kind_phys), pointer :: cmc(:) => null() !< real (kind=kind_phys), pointer :: cmm_ice(:) => null() !< real (kind=kind_phys), pointer :: cmm_land(:) => null() !< real (kind=kind_phys), pointer :: cmm_ocean(:) => null() !< - real (kind=kind_phys), pointer :: cndm_surf(:) => null() !< real (kind=kind_phys), pointer :: cnv_dqldt(:,:) => null() !< real (kind=kind_phys), pointer :: cnv_fice(:,:) => null() !< real (kind=kind_phys), pointer :: cnv_mfd(:,:) => null() !< @@ -2025,7 +2028,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: tsfc_land_save(:) => null() !< real (kind=kind_phys), pointer :: tsfc_ocean(:) => null() !< real (kind=kind_phys), pointer :: tsfg(:) => null() !< - real (kind=kind_phys), pointer :: tsnow(:) => null() !< real (kind=kind_phys), pointer :: tsurf(:) => null() !< real (kind=kind_phys), pointer :: tsurf_ice(:) => null() !< real (kind=kind_phys), pointer :: tsurf_land(:) => null() !< @@ -2349,7 +2351,6 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%hprime = clear_val !--- In (radiation only) - allocate (Sfcprop%sncovr (IM)) allocate (Sfcprop%snoalb (IM)) allocate (Sfcprop%alvsf (IM)) allocate (Sfcprop%alnsf (IM)) @@ -2358,7 +2359,6 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%facsf (IM)) allocate (Sfcprop%facwf (IM)) - Sfcprop%sncovr = clear_val Sfcprop%snoalb = clear_val Sfcprop%alvsf = clear_val Sfcprop%alnsf = clear_val @@ -2403,6 +2403,9 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%hice (IM)) allocate (Sfcprop%weasd (IM)) allocate (Sfcprop%sncovr (IM)) + if (Model%lsm == Model%lsm_ruc) then + allocate (Sfcprop%sncovr_ice (IM)) + end if allocate (Sfcprop%canopy (IM)) allocate (Sfcprop%ffmm (IM)) allocate (Sfcprop%ffhh (IM)) @@ -2416,6 +2419,9 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%hice = clear_val Sfcprop%weasd = clear_val Sfcprop%sncovr = clear_val + if (Model%lsm == Model%lsm_ruc) then + Sfcprop%sncovr_ice = clear_val + end if Sfcprop%canopy = clear_val Sfcprop%ffmm = clear_val Sfcprop%ffhh = clear_val @@ -2606,33 +2612,37 @@ subroutine sfcprop_create (Sfcprop, IM, Model) if (Model%lsm == Model%lsm_ruc) then ! For land surface models with different numbers of levels than the four NOAH levels - allocate (Sfcprop%wetness (IM)) - allocate (Sfcprop%sh2o (IM,Model%lsoil_lsm)) - allocate (Sfcprop%keepsmfr (IM,Model%lsoil_lsm)) - allocate (Sfcprop%smois (IM,Model%lsoil_lsm)) - allocate (Sfcprop%tslb (IM,Model%lsoil_lsm)) - allocate (Sfcprop%flag_frsoil (IM,Model%lsoil_lsm)) - allocate (Sfcprop%clw_surf (IM)) - allocate (Sfcprop%qwv_surf (IM)) - allocate (Sfcprop%cndm_surf (IM)) - allocate (Sfcprop%rhofr (IM)) - allocate (Sfcprop%tsnow (IM)) - allocate (Sfcprop%snowfallac (IM)) - allocate (Sfcprop%acsnow (IM)) + allocate (Sfcprop%wetness (IM)) + allocate (Sfcprop%sh2o (IM,Model%lsoil_lsm)) + allocate (Sfcprop%keepsmfr (IM,Model%lsoil_lsm)) + allocate (Sfcprop%smois (IM,Model%lsoil_lsm)) + allocate (Sfcprop%tslb (IM,Model%lsoil_lsm)) + allocate (Sfcprop%flag_frsoil (IM,Model%lsoil_lsm)) + allocate (Sfcprop%clw_surf_land (IM)) + allocate (Sfcprop%clw_surf_ice (IM)) + allocate (Sfcprop%qwv_surf_land (IM)) + allocate (Sfcprop%qwv_surf_ice (IM)) + allocate (Sfcprop%rhofr (IM)) + allocate (Sfcprop%tsnow_land (IM)) + allocate (Sfcprop%tsnow_ice (IM)) + allocate (Sfcprop%snowfallac_land (IM)) + allocate (Sfcprop%snowfallac_ice (IM)) ! - Sfcprop%wetness = clear_val - Sfcprop%sh2o = clear_val - Sfcprop%keepsmfr = clear_val - Sfcprop%smois = clear_val - Sfcprop%tslb = clear_val - Sfcprop%clw_surf = clear_val - Sfcprop%qwv_surf = clear_val - Sfcprop%cndm_surf = clear_val - Sfcprop%flag_frsoil = clear_val - Sfcprop%rhofr = clear_val - Sfcprop%tsnow = clear_val - Sfcprop%snowfallac = clear_val - Sfcprop%acsnow = clear_val + Sfcprop%wetness = clear_val + Sfcprop%sh2o = clear_val + Sfcprop%keepsmfr = clear_val + Sfcprop%smois = clear_val + Sfcprop%tslb = clear_val + Sfcprop%clw_surf_land = clear_val + Sfcprop%clw_surf_ice = clear_val + Sfcprop%qwv_surf_land = clear_val + Sfcprop%qwv_surf_ice = clear_val + Sfcprop%flag_frsoil = clear_val + Sfcprop%rhofr = clear_val + Sfcprop%tsnow_land = clear_val + Sfcprop%tsnow_ice = clear_val + Sfcprop%snowfallac_land = clear_val + Sfcprop%snowfallac_ice = clear_val ! if (Model%rdlai) then allocate (Sfcprop%xlaixy (IM)) @@ -3173,6 +3183,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: iopt_thcnd = 1 !< option to treat thermal conductivity in Noah LSM (new in 3.8) !< = 1, original (default) !< = 2, McCumber and Pielke for silt loam and sandy loam + integer :: kice = 2 !< number of layers in ice; default is 2 (GFS sice) #endif integer :: ivegsrc = 2 !< ivegsrc = 0 => USGS, !< ivegsrc = 1 => IGBP (20 category) @@ -3503,7 +3514,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & avg_max_length, & !--- land/surface model control #ifdef CCPP - lsm, lsoil, lsoil_lsm, lsnow_lsm, rdlai, & + lsm, lsoil, lsoil_lsm, lsnow_lsm, kice, rdlai, & nmtvr, ivegsrc, use_ufo, iopt_thcnd, ua_phys, usemonalb, & aoasis, fasdas, & #else @@ -3968,6 +3979,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & allocate (Model%zs(Model%lsoil_lsm)) Model%zs = clear_val end if + ! Set number of ice model layers + Model%kice = kice ! if (lsnow_lsm /= 3) then write(0,*) 'Logic error: NoahMP expects the maximum number of snow layers to be exactly 3 (see sfc_noahmp_drv.f)' @@ -5145,6 +5158,7 @@ subroutine control_print(Model) print *, ' usemonalb : ', Model%usemonalb print *, ' aoasis : ', Model%aoasis print *, ' fasdas : ', Model%fasdas + print *, ' kice : ', Model%kice #endif print *, ' ivegsrc : ', Model%ivegsrc print *, ' isot : ', Model%isot diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 84e447237..4dfb5046e 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -606,6 +606,14 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[sncovr_ice] + standard_name = surface_snow_area_fraction_over_ice + long_name = surface snow area fraction over ice + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [snoalb] standard_name = upper_bound_on_max_albedo_over_deep_snow long_name = maximum snow albedo @@ -1266,27 +1274,35 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[clw_surf] - standard_name = cloud_condensed_water_mixing_ratio_at_surface - long_name = moist cloud water mixing ratio at surface + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[clw_surf_land] + standard_name = cloud_condensed_water_mixing_ratio_at_surface_over_land + long_name = moist cloud water mixing ratio at surface over land units = kg kg-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[qwv_surf] - standard_name = water_vapor_mixing_ratio_at_surface - long_name = water vapor mixing ratio at surface + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[clw_surf_ice] + standard_name = cloud_condensed_water_mixing_ratio_at_surface_over_ice + long_name = moist cloud water mixing ratio at surface over ice units = kg kg-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[cndm_surf] - standard_name = surface_condensation_mass - long_name = surface condensation mass - units = kg m-2 +[qwv_surf_land] + standard_name = water_vapor_mixing_ratio_at_surface_over_land + long_name = water vapor mixing ratio at surface over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[qwv_surf_ice] + standard_name = water_vapor_mixing_ratio_at_surface_over_ice + long_name = water vapor mixing ratio at surface over ice + units = kg kg-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -1307,25 +1323,33 @@ type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[tsnow] - standard_name = snow_temperature_bottom_first_layer - long_name = snow temperature at the bottom of the first snow layer +[tsnow_land] + standard_name = snow_temperature_bottom_first_layer_over_land + long_name = snow temperature at the bottom of the first snow layer over land + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[tsnow_ice] + standard_name = snow_temperature_bottom_first_layer_over_ice + long_name = snow temperature at the bottom of the first snow layer over ice units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[snowfallac] - standard_name = total_accumulated_snowfall +[snowfallac_land] + standard_name = total_accumulated_snowfall_over_land long_name = run-total snow accumulation on the ground units = kg m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) -[acsnow] - standard_name = accumulated_water_equivalent_of_frozen_precip - long_name = snow water equivalent of run-total frozen precip + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[snowfallac_ice] + standard_name = total_accumulated_snowfall_over_ice + long_name = run-total snow accumulation on the ice units = kg m-2 dimensions = (horizontal_loop_extent) type = real diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 08f792b05..a710941e2 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -530,9 +530,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) #ifdef CCPP if (Model%lsm == Model%lsm_ruc .and. warm_start) then if(Model%rdlai) then - nvar_s2r = 7 + nvar_s2r = 11 else - nvar_s2r = 6 + nvar_s2r = 10 end if nvar_s3 = 5 else @@ -872,13 +872,17 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) #ifdef CCPP else if (Model%lsm == Model%lsm_ruc .and. warm_start) then sfc_name2(nvar_s2m+19) = 'wetness' - sfc_name2(nvar_s2m+20) = 'clw_surf' - sfc_name2(nvar_s2m+21) = 'qwv_surf' - sfc_name2(nvar_s2m+22) = 'tsnow' - sfc_name2(nvar_s2m+23) = 'snowfall_acc' - sfc_name2(nvar_s2m+24) = 'swe_snowfall_acc' + sfc_name2(nvar_s2m+20) = 'clw_surf_land' + sfc_name2(nvar_s2m+21) = 'clw_surf_ice' + sfc_name2(nvar_s2m+22) = 'qwv_surf_land' + sfc_name2(nvar_s2m+23) = 'qwv_surf_ice' + sfc_name2(nvar_s2m+24) = 'tsnow_land' + sfc_name2(nvar_s2m+25) = 'tsnow_ice' + sfc_name2(nvar_s2m+26) = 'snowfall_acc_land' + sfc_name2(nvar_s2m+27) = 'snowfall_acc_ice' + sfc_name2(nvar_s2m+28) = 'sncovr_ice' if (Model%rdlai) then - sfc_name2(nvar_s2m+25) = 'lai' + sfc_name2(nvar_s2m+29) = 'lai' endif else if (Model%lsm == Model%lsm_ruc .and. Model%rdlai) then sfc_name2(nvar_s2m+19) = 'lai' @@ -1142,17 +1146,21 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) #ifdef CCPP if (Model%lsm == Model%lsm_ruc .and. warm_start) then !--- Extra RUC variables - Sfcprop(nb)%wetness(ix) = sfc_var2(i,j,nvar_s2m+19) - Sfcprop(nb)%clw_surf(ix) = sfc_var2(i,j,nvar_s2m+20) - Sfcprop(nb)%qwv_surf(ix) = sfc_var2(i,j,nvar_s2m+21) - Sfcprop(nb)%tsnow(ix) = sfc_var2(i,j,nvar_s2m+22) - Sfcprop(nb)%snowfallac(ix) = sfc_var2(i,j,nvar_s2m+23) - Sfcprop(nb)%acsnow(ix) = sfc_var2(i,j,nvar_s2m+24) + Sfcprop(nb)%wetness(ix) = sfc_var2(i,j,nvar_s2m+19) + Sfcprop(nb)%clw_surf_land(ix) = sfc_var2(i,j,nvar_s2m+20) + Sfcprop(nb)%clw_surf_ice(ix) = sfc_var2(i,j,nvar_s2m+21) + Sfcprop(nb)%qwv_surf_land(ix) = sfc_var2(i,j,nvar_s2m+22) + Sfcprop(nb)%qwv_surf_ice(ix) = sfc_var2(i,j,nvar_s2m+23) + Sfcprop(nb)%tsnow_land(ix) = sfc_var2(i,j,nvar_s2m+24) + Sfcprop(nb)%tsnow_ice(ix) = sfc_var2(i,j,nvar_s2m+25) + Sfcprop(nb)%snowfallac_land(ix) = sfc_var2(i,j,nvar_s2m+26) + Sfcprop(nb)%snowfallac_ice(ix) = sfc_var2(i,j,nvar_s2m+27) + Sfcprop(nb)%sncovr_ice(ix) = sfc_var2(i,j,nvar_s2m+28) if (Model%rdlai) then - Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+25) + Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+29) endif else if (Model%lsm == Model%lsm_ruc .and. Model%rdlai) then - Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+19) + Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+19) elseif (Model%lsm == Model%lsm_noahmp) then !--- Extra Noah MP variables #else @@ -1282,7 +1290,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- if sncovr does not exist in the restart, need to create it if (sfc_var2(i,j,32) < -9990.0_r8) then - if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing sncovr') + 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 !$omp parallel do default(shared) private(nb, ix, vegtyp, rsnow) @@ -1301,6 +1309,13 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif enddo enddo + !--- For RUC LSM: create sncovr_ice from sncovr + if (Model%lsm == Model%lsm_ruc) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - fill sncovr_ice with sncovr') + do nb = 1, Atm_block%nblks + Sfcprop(nb)%sncovr_ice(:) = Sfcprop(nb)%sncovr(:) + end do + endif endif ! if (Model%frac_grid) then @@ -1730,9 +1745,9 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta #ifdef CCPP if (Model%lsm == Model%lsm_ruc) then if (Model%rdlai) then - nvar2r = 7 + nvar2r = 11 else - nvar2r = 6 + nvar2r = 10 endif nvar3 = 5 else @@ -1869,13 +1884,17 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta #ifdef CCPP if (Model%lsm == Model%lsm_ruc) then sfc_name2(nvar2m+19) = 'wetness' - sfc_name2(nvar2m+20) = 'clw_surf' - sfc_name2(nvar2m+21) = 'qwv_surf' - sfc_name2(nvar2m+22) = 'tsnow' - sfc_name2(nvar2m+23) = 'snowfall_acc' - sfc_name2(nvar2m+24) = 'swe_snowfall_acc' + sfc_name2(nvar2m+20) = 'clw_surf_land' + sfc_name2(nvar2m+21) = 'clw_surf_ice' + sfc_name2(nvar2m+22) = 'qwv_surf_land' + sfc_name2(nvar2m+23) = 'qwv_surf_ice' + sfc_name2(nvar2m+24) = 'tsnow_land' + sfc_name2(nvar2m+25) = 'tsnow_ice' + sfc_name2(nvar2m+26) = 'snowfall_acc_land' + sfc_name2(nvar2m+27) = 'snowfall_acc_ice' + sfc_name2(nvar2m+28) = 'sncovr_ice' if (Model%rdlai) then - sfc_name2(nvar2m+25) = 'lai' + sfc_name2(nvar2m+29) = 'lai' endif else if(Model%lsm == Model%lsm_noahmp) then #else @@ -2094,13 +2113,17 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta if (Model%lsm == Model%lsm_ruc) then !--- Extra RUC variables sfc_var2(i,j,nvar2m+19) = Sfcprop(nb)%wetness(ix) - sfc_var2(i,j,nvar2m+20) = Sfcprop(nb)%clw_surf(ix) - sfc_var2(i,j,nvar2m+21) = Sfcprop(nb)%qwv_surf(ix) - sfc_var2(i,j,nvar2m+22) = Sfcprop(nb)%tsnow(ix) - sfc_var2(i,j,nvar2m+23) = Sfcprop(nb)%snowfallac(ix) - sfc_var2(i,j,nvar2m+24) = Sfcprop(nb)%acsnow(ix) + sfc_var2(i,j,nvar2m+20) = Sfcprop(nb)%clw_surf_land(ix) + sfc_var2(i,j,nvar2m+21) = Sfcprop(nb)%clw_surf_ice(ix) + sfc_var2(i,j,nvar2m+22) = Sfcprop(nb)%qwv_surf_land(ix) + sfc_var2(i,j,nvar2m+23) = Sfcprop(nb)%qwv_surf_ice(ix) + sfc_var2(i,j,nvar2m+24) = Sfcprop(nb)%tsnow_land(ix) + sfc_var2(i,j,nvar2m+25) = Sfcprop(nb)%tsnow_ice(ix) + sfc_var2(i,j,nvar2m+26) = Sfcprop(nb)%snowfallac_land(ix) + sfc_var2(i,j,nvar2m+27) = Sfcprop(nb)%snowfallac_ice(ix) + sfc_var2(i,j,nvar2m+28) = Sfcprop(nb)%sncovr_ice(ix) if (Model%rdlai) then - sfc_var2(i,j,nvar2m+25) = Sfcprop(nb)%xlaixy(ix) + sfc_var2(i,j,nvar2m+29) = Sfcprop(nb)%xlaixy(ix) endif else if (Model%lsm == Model%lsm_noahmp) then From c59787a89dd81f3a642a4ec8c6a32dab20e6ab56 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 8 Dec 2020 15:54:33 -0700 Subject: [PATCH 003/115] Update gsl/develop from develop 2020/12/08 (#61) * Fix for updating stochastic physics on separate time-step. (#199) This bug fix allows the random patterns in the stochastic physics persist the for a period of time (defined as SKEBINT,SPPTINT, etc.) before calculating new patterns. The fix is to move the allocation of the saved variables into the init section of stochastic_physics_wrapper, and remove the deallocates in the run section. * Bug fixes in (1) running with frac_grid=T and GFDL MP and (2) restarting with frac_grid=T (#204) * -- Pointing to Moorthi's modifications in ccpp/physics, which fixed the crash when running GFDL MP with frac_grid=T; -- Not setting fice to zero in order to leave lake ice untouched; -- Restart in the coupled model with the default physics is reproducible, if bad water temperature is only filtered at initial time; Co-authored-with: Shrinivas Moorthi Co-authored-with: Denise Worthen * Revert change to .gitmodules and update submodule pointer for ccpp-physics Co-authored-by: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Co-authored-by: shansun6 <48043606+shansun6@users.noreply.github.com> --- atmos_model.F90 | 8 +- ccpp/physics | 2 +- io/FV3GFS_io.F90 | 45 ++++--- .../stochastic_physics_wrapper.F90 | 111 ++++++++++-------- 4 files changed, 97 insertions(+), 69 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 860079949..051f5918d 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -100,7 +100,7 @@ module atmos_model_mod use IPD_driver, only: IPD_initialize, IPD_initialize_rst use CCPP_driver, only: CCPP_step, non_uniform_blocks -use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper +use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper,stochastic_physics_wrapper_end #else use IPD_driver, only: IPD_initialize, IPD_initialize_rst, IPD_step use physics_abstraction_layer, only: time_vary_step, radiation_step1, physics_step1, physics_step2 @@ -962,6 +962,9 @@ subroutine atmos_model_end (Atmos) !---- termination routine for atmospheric model ---- call atmosphere_end (Atmos % Time, Atmos%grid, restart_endfcst) + + call stochastic_physics_wrapper_end(IPD_Control) + if(restart_endfcst) then call FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, & IPD_Control, Atmos%domain) @@ -1761,7 +1764,6 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) ofrac = IPD_Data(nb)%Sfcprop%oceanfrac(ix) if (ofrac > zero) then @@ -1776,7 +1778,7 @@ subroutine assign_importdata(rc) if (abs(one-ofrac) < epsln) then IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero - end if + endif endif endif enddo diff --git a/ccpp/physics b/ccpp/physics index bafcc9ebb..91b772665 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit bafcc9ebb6788696666e7592cf7577db81e5fbbe +Subproject commit 91b77266541d8a80dd23d09f80ee1e72e34af2d9 diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index a710941e2..46fdd8779 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1070,14 +1070,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif if(Model%frac_grid) then ! obtain slmsk from landfrac -!! next 5 lines are temporary till lake model is available - if (Sfcprop(nb)%lakefrac(ix) > zero) then -! Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) - Sfcprop(nb)%landfrac(ix) = one - Sfcprop(nb)%lakefrac(ix) - if (Sfcprop(nb)%lakefrac(ix) == zero) Sfcprop(nb)%fice(ix) = zero - endif - Sfcprop(nb)%slmsk(ix) = ceiling(Sfcprop(nb)%landfrac(ix)) - if (Sfcprop(nb)%fice(ix) > Model%min_lakeice .and. Sfcprop(nb)%landfrac(ix) == zero) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist + Sfcprop(nb)%slmsk(ix) = ceiling(Sfcprop(nb)%landfrac(ix)) !nint/floor are options else ! obtain landfrac from slmsk if (Sfcprop(nb)%slmsk(ix) > 1.9_r8) then Sfcprop(nb)%landfrac(ix) = zero @@ -1088,16 +1081,32 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell -! if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then -! Sfcprop(nb)%fice(ix) = zero -! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 -! endif + if (Sfcprop(nb)%slmsk(ix) /= one) then + if (Sfcprop(nb)%fice(ix) >= Model%min_lakeice) then + if (Sfcprop(nb)%slmsk(ix) < 1.9_r8) & + write(*,'(a,2i3,3f6.2)') 'reset lake slmsk=2 at nb,ix=' & + ,nb,ix,Sfcprop(nb)%fice(ix),Sfcprop(nb)%slmsk(ix),Sfcprop(nb)%lakefrac(ix) + Sfcprop(nb)%slmsk(ix) = 2. + else if (Sfcprop(nb)%slmsk(ix) > 1.e-7) then + write(*,'(a,2i3,3f6.2)') 'reset lake slmsk=0 at nb,ix=' & + ,nb,ix,Sfcprop(nb)%fice(ix),Sfcprop(nb)%slmsk(ix),Sfcprop(nb)%lakefrac(ix) + Sfcprop(nb)%slmsk(ix) = zero + end if + end if else Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) -! if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then -! Sfcprop(nb)%fice(ix) = zero -! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 -! endif + if (Sfcprop(nb)%slmsk(ix) /= one) then + if (Sfcprop(nb)%fice(ix) >= Model%min_seaice) then + if (Sfcprop(nb)%slmsk(ix) < 1.9_r8) & + write(*,'(a,2i3,3f6.2)') 'reset sea slmsk=2 at nb,ix=' & + ,nb,ix,Sfcprop(nb)%fice(ix),Sfcprop(nb)%slmsk(ix),Sfcprop(nb)%landfrac(ix) + Sfcprop(nb)%slmsk(ix) = 2. + else if (Sfcprop(nb)%slmsk(ix) > 1.e-7) then + write(*,'(a,2i3,4f6.2)') 'reset sea slmsk=0 at nb,ix=' & + ,nb,ix,Sfcprop(nb)%fice(ix),Sfcprop(nb)%slmsk(ix),Sfcprop(nb)%landfrac(ix) + Sfcprop(nb)%slmsk(ix) = zero + end if + end if endif ! !--- NSSTM variables @@ -1351,7 +1360,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif if (sfc_var2(i,j,nvar_s2m) < -9990.0_r8) then - if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorlw') !$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -1366,7 +1375,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !$omp parallel do default(shared) private(nb, ix, tem, tem1) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%tsfco(ix) = max(con_tice, Sfcprop(nb)%tsfco(ix)) + if( Model%phour < 1.e-7) Sfcprop(nb)%tsfco(ix) = max(con_tice, Sfcprop(nb)%tsfco(ix)) ! this may break restart reproducibility tem1 = one - Sfcprop(nb)%landfrac(ix) tem = tem1 * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90 index b5a1be065..5a3701aa8 100644 --- a/stochastic_physics/stochastic_physics_wrapper.F90 +++ b/stochastic_physics/stochastic_physics_wrapper.F90 @@ -92,16 +92,36 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) return endif end if + allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + if (GFS_Control%do_sppt) then + allocate(sppt_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) + end if + if (GFS_Control%do_shum) then + allocate(shum_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) + end if + if (GFS_Control%do_skeb) then + allocate(skebu_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) + allocate(skebv_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) + end if + if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast + allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%n_var_lndp)) + end if + if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme + allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(stype(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(vfrac(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + endif + + do nb=1,Atm_block%nblks + xlat(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlat(:) + xlon(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlon(:) + end do if ( GFS_Control%lndp_type .EQ. 1 ) then ! this scheme sets perts once - ! Copy blocked data into contiguous arrays; no need to copy sfc_wts in (intent out) - allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz))) - allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%n_var_lndp)) - do nb=1,Atm_block%nblks - xlat(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlat(:) - xlon(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlon(:) - end do call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, & sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & nthreads=nthreads) @@ -109,8 +129,6 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) end do - deallocate(xlat) - deallocate(xlon) deallocate(sfc_wts) end if ! Consistency check for cellular automata @@ -126,27 +144,6 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) else initalize_stochastic_physics if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .EQ. 2) ) then - ! Copy blocked data into contiguous arrays; no need to copy weights in (intent(out)) - allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz))) - allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz))) - do nb=1,Atm_block%nblks - xlat(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlat(:) - xlon(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlon(:) - end do - if (GFS_Control%do_sppt) then - allocate(sppt_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) - end if - if (GFS_Control%do_shum) then - allocate(shum_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) - end if - if (GFS_Control%do_skeb) then - allocate(skebu_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) - allocate(skebv_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) - end if - if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast - allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%n_var_lndp)) - end if - call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, & sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & nthreads=nthreads) @@ -155,32 +152,23 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%sppt_wts(:,:) = sppt_wts(nb,1:GFS_Control%blksz(nb),:) end do - deallocate(sppt_wts) end if if (GFS_Control%do_shum) then do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%shum_wts(:,:) = shum_wts(nb,1:GFS_Control%blksz(nb),:) end do - deallocate(shum_wts) end if if (GFS_Control%do_skeb) then do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%skebu_wts(:,:) = skebu_wts(nb,1:GFS_Control%blksz(nb),:) GFS_Data(nb)%Coupling%skebv_wts(:,:) = skebv_wts(nb,1:GFS_Control%blksz(nb),:) end do - deallocate(skebu_wts) - deallocate(skebv_wts) end if if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) end do - allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) - allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) - allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) - allocate(stype(1:Atm_block%nblks,maxval(GFS_Control%blksz))) - allocate(vfrac(1:Atm_block%nblks,maxval(GFS_Control%blksz))) do nb=1,Atm_block%nblks stype(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%stype(:) smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smc(:,:) @@ -202,21 +190,13 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) write(6,*) 'call to GFS_apply_lndp failed' return endif - deallocate(stype) - deallocate(sfc_wts) do nb=1,Atm_block%nblks GFS_Data(nb)%Sfcprop%smc(:,:) = smc(nb,1:GFS_Control%blksz(nb),:) GFS_Data(nb)%Sfcprop%slc(:,:) = slc(nb,1:GFS_Control%blksz(nb),:) GFS_Data(nb)%Sfcprop%stc(:,:) = stc(nb,1:GFS_Control%blksz(nb),:) GFS_Data(nb)%Sfcprop%vfrac(:) = vfrac(nb,1:GFS_Control%blksz(nb)) enddo - deallocate(smc) - deallocate(slc) - deallocate(stc) - deallocate(vfrac) endif ! lndp block - deallocate(xlat) - deallocate(xlon) end if endif initalize_stochastic_physics @@ -309,4 +289,41 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) end subroutine stochastic_physics_wrapper + + subroutine stochastic_physics_wrapper_end (GFS_Control) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type + use stochastic_physics, only: finalize_stochastic_physics + + implicit none + + type(GFS_control_type), intent(inout) :: GFS_Control + + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .GT. 0) ) then + if (allocated(xlat)) deallocate(xlat) + if (allocated(xlon)) deallocate(xlon) + if (GFS_Control%do_sppt) then + if (allocated(sppt_wts)) deallocate(sppt_wts) + end if + if (GFS_Control%do_shum) then + if (allocated(shum_wts)) deallocate(shum_wts) + end if + if (GFS_Control%do_skeb) then + if (allocated(skebu_wts)) deallocate(skebu_wts) + if (allocated(skebv_wts)) deallocate(skebv_wts) + end if + if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast + if (allocated(sfc_wts)) deallocate(sfc_wts) + end if + if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme + if (allocated(smc)) deallocate(smc) + if (allocated(slc)) deallocate(slc) + if (allocated(stc)) deallocate(stc) + if (allocated(stype)) deallocate(stype) + if (allocated(vfrac)) deallocate(vfrac) + endif + call finalize_stochastic_physics() + endif + end subroutine stochastic_physics_wrapper_end + end module stochastic_physics_wrapper_mod From b1e98cf2b91a593203637115b85882c0ba198aa4 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 16 Dec 2020 13:37:51 -0700 Subject: [PATCH 004/115] Update submodule pointer for ccpp-physics - MYNN surface layer updates and bugfixes (#63) --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 91b772665..0ac8068d5 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 91b77266541d8a80dd23d09f80ee1e72e34af2d9 +Subproject commit 0ac8068d53a19d342fc176dd62d4267f1b43008e From 6ecee94d0cdc82def576d56633a8a1ec93da39bd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 8 Jan 2021 19:51:30 -0700 Subject: [PATCH 005/115] Land stochastic perturbations (wrapper PR for #65) (#68) * Move initialization of stochastic physics after the physics initialization in CCPP. * Add albedo variables to land perturbations with lndp_type=2 option. Change to accommodate soil perturbations with RUC LSM. * Max/min soil moisture variables are introduced via GFS_Control_type variables instead of through the use of namelist_soilveg*. This is a more flexible way for different LSMs. * Added pores and resid variables for max/min soil moisture to GFS_typedefs.f90. * Remove tracer_sanitizer from all suites and from CCPP prebuild config * Add namelist option to apply land surface perturbations at every time step, clean up stochastic_physics/stochastic_physics_wrapper.F90 Co-authored-by: tanyasmirnova --- atmos_model.F90 | 9 +- ccpp/config/ccpp_prebuild_config.py | 1 - ccpp/physics | 2 +- ccpp/suites/suite_FV3_GSD_noah.xml | 1 - ccpp/suites/suite_FV3_GSD_v0.xml | 1 - gfsphysics/GFS_layer/GFS_typedefs.F90 | 26 +++- gfsphysics/GFS_layer/GFS_typedefs.meta | 14 +++ .../stochastic_physics_wrapper.F90 | 115 +++++++++++++++--- 8 files changed, 139 insertions(+), 30 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 051f5918d..c010789cd 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -627,9 +627,9 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) IPD_Interstitial, commglobal, mpp_npes(), Init_parm) !--- Initialize stochastic physics pattern generation / cellular automata for first time step - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) - if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') - +! call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) +! if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') +! #else call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) #endif @@ -684,6 +684,9 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) ! Initialize the CCPP physics call CCPP_step (step="physics_init", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_init step failed') +!--- Initialize stochastic physics pattern generation / cellular automata for first time step + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') #endif !--- set the initial diagnostic timestamp diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index f649535ac..cfa0b5eb6 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -159,7 +159,6 @@ 'ccpp/physics/physics/ozphys_2015.f', 'ccpp/physics/physics/precpd.f', 'ccpp/physics/physics/phys_tend.F90', - 'ccpp/physics/physics/tracer_sanitizer.F90', 'ccpp/physics/physics/radlw_main.F90', 'ccpp/physics/physics/radsw_main.F90', 'ccpp/physics/physics/rascnv.F90', diff --git a/ccpp/physics b/ccpp/physics index 0ac8068d5..acf281a01 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 0ac8068d53a19d342fc176dd62d4267f1b43008e +Subproject commit acf281a01e19b840a1f0e0fb947d9672c6d10c05 diff --git a/ccpp/suites/suite_FV3_GSD_noah.xml b/ccpp/suites/suite_FV3_GSD_noah.xml index 4d7d4e00f..42d55a5e4 100644 --- a/ccpp/suites/suite_FV3_GSD_noah.xml +++ b/ccpp/suites/suite_FV3_GSD_noah.xml @@ -79,7 +79,6 @@ mp_thompson_post GFS_MP_generic_post cu_gf_driver_post - maximum_hourly_diagnostics diff --git a/ccpp/suites/suite_FV3_GSD_v0.xml b/ccpp/suites/suite_FV3_GSD_v0.xml index 7838db77b..0d6531d19 100644 --- a/ccpp/suites/suite_FV3_GSD_v0.xml +++ b/ccpp/suites/suite_FV3_GSD_v0.xml @@ -78,7 +78,6 @@ mp_thompson_post GFS_MP_generic_post cu_gf_driver_post - maximum_hourly_diagnostics diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 2fef16ee4..1a63d5bc8 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -811,7 +811,9 @@ module GFS_typedefs integer :: lsoil_lsm !< number of soil layers internal to land surface model integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model integer :: lsnow_lsm_lbound!< lower bound for snow arrays, depending on lsnow_lsm - real(kind=kind_phys), pointer :: zs(:) => null() !< depth of soil levels for land surface model + real(kind=kind_phys), pointer :: zs(:) => null() !< depth of soil levels for land surface model + real(kind=kind_phys), pointer :: pores(:) => null() !< max soil moisture for a given soil type for land surface model + real(kind=kind_phys), pointer :: resid(:) => null() !< min soil moisture for a given soil type for land surface model logical :: rdlai !< read LAI from input file (for RUC LSM or NOAH LSM WRFv4) logical :: ua_phys !< flag for using University of Arizona? extension to NOAH LSM WRFv4 logical :: usemonalb !< flag to read surface diffused shortwave albedo from input file for NOAH LSM WRFv4 @@ -1110,6 +1112,8 @@ module GFS_typedefs integer :: skeb_npass integer :: lndp_type integer :: n_var_lndp + logical :: lndp_each_step ! flag to indicate that land perturbations are applied at every time step, + ! otherwise they are applied only after gcycle is run character(len=3) :: lndp_var_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def real(kind=kind_phys) :: lndp_prt_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def ! also previous code had dimension 5 for each pert, to allow @@ -3469,8 +3473,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: do_shum = .false. logical :: do_skeb = .false. integer :: skeb_npass = 11 - integer :: lndp_type = 0 - integer :: n_var_lndp = 0 + integer :: lndp_type = 0 + integer :: n_var_lndp = 0 + logical :: lndp_each_step = .false. !--- aerosol scavenging factors character(len=20) :: fscav_aero(20) = 'default' @@ -3555,7 +3560,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & do_deep, jcap, & cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, & dlqf, rbcr, shoc_parm, psauras, prauras, wminras, & - do_sppt, do_shum, do_skeb, lndp_type, n_var_lndp, & + do_sppt, do_shum, do_skeb, & + lndp_type, n_var_lndp, lndp_each_step, & !--- Rayleigh friction prslrd0, ral_ts, ldiag_ugwp, do_ugwp, do_tofd, & ! --- Ferrier-Aligo @@ -3981,6 +3987,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & end if ! Set number of ice model layers Model%kice = kice + + ! Allocate variable for min/max soil moisture for a given soil type + allocate (Model%pores(30)) + allocate (Model%resid(30)) + Model%pores = clear_val + Model%resid = clear_val ! if (lsnow_lsm /= 3) then write(0,*) 'Logic error: NoahMP expects the maximum number of snow layers to be exactly 3 (see sfc_noahmp_drv.f)' @@ -4216,6 +4228,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%do_skeb = do_skeb Model%lndp_type = lndp_type Model%n_var_lndp = n_var_lndp + Model%lndp_each_step = lndp_each_step !--- cellular automata options Model%nca = nca @@ -5159,6 +5172,8 @@ subroutine control_print(Model) print *, ' aoasis : ', Model%aoasis print *, ' fasdas : ', Model%fasdas print *, ' kice : ', Model%kice + print *, ' shape(pores) : ', shape(Model%pores) + print *, ' shape(resid) : ', shape(Model%resid) #endif print *, ' ivegsrc : ', Model%ivegsrc print *, ' isot : ', Model%isot @@ -5316,7 +5331,8 @@ subroutine control_print(Model) print *, ' do_shum : ', Model%do_shum print *, ' do_skeb : ', Model%do_skeb print *, ' lndp_type : ', Model%lndp_type - print *, ' n_var_lndp : ', Model%n_var_lndp + print *, ' n_var_lndp : ', Model%n_var_lndp + print *, ' lndp_each_step : ', Model%lndp_each_step print *, ' ' print *, 'cellular automata' print *, ' nca : ', Model%nca diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 4dfb5046e..dcacc8644 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -3285,6 +3285,20 @@ type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) +[pores] + standard_name = maximum_soil_moisture_content_for_land_surface_model + long_name = maximum soil moisture for a given soil type for land surface model + units = m + dimensions = (30) + type = real + kind = kind_phys +[resid] + standard_name = minimum_soil_moisture_content_for_land_surface_model + long_name = minimum soil moisture for a given soil type for land surface model + units = m + dimensions = (30) + type = real + kind = kind_phys [rdlai] standard_name = flag_for_reading_leaf_area_index_from_input long_name = flag for reading leaf area index from initial conditions diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90 index 5a3701aa8..44c82ecbd 100644 --- a/stochastic_physics/stochastic_physics_wrapper.F90 +++ b/stochastic_physics/stochastic_physics_wrapper.F90 @@ -13,10 +13,23 @@ module stochastic_physics_wrapper_mod real(kind=kind_phys), dimension(:,:,:), allocatable, save :: skebv_wts real(kind=kind_phys), dimension(:,:,:), allocatable, save :: sfc_wts + integer, save :: lsoil = -999 real(kind=kind_phys), dimension(:,:,:), allocatable, save :: smc real(kind=kind_phys), dimension(:,:,:), allocatable, save :: stc real(kind=kind_phys), dimension(:,:,:), allocatable, save :: slc + ! real(kind=kind_phys), dimension(:,:), allocatable, save :: vfrac + !albedo + real(kind=kind_phys), dimension(:,:), allocatable, save :: snoalb + real(kind=kind_phys), dimension(:,:), allocatable, save :: alvsf + real(kind=kind_phys), dimension(:,:), allocatable, save :: alnsf + real(kind=kind_phys), dimension(:,:), allocatable, save :: alvwf + real(kind=kind_phys), dimension(:,:), allocatable, save :: alnwf + real(kind=kind_phys), dimension(:,:), allocatable, save :: facsf + real(kind=kind_phys), dimension(:,:), allocatable, save :: facwf + !emissivity + real(kind=kind_phys), dimension(:,:), allocatable, save :: semis + real(kind=kind_phys), dimension(:,:), allocatable, save :: stype ! For cellular automata @@ -58,7 +71,6 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) use cellular_automata_global_mod, only: cellular_automata_global use cellular_automata_sgs_mod, only: cellular_automata_sgs use lndp_apply_perts_mod, only: lndp_apply_perts - use namelist_soilveg, only: maxsmc implicit none @@ -108,11 +120,24 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%n_var_lndp)) end if if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme - allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) - allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) - allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + if (GFS_Control%lsm == GFS_Control%lsm_noah) then + lsoil = GFS_Control%lsoil + elseif (GFS_Control%lsm == GFS_Control%lsm_ruc) then + lsoil = GFS_Control%lsoil_lsm + endif + allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),lsoil)) + allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),lsoil)) + allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),lsoil)) allocate(stype(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(vfrac(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(snoalb(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(alvsf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(alnsf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(alvwf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(alnwf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(facsf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(facwf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(semis(1:Atm_block%nblks,maxval(GFS_Control%blksz))) endif do nb=1,Atm_block%nblks @@ -171,31 +196,76 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) do nb=1,Atm_block%nblks stype(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%stype(:) - smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smc(:,:) - slc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%slc(:,:) - stc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%stc(:,:) vfrac(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%vfrac(:) + snoalb(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%snoalb(:) + alvsf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%alvsf(:) + alnsf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%alnsf(:) + alvwf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%alvwf(:) + alnwf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%alnwf(:) + facsf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%facsf(:) + facwf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%facwf(:) + semis(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Radtend%semis(:) end do - ! determine whether land paramaters have been over-written - if (mod(GFS_Control%kdt,GFS_Control%nscyc) == 1) then ! logic copied from GFS_driver - param_update_flag = .true. + if (GFS_Control%lsm == GFS_Control%lsm_noah) then + do nb=1,Atm_block%nblks + smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smc(:,:) + slc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%slc(:,:) + stc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%stc(:,:) + end do + elseif (GFS_Control%lsm == GFS_Control%lsm_ruc) then + do nb=1,Atm_block%nblks + smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smois(:,:) + slc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%sh2o(:,:) + stc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%tslb(:,:) + end do + endif + + ! determine whether land paramaters have been over-written to + ! trigger applying perturbations (logic copied from GFS_driver), + ! or if perturbations should be applied at every time step + if (mod(GFS_Control%kdt,GFS_Control%nscyc) == 1 ) then + param_update_flag = .true. else - param_update_flag = .false. + param_update_flag = .false. endif - call lndp_apply_perts( GFS_Control%blksz, GFS_Control%lsm, GFS_Control%lsoil, GFS_Control%dtf, & - GFS_Control%n_var_lndp, GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & - sfc_wts, xlon, xlat, stype, maxsmc,param_update_flag, smc, slc,stc, vfrac, ierr) + + call lndp_apply_perts(GFS_Control%blksz, GFS_Control%lsm, GFS_Control%lsm_noah, GFS_Control%lsm_ruc, lsoil, & + GFS_Control%dtf, GFS_Control%kdt, GFS_Control%lndp_each_step, & + GFS_Control%n_var_lndp, GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & + sfc_wts, xlon, xlat, stype, GFS_Control%pores, GFS_Control%resid,param_update_flag, & + smc, slc, stc, vfrac, alvsf, alnsf, alvwf, alnwf, facsf, facwf, snoalb, semis, ierr) if (ierr/=0) then write(6,*) 'call to GFS_apply_lndp failed' return endif + do nb=1,Atm_block%nblks - GFS_Data(nb)%Sfcprop%smc(:,:) = smc(nb,1:GFS_Control%blksz(nb),:) - GFS_Data(nb)%Sfcprop%slc(:,:) = slc(nb,1:GFS_Control%blksz(nb),:) - GFS_Data(nb)%Sfcprop%stc(:,:) = stc(nb,1:GFS_Control%blksz(nb),:) - GFS_Data(nb)%Sfcprop%vfrac(:) = vfrac(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%vfrac(:) = vfrac(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%snoalb(:) = snoalb(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%alvsf(:) = alvsf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%alnsf(:) = alnsf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%alvwf(:) = alvwf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%alnwf(:) = alnwf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%facsf(:) = facsf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%facwf(:) = facwf(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Radtend%semis(:) = semis(nb,1:GFS_Control%blksz(nb)) enddo + + if (GFS_Control%lsm == GFS_Control%lsm_noah) then + do nb=1,Atm_block%nblks + GFS_Data(nb)%Sfcprop%smc(:,:) = smc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%slc(:,:) = slc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%stc(:,:) = stc(nb,1:GFS_Control%blksz(nb),:) + enddo + elseif (GFS_Control%lsm == GFS_Control%lsm_ruc) then + do nb=1,Atm_block%nblks + GFS_Data(nb)%Sfcprop%smois(:,:) = smc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%sh2o(:,:) = slc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%tslb(:,:) = stc(nb,1:GFS_Control%blksz(nb),:) + enddo + endif + endif ! lndp block end if @@ -313,6 +383,7 @@ subroutine stochastic_physics_wrapper_end (GFS_Control) if (allocated(skebv_wts)) deallocate(skebv_wts) end if if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast + lsoil = -999 if (allocated(sfc_wts)) deallocate(sfc_wts) end if if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme @@ -321,6 +392,14 @@ subroutine stochastic_physics_wrapper_end (GFS_Control) if (allocated(stc)) deallocate(stc) if (allocated(stype)) deallocate(stype) if (allocated(vfrac)) deallocate(vfrac) + if (allocated(snoalb)) deallocate(snoalb) + if (allocated(alvsf)) deallocate(alvsf) + if (allocated(alnsf)) deallocate(alnsf) + if (allocated(alvwf)) deallocate(alvwf) + if (allocated(alnwf)) deallocate(alnwf) + if (allocated(facsf)) deallocate(facsf) + if (allocated(facwf)) deallocate(facwf) + if (allocated(semis)) deallocate(semis) endif call finalize_stochastic_physics() endif From fa070c83497debb2c34e310f7f6cdb767d282a80 Mon Sep 17 00:00:00 2001 From: tanyasmirnova <38667904+tanyasmirnova@users.noreply.github.com> Date: Tue, 19 Jan 2021 11:28:37 -0700 Subject: [PATCH 006/115] Stochastic land perturbations: add roughness length over land to the perturbed variables (#70) * Added roughness length over land to the perturbed variables. * Bugfix in gfsphysics/GFS_layer/GFS_typedefs.F90: remove Diag%cldcov, in particular the reset call because the variable is not allocated Co-authored-by: Dom Heinzeller --- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 13 ++++--------- stochastic_physics/stochastic_physics_wrapper.F90 | 8 +++++++- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index acf281a01..1fd346fc6 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit acf281a01e19b840a1f0e0fb947d9672c6d10c05 +Subproject commit 1fd346fc6eabc6d26f6dfca6056323baf478a082 diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 1a63d5bc8..8868ae0b8 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1618,7 +1618,6 @@ module GFS_typedefs 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 !--- F-A MP scheme #ifdef CCPP real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1) @@ -5892,7 +5891,6 @@ subroutine diag_create (Diag, IM, Model) ! 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 !vay-2018 @@ -6089,9 +6087,6 @@ subroutine diag_rad_zero(Diag, Model) 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 @@ -6241,11 +6236,11 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%dv3dt = zero Diag%dt3dt = zero if (Model%qdiag3d) then - Diag%dq3dt = zero + Diag%dq3dt = zero +! Diag%upd_mf = zero +! Diag%dwn_mf = zero +! Diag%det_mf = zero endif -! Diag%upd_mf = zero -! Diag%dwn_mf = zero -! Diag%det_mf = zero endif ! diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90 index 44c82ecbd..479270a9f 100644 --- a/stochastic_physics/stochastic_physics_wrapper.F90 +++ b/stochastic_physics/stochastic_physics_wrapper.F90 @@ -29,6 +29,8 @@ module stochastic_physics_wrapper_mod real(kind=kind_phys), dimension(:,:), allocatable, save :: facwf !emissivity real(kind=kind_phys), dimension(:,:), allocatable, save :: semis + !roughness length for land + real(kind=kind_phys), dimension(:,:), allocatable, save :: zorll real(kind=kind_phys), dimension(:,:), allocatable, save :: stype @@ -138,6 +140,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) allocate(facsf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(facwf(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(semis(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(zorll(1:Atm_block%nblks,maxval(GFS_Control%blksz))) endif do nb=1,Atm_block%nblks @@ -205,6 +208,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) facsf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%facsf(:) facwf(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%facwf(:) semis(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Radtend%semis(:) + zorll(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%zorll(:) end do if (GFS_Control%lsm == GFS_Control%lsm_noah) then @@ -234,7 +238,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) GFS_Control%dtf, GFS_Control%kdt, GFS_Control%lndp_each_step, & GFS_Control%n_var_lndp, GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & sfc_wts, xlon, xlat, stype, GFS_Control%pores, GFS_Control%resid,param_update_flag, & - smc, slc, stc, vfrac, alvsf, alnsf, alvwf, alnwf, facsf, facwf, snoalb, semis, ierr) + smc, slc, stc, vfrac, alvsf, alnsf, alvwf, alnwf, facsf, facwf, snoalb, semis, zorll, ierr) if (ierr/=0) then write(6,*) 'call to GFS_apply_lndp failed' return @@ -250,6 +254,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) GFS_Data(nb)%Sfcprop%facsf(:) = facsf(nb,1:GFS_Control%blksz(nb)) GFS_Data(nb)%Sfcprop%facwf(:) = facwf(nb,1:GFS_Control%blksz(nb)) GFS_Data(nb)%Radtend%semis(:) = semis(nb,1:GFS_Control%blksz(nb)) + GFS_Data(nb)%Sfcprop%zorll(:) = zorll(nb,1:GFS_Control%blksz(nb)) enddo if (GFS_Control%lsm == GFS_Control%lsm_noah) then @@ -400,6 +405,7 @@ subroutine stochastic_physics_wrapper_end (GFS_Control) if (allocated(facsf)) deallocate(facsf) if (allocated(facwf)) deallocate(facwf) if (allocated(semis)) deallocate(semis) + if (allocated(zorll)) deallocate(zorll) endif call finalize_stochastic_physics() endif From c48b45a9473a7f21a66c7c2217fd6e06590d6297 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 22 Feb 2021 20:35:56 -0700 Subject: [PATCH 007/115] Update gsl/develop from develop 2021/02/22 (#73) * Fix for updating stochastic physics on separate time-step. (#199) This bug fix allows the random patterns in the stochastic physics persist the for a period of time (defined as SKEBINT,SPPTINT, etc.) before calculating new patterns. The fix is to move the allocation of the saved variables into the init section of stochastic_physics_wrapper, and remove the deallocates in the run section. * Bug fixes in (1) running with frac_grid=T and GFDL MP and (2) restarting with frac_grid=T (#204) * -- Pointing to Moorthi's modifications in ccpp/physics, which fixed the crash when running GFDL MP with frac_grid=T; -- Not setting fice to zero in order to leave lake ice untouched; -- Restart in the coupled model with the default physics is reproducible, if bad water temperature is only filtered at initial time; Co-authored-with: Shrinivas Moorthi Co-authored-with: Denise Worthen * jedi-ufs with ccpp-physics submodule update (contains #201) (#211) * updated CMakeLists.txt * Changes for JEDI linking/control * Update .gitmodules and submodule pointer for ccpp-physics for code review and testing * Revert change to .gitmodules and update submodule pointer for ccpp-physics Co-authored-by: Mark Potts * Final-final GFS v16 updates / restart reproducibility bugfixes (#212) * updates the submodule pointer for ccpp-physics for the final-final (!) GFS v16 physics updates * fixes a bug in io/FV3GFS_io.F90 to obtain restart reproducibility for uncoupled and coupled runs - contributed by @SMoorthi-emc Co-authored-by: Shrinivas.Moorthi * RRTMGP coupling to Thompson MP in ccpp-physics (#208) * Updated physics. Added infrastructure to FV3 to handle new GP capabilities. Thompson MP, LW scattering, Use of LW-jacobian to update surface tendencies. * Some small changes to work with physics improvements to RRTMGP. * RRTMGP working with Thompson MP. * Updated .gitmodules. * Updated physics. New interstitials. * Synced with NCAR/master * Updated ccpp-physics * Updated physics submodule. * Cleanup * Update physics * Updated physics submodule pointer. * Updated physics submodule hash. * Minor bug fixes to CCPP UGWP (update submodule pointer for ccpp-physics) (#216) Update the submodule pointer for ccpp-physics for minor bugfixes in CCPP's Unified Gravity Wave Drag parameterization. * Remove IPD (step 1) (#215) Remove all IPD source files that are not needed to compile with CCPP. Update gfsphysics/CMakeLists.txt and gfsphysics/GFS_layer/GFS_driver.F90 so that the code compiles after removing IPD sources. Also: update submodule pointer for GFDL_atmos_cubed_sphere to include PR NOAA-EMC/GFDL_atmos_cubed_sphere#48 ("Removed use of mpp_node for use with FMS 2020.04"). * Update submodule pointers for ccpp-framework (ccpp_prebuild bugfix) and ccpp-physics (RRTMGP GFDL-MP bugfix) (#218) Update the submodule pointers for ccpp-framework and ccpp-physics for the changes described in NCAR/ccpp-framework#343 and NCAR/ccpp-physics#536. * Remove unnecessary SIMD instruction sets from ccpp/CMakeLists.txt (#220) * Remove additional/unnecessary SIMD instruction sets from ccpp/CMakeLists.txt * Implementation of CCPP timestep_init and timestep_final phases (#217) - replace calls to CCPP step `time_vary` with `timestep_init` in `atmos_model.F90`, add call to CCPP step `timestep_final` - update `ccpp/driver/CCPP_driver.F90` with calls to CCPP `timestep_init` and `timestep_final` - add `h2o_def.f` and `ozne_def.` to `ccpp_prebuild_config.py` - update of `gfsphysics/GFS_layer/GFS_typedefs.F90`: cleanup work for o3 and h2o physics (required by the updates to the CCPP time vary physics) - update metadata in `gfsphysics/GFS_layer/GFS_typedefs.meta` for the above changes, and clean up the index used for the surface wind enhancement due to convection in the `phy_f2d` array (use proper index, not just the last entry in the array) * add radiation_clouds_thompson_dependency in ccpp physics (#225) * using radiation_clouds_thompson_dependency ccpp physics branch * point to ccpp master branch * Remove IPD steps 3 and 5 (#224) * Implementation of CCPP timestep_init and timestep_final phases in fv3atm; cleanup work in GFS_typedefs for o3 and h2o physics as a result of the changes to the time vary physics in CCPP * Use proper index variable for surface wind enhancement due to convection in phy_f2d array in GFS_typedefs.{F90,meta}, move code to clear diagnostic buckets using GFS DDT bound procedures from atmos_model.F90 to CCPP_driver.F90 * First step of cleanup process: remove CCPP preprocessor directives, remove parts of unused IPD code, update cmake build system, Delete IPD source code, Replace IPD DDTs with GFS DDTs, Bugfix in atmos_model.F90; add missing call to GFS_externaldiag_populate, Move contents of gfsphysics/{CCPP_layer,GFS_layer} to ccpp/{data,driver}, entirely deleted IPD typedefs, Rename module GFS_driver to GFS_init * Fix indentation in ccpp/data/CMakeLists.txt and ccpp/driver/CMakeLists.txt * Add logic to set DYN32 depending on 32BIT setting * Pass preprocessor directive GFS_TYPES to dycore to enable use of GFS data types * Compile GFS_diagnostics.F90 without optimization, this leads to out of memory errors on wcoss_dell_p3 * Add CCPP rrtmgp fix (#237) * ccpp physics merged with top of master * point back to ccpp master branch * Update develop from NOAA-GSL: RUC ice, MYNN sfclay, stochastic land perturbations (#239) * Update .gitmodules and submodule pointers for ccpp-framework and ccpp-physics for gsl/develop branch * RUC ice for gsl/develop (replaces #54 and #56) (#60) Implementation of RUC LSM ice model in CCPP * Fix bug in gfsphysics/GFS_layer/GFS_typedefs.F90 from merge * Remove lsm_ruc_sfc_sice from suite FV3_GSD_v0_unified_ugwp_suite and update submodule pointer for ccpp-physics * Remove sfc_sice from ccpp/suites/suite_FV3_GSD_v0_unified_ugwp_suite.xml * Update gsl/develop from develop 2020/12/08 (#61) * Fix for updating stochastic physics on separate time-step. (#199) This bug fix allows the random patterns in the stochastic physics persist the for a period of time (defined as SKEBINT,SPPTINT, etc.) before calculating new patterns. The fix is to move the allocation of the saved variables into the init section of stochastic_physics_wrapper, and remove the deallocates in the run section. * Bug fixes in (1) running with frac_grid=T and GFDL MP and (2) restarting with frac_grid=T (#204) * -- Pointing to Moorthi's modifications in ccpp/physics, which fixed the crash when running GFDL MP with frac_grid=T; -- Not setting fice to zero in order to leave lake ice untouched; -- Restart in the coupled model with the default physics is reproducible, if bad water temperature is only filtered at initial time; Co-authored-with: Shrinivas Moorthi Co-authored-with: Denise Worthen * Revert change to .gitmodules and update submodule pointer for ccpp-physics * Update submodule pointer for ccpp-physics - MYNN surface layer updates and bugfixes (#63) * Land stochastic perturbations (wrapper PR for #65) (#68) * Move initialization of stochastic physics after the physics initialization in CCPP. * Add albedo variables to land perturbations with lndp_type=2 option. Change to accommodate soil perturbations with RUC LSM. * Max/min soil moisture variables are introduced via GFS_Control_type variables instead of through the use of namelist_soilveg*. This is a more flexible way for different LSMs. * Added pores and resid variables for max/min soil moisture to GFS_typedefs.f90. * Remove tracer_sanitizer from all suites and from CCPP prebuild config * Add namelist option to apply land surface perturbations at every time step, clean up stochastic_physics/stochastic_physics_wrapper.F90 * Stochastic land perturbations: add roughness length over land to the perturbed variables (#70) * Added roughness length over land to the perturbed variables. * Bugfix in gfsphysics/GFS_layer/GFS_typedefs.F90: remove Diag%cldcov, in particular the reset call because the variable is not allocated * Update .gitmodules and submodule pointer for GFDL_atmos_cubed_sphere for code review and testing * Revert change to .gitmodules for ccpp-physics, update submodule pointer for ccpp-physics * Revert change to .gitmodules and update submodule pointer for GFDL_atmos_cubed_sphere Co-authored-by: DomHeinzeller <58610420+DomHeinzeller@users.noreply.github.com> Co-authored-by: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Co-authored-by: shansun6 <48043606+shansun6@users.noreply.github.com> Co-authored-by: tanyasmirnova * Dycore change to add an option to zero-gradient BC for height advection and change dz_min as a namelist input (#232) * Point dycore to a personal branch * Point to new version of dycore * Update the dycore version * Update the dycore version * Point to NOAA-EMC dev/emc dycore branch * Remove gnumake build remnants, change v16beta to v16 (#234) * Remove gnumake files * Replace v16beta with v16 for all CCPP suites * Remove unused CCPP_INCLUDE_DIRS/CCPP_LIB_DIRS from ccpp/CMakeLists.txt * Move LSM vegetation lookup tables into CCPP, clean up RUC snow cover on ice initialization (remove IPD step 2) (#244) * Move LSM vegetation lookup tables into CCPP, clean up RUC snow cover on ice initialization * Revert change to .gitmodules and update submodule pointer for ccpp-physics * UGWP v0 v1 combined (#241) * .gitmodules/gsl atmos-cubed cccp-fram cccp/physics * update fv3atm from NOAA-EMC Jan 9 * new suite_FV3_GFS_v16b_ugwpv1.xml and modifications Jan 11/2021 * Added new logical flag do_ugwp_v0_nst_only which allows non-stationary drag from ugwp_v0 to be run with GSL drag suite * Fix formatting in ccpp/data/GFS_typedefs.* * Clean up allocation of arrays in ccpp/data/GFS_typedefs.F90, add active attribute (pass 1) to ccpp/data/GFS_typedefs.meta, strip trailing whitespaces from both * Update and cleanup of metadata for UGWPv0, UGWPv1, drag suite * Reorganize UGWP diagnostic variables in data/GFS_typedefs.{F90,meta} * Bugfix for uninitialized data in ccpp/data/GFS_typedefs.F90 * Update submodule pointer for ccpp-physics * Allocate 3d diagnostic arrays as dummy arrays if not used Co-authored-by: valery.yudin Co-authored-by: Michael Toy * SDF for GFSv16 with Thompson (#238) * SDF for GFSv16 with Thompson * Delete suite_FV3_GFS_v16beta_thompson.xml * update to new commit of Thompson MP in ccpp physics Co-authored-by: Phil Pegion <38869668+pjpegion@users.noreply.github.com> Co-authored-by: shansun6 <48043606+shansun6@users.noreply.github.com> Co-authored-by: Mark Potts Co-authored-by: Shrinivas.Moorthi Co-authored-by: dustinswales Co-authored-by: Jun Wang <37633869+junwang-noaa@users.noreply.github.com> Co-authored-by: XiaqiongZhou-NOAA <48254930+XiaqiongZhou-NOAA@users.noreply.github.com> Co-authored-by: valery.yudin Co-authored-by: Michael Toy Co-authored-by: XiaSun-NOAA <58949533+XiaSun-NOAA@users.noreply.github.com> --- CMakeLists.txt | 114 +- atmos_cubed_sphere | 2 +- atmos_model.F90 | 816 +- ccpp/CMakeLists.txt | 14 +- ccpp/build_ccpp.sh | 193 - ccpp/config/ccpp_prebuild_config.py | 24 +- .../CCPP_layer => ccpp/data}/CCPP_data.F90 | 0 .../CCPP_layer => ccpp/data}/CCPP_data.meta | 2 +- .../data}/CCPP_typedefs.F90 | 0 .../data}/CCPP_typedefs.meta | 2 +- ccpp/data/CMakeLists.txt | 43 + .../GFS_layer => ccpp/data}/GFS_typedefs.F90 | 1284 +- .../GFS_layer => ccpp/data}/GFS_typedefs.meta | 766 +- ccpp/driver/CCPP_driver.F90 | 73 +- ccpp/driver/CMakeLists.txt | 34 +- .../driver}/GFS_diagnostics.F90 | 120 - ccpp/driver/GFS_init.F90 | 173 + .../GFS_layer => ccpp/driver}/GFS_restart.F90 | 11 +- ccpp/driver/makefile | 71 - ccpp/framework | 2 +- ccpp/physics | 2 +- ccpp/set_compilers.sh | 101 - ccpp/suites/suite_FV3_GFS_v15p2_RRTMGP.xml | 1 + ..._GFS_v16beta.xml => suite_FV3_GFS_v16.xml} | 2 +- ...RTMGP.xml => suite_FV3_GFS_v16_RRTMGP.xml} | 3 +- ...pled.xml => suite_FV3_GFS_v16_coupled.xml} | 2 +- ..._flake.xml => suite_FV3_GFS_v16_flake.xml} | 2 +- ...nsst.xml => suite_FV3_GFS_v16_no_nsst.xml} | 2 +- ccpp/suites/suite_FV3_GFS_v16_thompson.xml | 91 + ccpp/suites/suite_FV3_GFS_v16b_ugwpv1.xml | 94 + ccpp/suites/suite_FV3_GSD_v0_RRTMGP.xml | 101 + conf/make.rules | 30 - cpl/makefile | 66 - gfsphysics/CMakeLists.txt | 202 +- .../GFS_layer/GFS_abstraction_layer.F90 | 94 - gfsphysics/GFS_layer/GFS_driver.F90 | 1114 - gfsphysics/GFS_layer/GFS_physics_driver.F90 | 6010 --- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 2206 -- gfsphysics/makefile | 273 - gfsphysics/physics/GFDL_parse_tracers.F90 | 41 - gfsphysics/physics/GFS_debug.F90 | 799 - gfsphysics/physics/aer_cloud.F | 4023 -- gfsphysics/physics/aerclm_def.f | 23 - gfsphysics/physics/aerinterp.f90 | 363 - gfsphysics/physics/calpreciptype.f90 | 1343 - gfsphysics/physics/cires_orowam2017.f | 339 - gfsphysics/physics/cires_ugwp_initialize.F90 | 704 - gfsphysics/physics/cires_ugwp_module.F90 | 670 - gfsphysics/physics/cires_ugwp_solvers.F90 | 664 - gfsphysics/physics/cires_ugwp_triggers.F90 | 562 - gfsphysics/physics/cires_ugwp_utils.F90 | 152 - gfsphysics/physics/cires_vert_lsatdis.F90 | 524 - gfsphysics/physics/cires_vert_orodis.F90 | 1018 - gfsphysics/physics/cires_vert_wmsdis.F90 | 425 - gfsphysics/physics/cldmacro.F | 2371 -- gfsphysics/physics/cldwat2m_micro.F | 5509 --- gfsphysics/physics/cnvc90.f | 90 - gfsphysics/physics/co2hc.f | 1738 - gfsphysics/physics/cs_conv.F90 | 3935 -- gfsphysics/physics/date_def.f | 13 - gfsphysics/physics/dcyc2.f | 313 - gfsphysics/physics/dcyc2.pre.rad.f | 206 - gfsphysics/physics/efield.f | 3241 -- gfsphysics/physics/funcphys.f90 | 2899 -- gfsphysics/physics/gcm_shoc.f90 | 1748 - gfsphysics/physics/gcycle.F90 | 265 - gfsphysics/physics/get_prs.f | 382 - gfsphysics/physics/get_prs_fv3.f90 | 60 - gfsphysics/physics/gfdl_cloud_microphys.F90 | 4975 --- gfsphysics/physics/gfs_phy_tracer_config.F | 240 - .../physics/gocart_tracer_config_stub.f | 17 - gfsphysics/physics/gscond.f | 521 - gfsphysics/physics/gscondp.f | 358 - gfsphysics/physics/gwdc.f | 1366 - gfsphysics/physics/gwdps.f | 1432 - gfsphysics/physics/h2o_def.f | 12 - gfsphysics/physics/h2oc.f | 894 - gfsphysics/physics/h2ohdc.f | 165 - gfsphysics/physics/h2ointerp.f90 | 187 - gfsphysics/physics/h2ophys.f | 100 - gfsphysics/physics/iccn_def.f | 15 - gfsphysics/physics/iccninterp.f90 | 238 - gfsphysics/physics/idea_co2.f | 73 - gfsphysics/physics/idea_composition.f | 237 - gfsphysics/physics/idea_dissipation.f | 191 - gfsphysics/physics/idea_h2o.f | 95 - gfsphysics/physics/idea_ion.f | 1845 - gfsphysics/physics/idea_o2_o3.f | 153 - gfsphysics/physics/idea_phys.f | 605 - gfsphysics/physics/idea_solar_heating.f | 1227 - gfsphysics/physics/idea_tracer.f | 419 - gfsphysics/physics/ideaca.f | 232 - gfsphysics/physics/iounitdef.f | 94 - gfsphysics/physics/lrgsclr.f | 289 - gfsphysics/physics/m_micro_driver.F90 | 1849 - gfsphysics/physics/machine.F | 45 - gfsphysics/physics/mersenne_twister.f | 498 - gfsphysics/physics/mfpbl.f | 392 - gfsphysics/physics/mfpblt.f | 440 - gfsphysics/physics/mfpbltq.f | 440 - gfsphysics/physics/mfscu.f | 545 - gfsphysics/physics/mfscuq.f | 539 - gfsphysics/physics/micro_mg2_0.F90 | 3391 -- gfsphysics/physics/micro_mg3_0.F90 | 4507 --- gfsphysics/physics/micro_mg_utils.F90 | 2730 -- gfsphysics/physics/module_bfmicrophysics.f | 3199 -- gfsphysics/physics/module_mp_radar.F90 | 614 - gfsphysics/physics/module_mp_thompson_gfs.F90 | 4170 -- gfsphysics/physics/module_mp_wsm6_fv3.F90 | 2632 -- gfsphysics/physics/module_nst_model.f90 | 924 - gfsphysics/physics/module_nst_parameters.f90 | 143 - gfsphysics/physics/module_nst_water_prop.f90 | 700 - .../physics/module_sf_noahmp_glacier.f90 | 2988 -- gfsphysics/physics/module_sf_noahmplsm.f90 | 8200 ---- gfsphysics/physics/module_wrf_utl.f90 | 50 - gfsphysics/physics/moninedmf.f | 1306 - gfsphysics/physics/moninedmf_hafs.f | 1571 - gfsphysics/physics/moninp.f | 547 - gfsphysics/physics/moninp1.f | 556 - gfsphysics/physics/moninq.f | 942 - gfsphysics/physics/moninq1.f | 940 - gfsphysics/physics/moninshoc.f | 557 - gfsphysics/physics/moninshoc.f_1Km | 492 - gfsphysics/physics/mstadb.f | 80 - gfsphysics/physics/mstadbtn.f | 91 - gfsphysics/physics/mstadbtn2.f | 91 - gfsphysics/physics/mstcnv.f | 316 - gfsphysics/physics/namelist_soilveg.f | 49 - gfsphysics/physics/num_parthds.F | 23 - gfsphysics/physics/ozinterp.f90 | 193 - gfsphysics/physics/ozne_def.f | 14 - gfsphysics/physics/ozphys.f | 159 - gfsphysics/physics/ozphys_2015.f | 108 - gfsphysics/physics/physcons.F90 | 193 - gfsphysics/physics/physparam.f | 307 - gfsphysics/physics/precpd.f | 719 - gfsphysics/physics/precpd_shoc.f | 438 - gfsphysics/physics/precpdp.f | 570 - gfsphysics/physics/progt2.f | 246 - gfsphysics/physics/progtm_module.f | 93 - gfsphysics/physics/rad_initialize.f | 217 - gfsphysics/physics/radiation_aerosols.f | 4528 --- gfsphysics/physics/radiation_astronomy.f | 1011 - gfsphysics/physics/radiation_clouds.f | 3408 -- gfsphysics/physics/radiation_gases.f | 1169 - gfsphysics/physics/radiation_surface.f | 839 - gfsphysics/physics/radlw_datatb.f | 32462 ---------------- gfsphysics/physics/radlw_main.f | 6755 ---- gfsphysics/physics/radlw_param.f | 162 - gfsphysics/physics/radsw_datatb.f | 22641 ----------- gfsphysics/physics/radsw_main.f | 5492 --- gfsphysics/physics/radsw_param.f | 202 - gfsphysics/physics/rascnvv2.f | 4620 --- gfsphysics/physics/rayleigh_damp.f | 90 - gfsphysics/physics/rayleigh_damp_mesopause.f | 105 - gfsphysics/physics/samfaerosols.f | 802 - gfsphysics/physics/samfdeepcnv.f | 2865 -- gfsphysics/physics/samfshalcnv.f | 1809 - gfsphysics/physics/sascnv.f | 1811 - gfsphysics/physics/sascnvn.f | 2081 - gfsphysics/physics/satmedmfvdif.f | 1419 - gfsphysics/physics/satmedmfvdifq.f | 1391 - gfsphysics/physics/set_soilveg.f | 409 - gfsphysics/physics/sfc_cice.f | 143 - gfsphysics/physics/sfc_diag.f | 66 - gfsphysics/physics/sfc_diff.f | 678 - gfsphysics/physics/sfc_drv.f | 604 - gfsphysics/physics/sfc_noahmp_drv.f | 1138 - gfsphysics/physics/sfc_nst.f | 593 - gfsphysics/physics/sfc_ocean.f | 134 - gfsphysics/physics/sfc_sice.f | 648 - gfsphysics/physics/sfcsub.F | 8700 ----- gfsphysics/physics/sflx.f | 5571 --- gfsphysics/physics/shalcnv.f | 1281 - gfsphysics/physics/shalcv.f | 205 - gfsphysics/physics/shalcv_1lyr.f | 188 - gfsphysics/physics/shalcv_fixdp.f | 194 - gfsphysics/physics/shalcv_opr.f | 164 - gfsphysics/physics/surface_perturbation.F90 | 419 - gfsphysics/physics/tracer_const_h.f | 62 - gfsphysics/physics/tridi2t3.f | 41 - gfsphysics/physics/ugwp_driver_v0.f | 2088 - gfsphysics/physics/wam_f107_kp_mod.f90 | 75 - gfsphysics/physics/wv_saturation.F | 1574 - io/CMakeLists.txt | 13 +- io/FV3GFS_io.F90 | 735 +- io/makefile | 101 - ipd/CMakeLists.txt | 33 - ipd/IPD_driver.F90 | 121 - ipd/IPD_typedefs.F90 | 165 - ipd/makefile | 58 - makefile | 165 - mkDepends.pl | 357 - stochastic_physics/CMakeLists.txt | 6 +- stochastic_physics/makefile | 54 - 195 files changed, 2259 insertions(+), 234540 deletions(-) delete mode 100755 ccpp/build_ccpp.sh rename {gfsphysics/CCPP_layer => ccpp/data}/CCPP_data.F90 (100%) rename {gfsphysics/CCPP_layer => ccpp/data}/CCPP_data.meta (93%) rename {gfsphysics/CCPP_layer => ccpp/data}/CCPP_typedefs.F90 (100%) rename {gfsphysics/CCPP_layer => ccpp/data}/CCPP_typedefs.meta (99%) create mode 100644 ccpp/data/CMakeLists.txt rename {gfsphysics/GFS_layer => ccpp/data}/GFS_typedefs.F90 (94%) rename {gfsphysics/GFS_layer => ccpp/data}/GFS_typedefs.meta (96%) rename {gfsphysics/GFS_layer => ccpp/driver}/GFS_diagnostics.F90 (97%) create mode 100644 ccpp/driver/GFS_init.F90 rename {gfsphysics/GFS_layer => ccpp/driver}/GFS_restart.F90 (98%) delete mode 100644 ccpp/driver/makefile delete mode 100755 ccpp/set_compilers.sh rename ccpp/suites/{suite_FV3_GFS_v16beta.xml => suite_FV3_GFS_v16.xml} (98%) rename ccpp/suites/{suite_FV3_GFS_v16beta_RRTMGP.xml => suite_FV3_GFS_v16_RRTMGP.xml} (97%) rename ccpp/suites/{suite_FV3_GFS_v16beta_coupled.xml => suite_FV3_GFS_v16_coupled.xml} (98%) rename ccpp/suites/{suite_FV3_GFS_v16beta_flake.xml => suite_FV3_GFS_v16_flake.xml} (98%) rename ccpp/suites/{suite_FV3_GFS_v16beta_no_nsst.xml => suite_FV3_GFS_v16_no_nsst.xml} (98%) create mode 100644 ccpp/suites/suite_FV3_GFS_v16_thompson.xml create mode 100644 ccpp/suites/suite_FV3_GFS_v16b_ugwpv1.xml create mode 100644 ccpp/suites/suite_FV3_GSD_v0_RRTMGP.xml delete mode 100644 conf/make.rules delete mode 100644 cpl/makefile delete mode 100644 gfsphysics/GFS_layer/GFS_abstraction_layer.F90 delete mode 100644 gfsphysics/GFS_layer/GFS_driver.F90 delete mode 100644 gfsphysics/GFS_layer/GFS_physics_driver.F90 delete mode 100644 gfsphysics/GFS_layer/GFS_radiation_driver.F90 delete mode 100644 gfsphysics/makefile delete mode 100644 gfsphysics/physics/GFDL_parse_tracers.F90 delete mode 100644 gfsphysics/physics/GFS_debug.F90 delete mode 100644 gfsphysics/physics/aer_cloud.F delete mode 100644 gfsphysics/physics/aerclm_def.f delete mode 100644 gfsphysics/physics/aerinterp.f90 delete mode 100644 gfsphysics/physics/calpreciptype.f90 delete mode 100644 gfsphysics/physics/cires_orowam2017.f delete mode 100644 gfsphysics/physics/cires_ugwp_initialize.F90 delete mode 100644 gfsphysics/physics/cires_ugwp_module.F90 delete mode 100644 gfsphysics/physics/cires_ugwp_solvers.F90 delete mode 100644 gfsphysics/physics/cires_ugwp_triggers.F90 delete mode 100644 gfsphysics/physics/cires_ugwp_utils.F90 delete mode 100644 gfsphysics/physics/cires_vert_lsatdis.F90 delete mode 100644 gfsphysics/physics/cires_vert_orodis.F90 delete mode 100644 gfsphysics/physics/cires_vert_wmsdis.F90 delete mode 100644 gfsphysics/physics/cldmacro.F delete mode 100644 gfsphysics/physics/cldwat2m_micro.F delete mode 100644 gfsphysics/physics/cnvc90.f delete mode 100644 gfsphysics/physics/co2hc.f delete mode 100644 gfsphysics/physics/cs_conv.F90 delete mode 100644 gfsphysics/physics/date_def.f delete mode 100644 gfsphysics/physics/dcyc2.f delete mode 100644 gfsphysics/physics/dcyc2.pre.rad.f delete mode 100644 gfsphysics/physics/efield.f delete mode 100644 gfsphysics/physics/funcphys.f90 delete mode 100644 gfsphysics/physics/gcm_shoc.f90 delete mode 100644 gfsphysics/physics/gcycle.F90 delete mode 100644 gfsphysics/physics/get_prs.f delete mode 100644 gfsphysics/physics/get_prs_fv3.f90 delete mode 100644 gfsphysics/physics/gfdl_cloud_microphys.F90 delete mode 100644 gfsphysics/physics/gfs_phy_tracer_config.F delete mode 100644 gfsphysics/physics/gocart_tracer_config_stub.f delete mode 100644 gfsphysics/physics/gscond.f delete mode 100644 gfsphysics/physics/gscondp.f delete mode 100644 gfsphysics/physics/gwdc.f delete mode 100644 gfsphysics/physics/gwdps.f delete mode 100644 gfsphysics/physics/h2o_def.f delete mode 100644 gfsphysics/physics/h2oc.f delete mode 100644 gfsphysics/physics/h2ohdc.f delete mode 100644 gfsphysics/physics/h2ointerp.f90 delete mode 100644 gfsphysics/physics/h2ophys.f delete mode 100644 gfsphysics/physics/iccn_def.f delete mode 100644 gfsphysics/physics/iccninterp.f90 delete mode 100644 gfsphysics/physics/idea_co2.f delete mode 100644 gfsphysics/physics/idea_composition.f delete mode 100644 gfsphysics/physics/idea_dissipation.f delete mode 100644 gfsphysics/physics/idea_h2o.f delete mode 100644 gfsphysics/physics/idea_ion.f delete mode 100644 gfsphysics/physics/idea_o2_o3.f delete mode 100644 gfsphysics/physics/idea_phys.f delete mode 100644 gfsphysics/physics/idea_solar_heating.f delete mode 100644 gfsphysics/physics/idea_tracer.f delete mode 100644 gfsphysics/physics/ideaca.f delete mode 100644 gfsphysics/physics/iounitdef.f delete mode 100644 gfsphysics/physics/lrgsclr.f delete mode 100644 gfsphysics/physics/m_micro_driver.F90 delete mode 100644 gfsphysics/physics/machine.F delete mode 100644 gfsphysics/physics/mersenne_twister.f delete mode 100644 gfsphysics/physics/mfpbl.f delete mode 100644 gfsphysics/physics/mfpblt.f delete mode 100644 gfsphysics/physics/mfpbltq.f delete mode 100644 gfsphysics/physics/mfscu.f delete mode 100644 gfsphysics/physics/mfscuq.f delete mode 100644 gfsphysics/physics/micro_mg2_0.F90 delete mode 100644 gfsphysics/physics/micro_mg3_0.F90 delete mode 100644 gfsphysics/physics/micro_mg_utils.F90 delete mode 100644 gfsphysics/physics/module_bfmicrophysics.f delete mode 100644 gfsphysics/physics/module_mp_radar.F90 delete mode 100644 gfsphysics/physics/module_mp_thompson_gfs.F90 delete mode 100644 gfsphysics/physics/module_mp_wsm6_fv3.F90 delete mode 100644 gfsphysics/physics/module_nst_model.f90 delete mode 100644 gfsphysics/physics/module_nst_parameters.f90 delete mode 100644 gfsphysics/physics/module_nst_water_prop.f90 delete mode 100644 gfsphysics/physics/module_sf_noahmp_glacier.f90 delete mode 100644 gfsphysics/physics/module_sf_noahmplsm.f90 delete mode 100644 gfsphysics/physics/module_wrf_utl.f90 delete mode 100644 gfsphysics/physics/moninedmf.f delete mode 100644 gfsphysics/physics/moninedmf_hafs.f delete mode 100644 gfsphysics/physics/moninp.f delete mode 100644 gfsphysics/physics/moninp1.f delete mode 100644 gfsphysics/physics/moninq.f delete mode 100644 gfsphysics/physics/moninq1.f delete mode 100644 gfsphysics/physics/moninshoc.f delete mode 100644 gfsphysics/physics/moninshoc.f_1Km delete mode 100644 gfsphysics/physics/mstadb.f delete mode 100644 gfsphysics/physics/mstadbtn.f delete mode 100644 gfsphysics/physics/mstadbtn2.f delete mode 100644 gfsphysics/physics/mstcnv.f delete mode 100644 gfsphysics/physics/namelist_soilveg.f delete mode 100644 gfsphysics/physics/num_parthds.F delete mode 100644 gfsphysics/physics/ozinterp.f90 delete mode 100644 gfsphysics/physics/ozne_def.f delete mode 100644 gfsphysics/physics/ozphys.f delete mode 100644 gfsphysics/physics/ozphys_2015.f delete mode 100644 gfsphysics/physics/physcons.F90 delete mode 100644 gfsphysics/physics/physparam.f delete mode 100644 gfsphysics/physics/precpd.f delete mode 100644 gfsphysics/physics/precpd_shoc.f delete mode 100644 gfsphysics/physics/precpdp.f delete mode 100644 gfsphysics/physics/progt2.f delete mode 100644 gfsphysics/physics/progtm_module.f delete mode 100644 gfsphysics/physics/rad_initialize.f delete mode 100644 gfsphysics/physics/radiation_aerosols.f delete mode 100644 gfsphysics/physics/radiation_astronomy.f delete mode 100644 gfsphysics/physics/radiation_clouds.f delete mode 100644 gfsphysics/physics/radiation_gases.f delete mode 100644 gfsphysics/physics/radiation_surface.f delete mode 100644 gfsphysics/physics/radlw_datatb.f delete mode 100644 gfsphysics/physics/radlw_main.f delete mode 100644 gfsphysics/physics/radlw_param.f delete mode 100644 gfsphysics/physics/radsw_datatb.f delete mode 100644 gfsphysics/physics/radsw_main.f delete mode 100644 gfsphysics/physics/radsw_param.f delete mode 100644 gfsphysics/physics/rascnvv2.f delete mode 100644 gfsphysics/physics/rayleigh_damp.f delete mode 100644 gfsphysics/physics/rayleigh_damp_mesopause.f delete mode 100644 gfsphysics/physics/samfaerosols.f delete mode 100644 gfsphysics/physics/samfdeepcnv.f delete mode 100644 gfsphysics/physics/samfshalcnv.f delete mode 100644 gfsphysics/physics/sascnv.f delete mode 100644 gfsphysics/physics/sascnvn.f delete mode 100644 gfsphysics/physics/satmedmfvdif.f delete mode 100644 gfsphysics/physics/satmedmfvdifq.f delete mode 100644 gfsphysics/physics/set_soilveg.f delete mode 100644 gfsphysics/physics/sfc_cice.f delete mode 100644 gfsphysics/physics/sfc_diag.f delete mode 100644 gfsphysics/physics/sfc_diff.f delete mode 100644 gfsphysics/physics/sfc_drv.f delete mode 100644 gfsphysics/physics/sfc_noahmp_drv.f delete mode 100644 gfsphysics/physics/sfc_nst.f delete mode 100644 gfsphysics/physics/sfc_ocean.f delete mode 100644 gfsphysics/physics/sfc_sice.f delete mode 100644 gfsphysics/physics/sfcsub.F delete mode 100644 gfsphysics/physics/sflx.f delete mode 100644 gfsphysics/physics/shalcnv.f delete mode 100644 gfsphysics/physics/shalcv.f delete mode 100644 gfsphysics/physics/shalcv_1lyr.f delete mode 100644 gfsphysics/physics/shalcv_fixdp.f delete mode 100644 gfsphysics/physics/shalcv_opr.f delete mode 100644 gfsphysics/physics/surface_perturbation.F90 delete mode 100644 gfsphysics/physics/tracer_const_h.f delete mode 100644 gfsphysics/physics/tridi2t3.f delete mode 100644 gfsphysics/physics/ugwp_driver_v0.f delete mode 100644 gfsphysics/physics/wam_f107_kp_mod.f90 delete mode 100644 gfsphysics/physics/wv_saturation.F delete mode 100644 io/makefile delete mode 100644 ipd/CMakeLists.txt delete mode 100644 ipd/IPD_driver.F90 delete mode 100644 ipd/IPD_typedefs.F90 delete mode 100644 ipd/makefile delete mode 100644 makefile delete mode 100755 mkDepends.pl delete mode 100644 stochastic_physics/makefile diff --git a/CMakeLists.txt b/CMakeLists.txt index d5013e53e..6022f41f0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,41 +1,28 @@ -if(CCPP) - - if(DEBUG) - set(_ccpp_debug_arg "--debug") - endif() - if(DEFINED CCPP_SUITES) - set(_ccpp_suites_arg "--suites=${CCPP_SUITES}") - message("Calling CCPP code generator (ccpp_prebuild.py) for suites ${_ccpp_suites_arg} ...") - else() - message("Calling CCPP code generator (ccpp_prebuild.py) for all available suites ...") - endif() - execute_process(COMMAND ${Python_EXECUTABLE} - "ccpp/framework/scripts/ccpp_prebuild.py" - "--config=ccpp/config/ccpp_prebuild_config.py" - "--builddir=${CMAKE_CURRENT_BINARY_DIR}" ${_ccpp_suites_arg} ${_ccpp_debug_arg} - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} - OUTPUT_FILE ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.out - ERROR_FILE ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.err - RESULT_VARIABLE RC) - # Check return code from ccpp_prebuild.py - if(NOT RC EQUAL 0) - message(FATAL_ERROR "An error occured while running ccpp_prebuild.py, check ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.{out,err}") - endif() - # this should not be necessary; including CCPP_*.cmake here and passing - # SCHEMES, CAPS and TYPEDEFS via environment variables to CCPP build. - # CCPP should be able to directly include those three .cmake files. - include(${CMAKE_CURRENT_BINARY_DIR}/ccpp/physics/CCPP_SCHEMES.cmake) - include(${CMAKE_CURRENT_BINARY_DIR}/ccpp/physics/CCPP_CAPS.cmake) - include(${CMAKE_CURRENT_BINARY_DIR}/ccpp/physics/CCPP_TYPEDEFS.cmake) - set(ENV{CCPP_SCHEMES} "${SCHEMES}") - set(ENV{CCPP_CAPS} "${CAPS}") - set(ENV{CCPP_TYPEDEFS} "${TYPEDEFS}") - +# Call to CCPP code generator +if(DEBUG) + set(_ccpp_debug_arg "--debug") +endif() +if(DEFINED CCPP_SUITES) + set(_ccpp_suites_arg "--suites=${CCPP_SUITES}") + message("Calling CCPP code generator (ccpp_prebuild.py) for suites ${_ccpp_suites_arg} ...") +else() + message("Calling CCPP code generator (ccpp_prebuild.py) for all available suites ...") +endif() +execute_process(COMMAND ${Python_EXECUTABLE} + "ccpp/framework/scripts/ccpp_prebuild.py" + "--config=ccpp/config/ccpp_prebuild_config.py" + "--builddir=${CMAKE_CURRENT_BINARY_DIR}" ${_ccpp_suites_arg} ${_ccpp_debug_arg} + WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + OUTPUT_FILE ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.out + ERROR_FILE ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.err + RESULT_VARIABLE RC) +# Check return code from ccpp_prebuild.py +if(NOT RC EQUAL 0) + message(FATAL_ERROR "An error occured while running ccpp_prebuild.py, check ${CMAKE_CURRENT_BINARY_DIR}/ccpp_prebuild.{out,err}") endif() add_subdirectory(cpl) add_subdirectory(gfsphysics) -add_subdirectory(ipd) add_subdirectory(io) ############################################################################### @@ -82,15 +69,12 @@ list(APPEND _fv3dycore_srcs atmos_cubed_sphere/driver/fvGFS/fv_nggps_diag.F90 atmos_cubed_sphere/driver/fvGFS/atmosphere.F90) -if(NOT CCPP) - list(APPEND _fv3dycore_srcs atmos_cubed_sphere/model/fv_cmp.F90) -endif() - add_library(fv3dycore ${_fv3dycore_srcs}) list(APPEND _fv3dycore_defs_private SPMD use_WRTCOMP GFS_PHYS + GFS_TYPES USE_GFSL63 MOIST_CAPPA USE_COND) @@ -100,13 +84,14 @@ if(MULTI_GASES) endif() if(32BIT) + set(DYN32 ON CACHE BOOL "Enable support for 32bit fast physics in CCPP") list(APPEND _fv3dycore_defs_private OVERLOAD_R4 OVERLOAD_R8) +else() + set(DYN32 OFF CACHE BOOL "Disable support for 32bit fast physics in CCPP") endif() -if(CCPP) - list(APPEND _fv3dycore_defs_private CCPP) -endif() +list(APPEND _fv3dycore_defs_private CCPP) if(OpenMP_Fortran_FOUND) list(APPEND _fv3dycore_defs_private OPENMP) @@ -118,32 +103,35 @@ set_property(SOURCE atmos_cubed_sphere/model/fv_mapz.F90 APPEND_STRING PROPERTY set_target_properties(fv3dycore PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod) target_compile_definitions(fv3dycore PRIVATE "${_fv3dycore_defs_private}") -target_include_directories(fv3dycore PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/atmos_cubed_sphere) +target_include_directories(fv3dycore PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/atmos_cubed_sphere + ${CMAKE_CURRENT_BINARY_DIR}/ccpp/driver/mod) target_include_directories(fv3dycore INTERFACE $ $) target_link_libraries(fv3dycore PUBLIC fms gfsphysics - ipd esmf) if(OpenMP_Fortran_FOUND) target_link_libraries(fv3dycore PUBLIC OpenMP::OpenMP_Fortran) endif() ############################################################################### -### ccpp +### CCPP ############################################################################### -if(CCPP) - add_subdirectory(ccpp) - add_subdirectory(ccpp/driver) - add_dependencies(gfsphysics ccpp ccppphys) - add_dependencies(ccppdriver ccpp ccppphys) - add_dependencies(ccppphys ccpp) - target_include_directories(fv3dycore PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/ccpp/framework/src - ${CMAKE_CURRENT_BINARY_DIR}/ccpp/driver) - target_link_libraries(ccppphys PRIVATE sp::sp_d - w3nco::w3nco_d) -endif() + +add_subdirectory(ccpp) +add_subdirectory(ccpp/data) +add_subdirectory(ccpp/driver) +add_dependencies(ccppphys ccpp) +add_dependencies(gfsphysics ccpp ccppphys) +add_dependencies(ccppdata ccpp ccppphys gfsphysics) +add_dependencies(ccppdriver ccpp ccppphys ccppdata gfsphysics) +add_dependencies(fv3dycore ccppdriver ccpp ccppphys ccppdata gfsphysics) +target_include_directories(fv3dycore PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/ccpp/framework/src + ${CMAKE_CURRENT_BINARY_DIR}/ccpp/physics + ${CMAKE_CURRENT_BINARY_DIR}/ccpp/driver) +target_link_libraries(ccppphys PUBLIC sp::sp_d + w3nco::w3nco_d) ############################################################################### ### stochastic_physics @@ -170,13 +158,13 @@ set_target_properties(fv3atm PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT target_include_directories(fv3atm INTERFACE $ $) -if(CCPP) - list(APPEND _fv3atm_defs_private CCPP) - target_include_directories(fv3atm PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/ccpp/driver/mod) - set(CCPP_LIBRARIES ccppdriver ccppphys ccpp) - add_dependencies(fv3atm ccppdriver ccppphys ccpp) - target_link_libraries(fv3atm PUBLIC ccppdriver ccppphys ccpp) -endif() +list(APPEND _fv3atm_defs_private CCPP) +target_include_directories(fv3atm PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/ccpp/physics + ${CMAKE_CURRENT_BINARY_DIR}/ccpp/driver/mod) +set(CCPP_LIBRARIES ccppdriver ccppdata ccppphys ccpp) +add_dependencies(fv3atm ccppdriver ccppdata ccppphys ccpp) +target_link_libraries(fv3atm PUBLIC ccppdriver ccppdata ccppphys ccpp) + target_include_directories(fv3atm PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/stochastic_physics) target_compile_definitions(fv3atm PRIVATE "${_fv3atm_defs_private}") @@ -205,7 +193,7 @@ endif() ### Install ############################################################################### install( - TARGETS fv3atm fv3dycore io ipd gfsphysics ${CCPP_LIBRARIES} cpl stochastic_physics stochastic_physics_wrapper + TARGETS fv3atm fv3dycore io gfsphysics ${CCPP_LIBRARIES} cpl stochastic_physics stochastic_physics_wrapper EXPORT fv3atm-config LIBRARY DESTINATION lib ARCHIVE DESTINATION lib) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 61875852b..306ff3137 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 61875852b52951f6c6215603a19c826b952fc534 +Subproject commit 306ff31371e74694e5d9f4a57584295c7122b9ac diff --git a/atmos_model.F90 b/atmos_model.F90 index c010789cd..3730da692 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -81,33 +81,20 @@ module atmos_model_mod use atmosphere_mod, only: Atm, mygrid use block_control_mod, only: block_control_type, define_blocks_packed use DYCORE_typedefs, only: DYCORE_data_type, DYCORE_diag_type -#ifdef CCPP -use IPD_typedefs, only: IPD_init_type, IPD_diag_type, & - IPD_restart_type, IPD_kind_phys, & - IPD_func0d_proc, IPD_func1d_proc -#else -use IPD_typedefs, only: IPD_init_type, IPD_control_type, & - IPD_data_type, IPD_diag_type, & - IPD_restart_type, IPD_kind_phys, & - IPD_func0d_proc, IPD_func1d_proc -#endif -#ifdef CCPP -use CCPP_data, only: ccpp_suite, & - IPD_control => GFS_control, & - IPD_data => GFS_data, & - IPD_interstitial => GFS_interstitial -use IPD_driver, only: IPD_initialize, IPD_initialize_rst +use GFS_typedefs, only: GFS_init_type, GFS_kind_phys => kind_phys +use GFS_restart, only: GFS_restart_type, GFS_restart_populate +use GFS_diagnostics, only: GFS_externaldiag_type, & + GFS_externaldiag_populate +use CCPP_data, only: ccpp_suite, GFS_control, & + GFS_data, GFS_interstitial +use GFS_init, only: GFS_initialize use CCPP_driver, only: CCPP_step, non_uniform_blocks use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper,stochastic_physics_wrapper_end -#else -use IPD_driver, only: IPD_initialize, IPD_initialize_rst, IPD_step -use physics_abstraction_layer, only: time_vary_step, radiation_step1, physics_step1, physics_step2 -#endif use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, & - FV3GFS_IPD_checksum, & + FV3GFS_GFS_checksum, & FV3GFS_diag_register, FV3GFS_diag_output, & DIAG_SIZE use fv_iau_mod, only: iau_external_data_type,getiauforcing,iau_initialize @@ -143,9 +130,9 @@ module atmos_model_mod real(kind=8), pointer, dimension(:) :: ak, bk 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=IPD_kind_phys), pointer, dimension(:,:) :: lon => null() ! local longitude axis grid box centers in radians. - real(kind=IPD_kind_phys), pointer, dimension(:,:) :: lat => null() ! local latitude axis grid box centers in radians. - real(kind=IPD_kind_phys), pointer, dimension(:,:) :: dx, dy + real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lon => null() ! local longitude axis grid box centers in radians. + real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lat => null() ! local latitude axis grid box centers in radians. + real(kind=GFS_kind_phys), pointer, dimension(:,:) :: dx, dy real(kind=8), pointer, dimension(:,:) :: area real(kind=8), pointer, dimension(:,:,:) :: layer_hgt, level_hgt type(domain2d) :: domain ! domain decomposition @@ -153,7 +140,7 @@ module atmos_model_mod type(time_type) :: Time_step ! atmospheric time step. type(time_type) :: Time_init ! reference time. type(grid_box_type) :: grid ! hold grid information needed for 2nd order conservative flux exchange - type(IPD_diag_type), pointer, dimension(:) :: Diag + type(GFS_externaldiag_type), pointer, dimension(:) :: Diag end type atmos_data_type ! to calculate gradient on cubic sphere grid. ! @@ -170,11 +157,7 @@ module atmos_model_mod integer, parameter :: maxhr = 4096 real, dimension(maxhr) :: fdiag = 0. real :: fhmax=384.0, fhmaxhf=120.0, fhout=3.0, fhouthf=1.0,avg_max_length=3600. -#ifdef CCPP namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, fdiag, fhmax, fhmaxhf, fhout, fhouthf, ccpp_suite, avg_max_length -#else -namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, fdiag, fhmax, fhmaxhf, fhout, fhouthf, avg_max_length -#endif type (time_type) :: diag_time, diag_time_fhzero @@ -186,18 +169,10 @@ module atmos_model_mod type(DYCORE_diag_type) :: DYCORE_Diag(25) !---------------- -! IPD containers +! GFS containers !---------------- -#ifndef CCPP -type(IPD_control_type) :: IPD_Control -type(IPD_data_type), allocatable :: IPD_Data(:) ! number of blocks -type(IPD_diag_type), target :: IPD_Diag(DIAG_SIZE) -type(IPD_restart_type) :: IPD_Restart -#else -! IPD_Control and IPD_Data are coming from CCPP_data -type(IPD_diag_type), target :: IPD_Diag(DIAG_SIZE) -type(IPD_restart_type) :: IPD_Restart -#endif +type(GFS_externaldiag_type), target :: GFS_Diag(DIAG_SIZE) +type(GFS_restart_type) :: GFS_restart_var !-------------- ! IAU container @@ -220,10 +195,10 @@ module atmos_model_mod logical,parameter :: flip_vc = .true. #endif - real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & - one = 1.0_IPD_kind_phys, & - epsln = 1.0e-10_IPD_kind_phys, & - zorlmin = 1.0e-7_IPD_kind_phys + real(kind=GFS_kind_phys), parameter :: zero = 0.0_GFS_kind_phys, & + one = 1.0_GFS_kind_phys, & + epsln = 1.0e-10_GFS_kind_phys, & + zorlmin = 1.0e-7_GFS_kind_phys contains @@ -253,63 +228,51 @@ subroutine update_atmos_radiation_physics (Atmos) !----------------------------------------------------------------------- type (atmos_data_type), intent(in) :: Atmos !--- local variables--- - integer :: nb, jdat(8), rc - procedure(IPD_func0d_proc), pointer :: Func0d => NULL() - procedure(IPD_func1d_proc), pointer :: Func1d => NULL() - ! -#ifdef CCPP - integer :: ierr -#endif + integer :: nb, jdat(8), rc, ierr 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, flip_vc) + if (GFS_control%do_skeb) call atmosphere_diss_est (GFS_control%skeb_npass) ! do smoothing for SKEB + call atmos_phys_driver_statein (GFS_data, Atm_block, flip_vc) call mpp_clock_end(getClock) !--- 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 + GFS_data(nb)%Stateout%gu0 = GFS_data(nb)%Statein%ugrs + GFS_data(nb)%Stateout%gv0 = GFS_data(nb)%Statein%vgrs + GFS_data(nb)%Stateout%gt0 = GFS_data(nb)%Statein%tgrs + GFS_data(nb)%Stateout%gq0 = GFS_data(nb)%Statein%qgrs enddo else if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "setup step" -!--- update IPD_Control%jdat(8) +!--- update GFS_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(:) + GFS_control%jdat(:) = jdat(:) !--- execute the IPD atmospheric setup step call mpp_clock_begin(setupClock) -#ifdef CCPP - call CCPP_step (step="time_vary", nblks=Atm_block%nblks, ierr=ierr) - if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP time_vary step failed') + call CCPP_step (step="timestep_init", nblks=Atm_block%nblks, ierr=ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_init step failed') !--- call stochastic physics pattern generation / cellular automata - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + call stochastic_physics_wrapper(GFS_control, GFS_data, Atm_block, ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') -#else - Func1d => time_vary_step - call IPD_step (IPD_Control, IPD_Data(:), IPD_Diag, IPD_Restart, IPD_func1d=Func1d) -#endif - !--- if coupled, assign coupled fields - if( IPD_Control%cplflx .or. IPD_Control%cplwav ) then + if( GFS_control%cplflx .or. GFS_control%cplwav ) then ! if (mpp_pe() == mpp_root_pe() .and. debug) then ! print *,'in atmos_model,nblks=',Atm_block%nblks -! print *,'in atmos_model,IPD_Data size=',size(IPD_Data) -! print *,'in atmos_model,tsfc(1)=',IPD_Data(1)%sfcprop%tsfc(1) -! print *,'in atmos_model, tsfc size=',size(IPD_Data(1)%sfcprop%tsfc) +! print *,'in atmos_model,GFS_data size=',size(GFS_data) +! print *,'in atmos_model,tsfc(1)=',GFS_data(1)%sfcprop%tsfc(1) +! print *,'in atmos_model, tsfc size=',size(GFS_data(1)%sfcprop%tsfc) ! endif call assign_importdata(rc) @@ -319,21 +282,21 @@ subroutine update_atmos_radiation_physics (Atmos) ! Calculate total non-physics tendencies by substracting old IPD Stateout ! variables from new/updated IPD Statein variables (gives the tendencies ! due to anything else than physics) - if (IPD_Control%ldiag3d) then + if (GFS_control%ldiag3d) then do nb = 1,Atm_block%nblks - IPD_Data(nb)%Intdiag%du3dt(:,:,8) = IPD_Data(nb)%Intdiag%du3dt(:,:,8) & - + (IPD_Data(nb)%Statein%ugrs - IPD_Data(nb)%Stateout%gu0) - IPD_Data(nb)%Intdiag%dv3dt(:,:,8) = IPD_Data(nb)%Intdiag%dv3dt(:,:,8) & - + (IPD_Data(nb)%Statein%vgrs - IPD_Data(nb)%Stateout%gv0) - IPD_Data(nb)%Intdiag%dt3dt(:,:,11) = IPD_Data(nb)%Intdiag%dt3dt(:,:,11) & - + (IPD_Data(nb)%Statein%tgrs - IPD_Data(nb)%Stateout%gt0) + GFS_data(nb)%Intdiag%du3dt(:,:,8) = GFS_data(nb)%Intdiag%du3dt(:,:,8) & + + (GFS_data(nb)%Statein%ugrs - GFS_data(nb)%Stateout%gu0) + GFS_data(nb)%Intdiag%dv3dt(:,:,8) = GFS_data(nb)%Intdiag%dv3dt(:,:,8) & + + (GFS_data(nb)%Statein%vgrs - GFS_data(nb)%Stateout%gv0) + GFS_data(nb)%Intdiag%dt3dt(:,:,11) = GFS_data(nb)%Intdiag%dt3dt(:,:,11) & + + (GFS_data(nb)%Statein%tgrs - GFS_data(nb)%Stateout%gt0) enddo - if (IPD_Control%qdiag3d) then + if (GFS_control%qdiag3d) then do nb = 1,Atm_block%nblks - IPD_Data(nb)%Intdiag%dq3dt(:,:,12) = IPD_Data(nb)%Intdiag%dq3dt(:,:,12) & - + (IPD_Data(nb)%Statein%qgrs(:,:,IPD_Control%ntqv) - IPD_Data(nb)%Stateout%gq0(:,:,IPD_Control%ntqv)) - IPD_Data(nb)%Intdiag%dq3dt(:,:,13) = IPD_Data(nb)%Intdiag%dq3dt(:,:,13) & - + (IPD_Data(nb)%Statein%qgrs(:,:,IPD_Control%ntoz) - IPD_Data(nb)%Stateout%gq0(:,:,IPD_Control%ntoz)) + GFS_data(nb)%Intdiag%dq3dt(:,:,12) = GFS_data(nb)%Intdiag%dq3dt(:,:,12) & + + (GFS_data(nb)%Statein%qgrs(:,:,GFS_control%ntqv) - GFS_data(nb)%Stateout%gq0(:,:,GFS_control%ntqv)) + GFS_data(nb)%Intdiag%dq3dt(:,:,13) = GFS_data(nb)%Intdiag%dq3dt(:,:,13) & + + (GFS_data(nb)%Statein%qgrs(:,:,GFS_control%ntoz) - GFS_data(nb)%Stateout%gq0(:,:,GFS_control%ntoz)) enddo endif endif @@ -345,27 +308,16 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the IPD atmospheric radiation subcomponent (RRTM) call mpp_clock_begin(radClock) -#ifdef CCPP ! Performance improvement. Only enter if it is time to call the radiation physics. - if (IPD_Control%lsswr .or. IPD_Control%lslwr) then + if (GFS_control%lsswr .or. GFS_control%lslwr) then call CCPP_step (step="radiation", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP radiation step failed') endif -#else - Func0d => radiation_step1 -!$OMP parallel do default (none) & -!$OMP schedule (dynamic,1), & -!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Func0d) & -!$OMP private (nb) - do nb = 1,Atm_block%nblks - call IPD_step (IPD_Control, IPD_Data(nb:nb), IPD_Diag, IPD_Restart, IPD_func0d=Func0d) - enddo -#endif 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) + if (mpp_pe() == mpp_root_pe()) print *,'RADIATION STEP ', GFS_control%kdt, GFS_control%fhour + call FV3GFS_GFS_checksum(GFS_control, GFS_data, Atm_block) endif if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "physics driver" @@ -373,24 +325,13 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the IPD atmospheric physics step1 subcomponent (main physics driver) call mpp_clock_begin(physClock) -#ifdef CCPP call CCPP_step (step="physics", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics step failed') -#else - Func0d => physics_step1 -!$OMP parallel do default (none) & -!$OMP schedule (dynamic,1), & -!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Func0d) & -!$OMP private (nb) - do nb = 1,Atm_block%nblks - call IPD_step (IPD_Control, IPD_Data(nb:nb), IPD_Diag, IPD_Restart, IPD_func0d=Func0d) - enddo -#endif 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) + if (mpp_pe() == mpp_root_pe()) print *,'PHYSICS STEP1 ', GFS_control%kdt, GFS_control%fhour + call FV3GFS_GFS_checksum(GFS_control, GFS_data, Atm_block) endif if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "stochastic physics driver" @@ -398,33 +339,28 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the IPD atmospheric physics step2 subcomponent (stochastic physics driver) call mpp_clock_begin(physClock) -#ifdef CCPP call CCPP_step (step="stochastics", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP stochastics step failed') -#else - Func0d => physics_step2 -!$OMP parallel do default (none) & -!$OMP schedule (dynamic,1), & -!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Func0d) & -!$OMP private (nb) - do nb = 1,Atm_block%nblks - call IPD_step (IPD_Control, IPD_Data(nb:nb), IPD_Diag, IPD_Restart, IPD_func0d=Func0d) - enddo -#endif 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) + if (mpp_pe() == mpp_root_pe()) print *,'PHYSICS STEP2 ', GFS_control%kdt, GFS_control%fhour + call FV3GFS_GFS_checksum(GFS_control, GFS_data, Atm_block) endif - call getiauforcing(IPD_Control,IAU_data) + call getiauforcing(GFS_control,IAU_data) if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "end of radiation and physics step" + +!--- execute the IPD atmospheric timestep finalize step + call mpp_clock_begin(setupClock) + call CCPP_step (step="timestep_finalize", nblks=Atm_block%nblks, ierr=ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_finalize step failed') + call mpp_clock_end(setupClock) + endif -#ifdef CCPP ! Update flag for first time step of time integration - IPD_Control%first_time_step = .false. -#endif + GFS_control%first_time_step = .false. + !----------------------------------------------------------------------- end subroutine update_atmos_radiation_physics ! @@ -442,9 +378,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #ifdef _OPENMP use omp_lib #endif -#ifdef CCPP use fv_mp_mod, only: commglobal -#endif use mpp_mod, only: mpp_npes type (atmos_data_type), intent(inout) :: Atmos @@ -457,14 +391,14 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed integer :: blk, ibs, ibe, jbs, jbe - real(kind=IPD_kind_phys) :: dt_phys + real(kind=GFS_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 + type(GFS_init_type) :: Init_parm integer :: bdat(8), cdat(8) integer :: ntracers, maxhf, maxh character(len=32), allocatable, target :: tracer_names(:) @@ -485,12 +419,6 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) !----------------------------------------------------------------------- ! initialize atmospheric model ----- -#ifndef CCPP -!---------- initialize atmospheric dynamics ------- - call atmosphere_init (Atmos%Time_init, Atmos%Time, Atmos%Time_step,& - Atmos%grid, Atmos%area) -#endif - IF ( file_exist('input.nml')) THEN #ifdef INTERNAL_FILE_NML read(input_nml_file, nml=atmos_model_nml, iostat=io) @@ -506,12 +434,10 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #endif endif -#ifdef CCPP !---------- initialize atmospheric dynamics after reading the namelist ------- !---------- (need name of CCPP suite definition file from input.nml) --------- call atmosphere_init (Atmos%Time_init, Atmos%Time, Atmos%Time_step,& Atmos%grid, Atmos%area) -#endif !----------------------------------------------------------------------- call atmosphere_resolution (nlon, nlat, global=.false.) @@ -535,7 +461,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) blocksize, block_message) allocate(DYCORE_Data(Atm_block%nblks)) - allocate(IPD_Data(Atm_block%nblks)) + allocate(GFS_data(Atm_block%nblks)) #ifdef _OPENMP nthrds = omp_get_max_threads() @@ -543,7 +469,6 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) nthrds = 1 #endif -#ifdef CCPP ! This logic deals with non-uniform block sizes for CCPP. ! When non-uniform block sizes are used, it is required ! that only the last block has a different (smaller) @@ -555,18 +480,16 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) ! runs over the last, smaller block. if (minval(Atm_block%blksz)==maxval(Atm_block%blksz)) then non_uniform_blocks = .false. - allocate(IPD_Interstitial(nthrds)) + allocate(GFS_interstitial(nthrds)) else if (all(minloc(Atm_block%blksz)==(/size(Atm_block%blksz)/))) then non_uniform_blocks = .true. - allocate(IPD_Interstitial(nthrds+1)) + allocate(GFS_interstitial(nthrds+1)) else call mpp_error(FATAL, 'For non-uniform blocksizes, only the last element ' // & 'in Atm_block%blksz can be different from the others') end if -#endif - -!--- update IPD_Control%jdat(8) +!--- update GFS_control%jdat(8) bdat(:) = 0 call get_date (Time_init, bdat(1), bdat(2), bdat(3), & bdat(5), bdat(6), bdat(7)) @@ -605,10 +528,8 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) Init_parm%xlat => Atmos%lat Init_parm%area => Atmos%area Init_parm%tracer_names => tracer_names -#ifdef CCPP Init_parm%restart = Atm(mygrid)%flagstruct%warm_start Init_parm%hydrostatic = Atm(mygrid)%flagstruct%hydrostatic -#endif #ifdef INTERNAL_FILE_NML Init_parm%input_nml_file => input_nml_file @@ -622,24 +543,22 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) endif #endif -#ifdef CCPP - call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, & - IPD_Interstitial, commglobal, mpp_npes(), Init_parm) + call GFS_initialize (GFS_control, GFS_data%Statein, GFS_data%Stateout, GFS_data%Sfcprop, & + GFS_data%Coupling, GFS_data%Grid, GFS_data%Tbd, GFS_data%Cldprop, GFS_data%Radtend, & + GFS_data%Intdiag, GFS_interstitial, commglobal, mpp_npes(), Init_parm) -!--- Initialize stochastic physics pattern generation / cellular automata for first time step -! call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) -! if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') -! -#else - call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) -#endif + !--- populate/associate the Diag container elements + call GFS_externaldiag_populate (GFS_Diag, GFS_Control, GFS_Data%Statein, GFS_Data%Stateout, & + GFS_Data%Sfcprop, GFS_Data%Coupling, GFS_Data%Grid, & + GFS_Data%Tbd, GFS_Data%Cldprop, GFS_Data%Radtend, & + GFS_Data%Intdiag, Init_parm) - Atmos%Diag => IPD_Diag + Atmos%Diag => GFS_Diag - Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb + Atm(mygrid)%flagstruct%do_skeb = GFS_control%do_skeb ! initialize the IAU module - call iau_initialize (IPD_Control,IAU_data,Init_parm) + call iau_initialize (GFS_control,IAU_data,Init_parm) Init_parm%blksz => null() Init_parm%ak => null() @@ -651,43 +570,40 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) 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) +!rab call atmosphere_tracer_postinit (GFS_data, Atm_block) call atmosphere_nggps_diag (Time, init=.true.) - call FV3GFS_diag_register (IPD_Diag, Time, Atm_block, IPD_Control, Atmos%lon, Atmos%lat, Atmos%axes) - call IPD_initialize_rst (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) -#ifdef CCPP - call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain, Atm(mygrid)%flagstruct%warm_start) -#else - call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain) -#endif + call FV3GFS_diag_register (GFS_Diag, Time, Atm_block, GFS_control, Atmos%lon, Atmos%lat, Atmos%axes) + call GFS_restart_populate (GFS_restart_var, GFS_control, GFS_data%Statein, GFS_data%Stateout, GFS_data%Sfcprop, & + GFS_data%Coupling, GFS_data%Grid, GFS_data%Tbd, GFS_data%Cldprop, GFS_data%Radtend, & + GFS_data%IntDiag, Init_parm, GFS_Diag) + call FV3GFS_restart_read (GFS_data, GFS_restart_var, Atm_block, GFS_control, Atmos%domain, Atm(mygrid)%flagstruct%warm_start) - ! Populate the IPD_Data%Statein container with the prognostic state + ! Populate the GFS_data%Statein container with the prognostic state ! in Atm_block, which contains the initial conditions/restart data. - call atmos_phys_driver_statein (IPD_data, Atm_block, flip_vc) + call atmos_phys_driver_statein (GFS_data, Atm_block, flip_vc) ! When asked to calculate 3-dim. tendencies, set Stateout variables to ! Statein variables here in order to capture the first call to dycore - if (IPD_Control%ldiag3d) then + if (GFS_control%ldiag3d) 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 + GFS_data(nb)%Stateout%gu0 = GFS_data(nb)%Statein%ugrs + GFS_data(nb)%Stateout%gv0 = GFS_data(nb)%Statein%vgrs + GFS_data(nb)%Stateout%gt0 = GFS_data(nb)%Statein%tgrs + GFS_data(nb)%Stateout%gq0 = GFS_data(nb)%Statein%qgrs enddo endif -#ifdef CCPP ! Initialize the CCPP framework call CCPP_step (step="init", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP init step failed') ! Initialize the CCPP physics call CCPP_step (step="physics_init", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_init step failed') + !--- Initialize stochastic physics pattern generation / cellular automata for first time step - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + call stochastic_physics_wrapper(GFS_control, GFS_data, Atm_block, ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') -#endif !--- set the initial diagnostic timestamp diag_time = Time @@ -751,15 +667,14 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) call atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) !if in coupled mode, set up coupled fields - if (IPD_Control%cplflx .or. IPD_Control%cplwav) then + if (GFS_control%cplflx .or. GFS_control%cplwav) then if (mpp_pe() == mpp_root_pe()) print *,'COUPLING: IPD layer' call setup_exportdata(ierr) endif -#ifdef CCPP ! Set flag for first time step of time integration - IPD_Control%first_time_step = .true. -#endif + GFS_control%first_time_step = .true. + !----------------------------------------------------------------------- end subroutine atmos_model_init ! @@ -808,7 +723,7 @@ subroutine atmos_model_exchange_phase_1 (Atmos, rc) if (present(rc)) rc = ESMF_SUCCESS !--- if coupled, exchange coupled fields - if( IPD_Control%cplchm ) then + if( GFS_control%cplchm ) then ! -- export fields to chemistry call update_atmos_chemistry('export', rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return @@ -844,7 +759,7 @@ subroutine atmos_model_exchange_phase_2 (Atmos, rc) if (present(rc)) rc = ESMF_SUCCESS !--- if coupled, exchange coupled fields - if( IPD_Control%cplchm ) then + if( GFS_control%cplchm ) then ! -- import fields from chemistry call update_atmos_chemistry('import', rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return @@ -864,19 +779,19 @@ subroutine update_atmos_model_state (Atmos) !--- local variables integer :: isec, seconds, isec_fhzero integer :: rc - real(kind=IPD_kind_phys) :: time_int, time_intfull + real(kind=GFS_kind_phys) :: time_int, time_intfull ! 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, flip_vc) + call atmosphere_state_update (Atmos%Time, GFS_data, IAU_Data, Atm_block, flip_vc) 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 - if (mpp_pe() == mpp_root_pe()) print *,'in UPDATE STATE ', size(IPD_Data(1)%SfcProp%tsfc),'nblks=',Atm_block%nblks - call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + if (mpp_pe() == mpp_root_pe()) print *,'UPDATE STATE ', GFS_control%kdt, GFS_control%fhour + if (mpp_pe() == mpp_root_pe()) print *,'in UPDATE STATE ', size(GFS_data(1)%SfcProp%tsfc),'nblks=',Atm_block%nblks + call FV3GFS_GFS_checksum(GFS_control, GFS_data, Atm_block) endif !--- advance time --- @@ -885,7 +800,7 @@ subroutine update_atmos_model_state (Atmos) call get_time (Atmos%Time - diag_time, isec) call get_time (Atmos%Time - Atmos%Time_init, seconds) call atmosphere_nggps_diag(Atmos%Time,ltavg=.true.,avg_max_length=avg_max_length) - if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (IPD_Control%kdt == first_kdt) .or. nsout > 0) then + if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (GFS_control%kdt == first_kdt) .or. nsout > 0) then if (mpp_pe() == mpp_root_pe()) write(6,*) "---isec,seconds",isec,seconds time_int = real(isec) if(Atmos%iau_offset > zero) then @@ -905,13 +820,13 @@ subroutine update_atmos_model_state (Atmos) endif 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) - call FV3GFS_diag_output(Atmos%Time, IPD_DIag, Atm_block, IPD_Control%nx, IPD_Control%ny, & - IPD_Control%levs, 1, 1, 1.0_IPD_kind_phys, time_int, time_intfull, & - IPD_Control%fhswr, IPD_Control%fhlwr) - if (nint(IPD_Control%fhzero) > 0) then - if (mod(isec,3600*nint(IPD_Control%fhzero)) == 0) diag_time = Atmos%Time + call FV3GFS_diag_output(Atmos%Time, GFS_Diag, Atm_block, GFS_control%nx, GFS_control%ny, & + GFS_control%levs, 1, 1, 1.0_GFS_kind_phys, time_int, time_intfull, & + GFS_control%fhswr, GFS_control%fhlwr) + if (nint(GFS_control%fhzero) > 0) then + if (mod(isec,3600*nint(GFS_control%fhzero)) == 0) diag_time = Atmos%Time else - if (mod(isec,nint(3600*IPD_Control%fhzero)) == 0) diag_time = Atmos%Time + if (mod(isec,nint(3600*GFS_control%fhzero)) == 0) diag_time = Atmos%Time endif call diag_send_complete_instant (Atmos%Time) endif @@ -923,7 +838,7 @@ subroutine update_atmos_model_state (Atmos) call atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) !if in coupled mode, set up coupled fields - if (IPD_Control%cplflx .or. IPD_Control%cplwav) then + if (GFS_control%cplflx .or. GFS_control%cplwav) then call setup_exportdata(rc) endif @@ -956,30 +871,25 @@ end subroutine update_atmos_model_state subroutine atmos_model_end (Atmos) type (atmos_data_type), intent(inout) :: Atmos !---local variables - integer :: idx, seconds -#ifdef CCPP - integer :: ierr -#endif + integer :: idx, seconds, ierr !----------------------------------------------------------------------- !---- termination routine for atmospheric model ---- call atmosphere_end (Atmos % Time, Atmos%grid, restart_endfcst) - call stochastic_physics_wrapper_end(IPD_Control) + call stochastic_physics_wrapper_end(GFS_control) if(restart_endfcst) then - call FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, & - IPD_Control, Atmos%domain) + call FV3GFS_restart_write (GFS_data, GFS_restart_var, Atm_block, & + GFS_control, Atmos%domain) endif -#ifdef CCPP ! Fast physics (from dynamics) are finalized in atmosphere_end above; ! standard/slow physics (from IPD) are finalized in CCPP_step 'finalize'. ! The CCPP framework for all cdata structures is finalized in CCPP_step 'finalize'. call CCPP_step (step="finalize", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP finalize step failed') -#endif end subroutine atmos_model_end @@ -994,8 +904,8 @@ subroutine atmos_model_restart(Atmos, timestamp) character(len=*), intent(in) :: timestamp call atmosphere_restart(timestamp) - call FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, & - IPD_Control, Atmos%domain, timestamp) + call FV3GFS_restart_write (GFS_data, GFS_restart_var, Atm_block, & + GFS_control, Atmos%domain, timestamp) end subroutine atmos_model_restart ! @@ -1021,9 +931,9 @@ subroutine get_atmos_model_ungridded_dim(nlev, nsoillev, ntracers, & !--- number of soil levels if (present(nsoillev)) then nsoillev = 0 - if (allocated(IPD_Data)) then - if (associated(IPD_Data(1)%Sfcprop%slc)) & - nsoillev = size(IPD_Data(1)%Sfcprop%slc, dim=2) + if (allocated(GFS_data)) then + if (associated(GFS_data(1)%Sfcprop%slc)) & + nsoillev = size(GFS_data(1)%Sfcprop%slc, dim=2) end if end if @@ -1033,17 +943,17 @@ subroutine get_atmos_model_ungridded_dim(nlev, nsoillev, ntracers, & !--- number of tracers used in chemistry diagnostic output if (present(num_diag_down_flux)) then num_diag_down_flux = 0 - if (associated(IPD_Data(1)%IntDiag%sedim)) & - num_diag_down_flux = size(IPD_Data(1)%IntDiag%sedim, dim=2) + if (associated(GFS_data(1)%IntDiag%sedim)) & + num_diag_down_flux = size(GFS_data(1)%IntDiag%sedim, dim=2) if (present(num_diag_type_down_flux)) then num_diag_type_down_flux = 0 - if (associated(IPD_Data(1)%IntDiag%sedim)) & + if (associated(GFS_data(1)%IntDiag%sedim)) & num_diag_type_down_flux = num_diag_type_down_flux + 1 - if (associated(IPD_Data(1)%IntDiag%drydep)) & + if (associated(GFS_data(1)%IntDiag%drydep)) & num_diag_type_down_flux = num_diag_type_down_flux + 1 - if (associated(IPD_Data(1)%IntDiag%wetdpl)) & + if (associated(GFS_data(1)%IntDiag%wetdpl)) & num_diag_type_down_flux = num_diag_type_down_flux + 1 - if (associated(IPD_Data(1)%IntDiag%wetdpc)) & + if (associated(GFS_data(1)%IntDiag%wetdpc)) & num_diag_type_down_flux = num_diag_type_down_flux + 1 end if end if @@ -1051,25 +961,25 @@ subroutine get_atmos_model_ungridded_dim(nlev, nsoillev, ntracers, & !--- number of bins for chemistry diagnostic output if (present(num_diag_sfc_emis_flux)) then num_diag_sfc_emis_flux = 0 - if (associated(IPD_Data(1)%IntDiag%duem)) & - num_diag_sfc_emis_flux = size(IPD_Data(1)%IntDiag%duem, dim=2) - if (associated(IPD_Data(1)%IntDiag%ssem)) & + if (associated(GFS_data(1)%IntDiag%duem)) & + num_diag_sfc_emis_flux = size(GFS_data(1)%IntDiag%duem, dim=2) + if (associated(GFS_data(1)%IntDiag%ssem)) & num_diag_sfc_emis_flux = & - num_diag_sfc_emis_flux + size(IPD_Data(1)%IntDiag%ssem, dim=2) + num_diag_sfc_emis_flux + size(GFS_data(1)%IntDiag%ssem, dim=2) end if !--- number of tracers used in emission diagnostic output if (present(num_diag_burn_emis_flux)) then num_diag_burn_emis_flux = 0 - if (associated(IPD_Data(1)%IntDiag%abem)) & - num_diag_burn_emis_flux = size(IPD_Data(1)%IntDiag%abem, dim=2) + if (associated(GFS_data(1)%IntDiag%abem)) & + num_diag_burn_emis_flux = size(GFS_data(1)%IntDiag%abem, dim=2) end if !--- number of tracers used in column mass density diagnostics if (present(num_diag_cmass)) then num_diag_cmass = 0 - if (associated(IPD_Data(1)%IntDiag%aecm)) & - num_diag_cmass = size(IPD_Data(1)%IntDiag%aecm, dim=2) + if (associated(GFS_data(1)%IntDiag%aecm)) & + num_diag_cmass = size(GFS_data(1)%IntDiag%aecm, dim=2) end if end subroutine get_atmos_model_ungridded_dim @@ -1089,7 +999,7 @@ end subroutine get_atmos_model_ungridded_dim ! tracers must match their order in the chemistry component. ! ! Requires: -! IPD_Data +! GFS_data ! Atm_block ! subroutine update_atmos_chemistry(state, rc) @@ -1157,17 +1067,17 @@ subroutine update_atmos_chemistry(state, rc) nte = nt !--- if chemical tracers are present, set bounds appropriately - if (IPD_Control%ntchm > 0) then - if (IPD_Control%ntchs /= NO_TRACER) then - ntb = IPD_Control%ntchs - nte = IPD_Control%ntchm + ntb - 1 + if (GFS_control%ntchm > 0) then + if (GFS_control%ntchs /= NO_TRACER) then + ntb = GFS_control%ntchs + nte = GFS_control%ntchm + ntb - 1 end if end if !--- tracer concentrations do it = ntb, nte !$OMP parallel do default (none) & -!$OMP shared (it, nk, nj, ni, Atm_block, IPD_Data, q) & +!$OMP shared (it, nk, nj, ni, Atm_block, GFS_data, q) & !$OMP private (k, j, jb, i, ib, nb, ix) do k = 1, nk do j = 1, nj @@ -1176,7 +1086,7 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%Stateout%gq0(ix,k,it) = q(i,j,k,it) + GFS_data(nb)%Stateout%gq0(ix,k,it) = q(i,j,k,it) enddo enddo enddo @@ -1186,7 +1096,7 @@ subroutine update_atmos_chemistry(state, rc) !--- (a) column mass densities do it = 1, size(qm, dim=3) !$OMP parallel do default (none) & -!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qm) & +!$OMP shared (it, nj, ni, Atm_block, GFS_data, qm) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1194,17 +1104,17 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%aecm(ix,it) = qm(i,j,it) + GFS_data(nb)%IntDiag%aecm(ix,it) = qm(i,j,it) enddo enddo enddo !--- (b) dust and sea salt emissions - ntb = size(IPD_Data(1)%IntDiag%duem, dim=2) + ntb = size(GFS_data(1)%IntDiag%duem, dim=2) nte = size(qu, dim=3) do it = 1, min(ntb, nte) !$OMP parallel do default (none) & -!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qu) & +!$OMP shared (it, nj, ni, Atm_block, GFS_data, qu) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1212,16 +1122,16 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%duem(ix,it) = qu(i,j,it) + GFS_data(nb)%IntDiag%duem(ix,it) = qu(i,j,it) enddo enddo enddo nte = nte - ntb if (nte > 0) then - do it = 1, min(size(IPD_Data(1)%IntDiag%ssem, dim=2), nte) + do it = 1, min(size(GFS_data(1)%IntDiag%ssem, dim=2), nte) !$OMP parallel do default (none) & -!$OMP shared (it, nj, ni, ntb, Atm_block, IPD_Data, qu) & +!$OMP shared (it, nj, ni, ntb, Atm_block, GFS_data, qu) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1229,7 +1139,7 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) + GFS_data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) enddo enddo enddo @@ -1238,7 +1148,7 @@ subroutine update_atmos_chemistry(state, rc) !--- (c) sedimentation and dry/wet deposition do it = 1, size(qd, dim=3) !$OMP parallel do default (none) & -!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qd) & +!$OMP shared (it, nj, ni, Atm_block, GFS_data, qd) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1246,10 +1156,10 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%sedim (ix,it) = qd(i,j,it,1) - IPD_Data(nb)%IntDiag%drydep(ix,it) = qd(i,j,it,2) - IPD_Data(nb)%IntDiag%wetdpl(ix,it) = qd(i,j,it,3) - IPD_Data(nb)%IntDiag%wetdpc(ix,it) = qd(i,j,it,4) + GFS_data(nb)%IntDiag%sedim (ix,it) = qd(i,j,it,1) + GFS_data(nb)%IntDiag%drydep(ix,it) = qd(i,j,it,2) + GFS_data(nb)%IntDiag%wetdpl(ix,it) = qd(i,j,it,3) + GFS_data(nb)%IntDiag%wetdpc(ix,it) = qd(i,j,it,4) enddo enddo enddo @@ -1257,7 +1167,7 @@ subroutine update_atmos_chemistry(state, rc) !--- (d) anthropogenic and biomass burning emissions do it = 1, size(qb, dim=3) !$OMP parallel do default (none) & -!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qb) & +!$OMP shared (it, nj, ni, Atm_block, GFS_data, qb) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1265,12 +1175,12 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%abem(ix,it) = qb(i,j,it) + GFS_data(nb)%IntDiag%abem(ix,it) = qb(i,j,it) enddo enddo enddo - if (IPD_Control%debug) then + if (GFS_control%debug) then write(6,'("update_atmos: ",a,": qgrs - min/max/avg",3g16.6)') & trim(state), minval(q), maxval(q), sum(q)/size(q) write(6,'("update_atmos: ",a,": qup - min/max/avg",3g16.6)') & @@ -1395,7 +1305,7 @@ subroutine update_atmos_chemistry(state, rc) !--- handle all three-dimensional variables !$OMP parallel do default (none) & -!$OMP shared (nk, nj, ni, Atm_block, IPD_Data, prsi, phii, prsl, phil, temp, ua, va, vvl, dkt, dqdt) & +!$OMP shared (nk, nj, ni, Atm_block, GFS_data, prsi, phii, prsl, phil, temp, ua, va, vvl, dkt, dqdt) & !$OMP private (k, j, jb, i, ib, nb, ix) do k = 1, nk do j = 1, nj @@ -1405,17 +1315,17 @@ subroutine update_atmos_chemistry(state, rc) nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) !--- interface values - prsi(i,j,k) = IPD_Data(nb)%Statein%prsi(ix,k) - phii(i,j,k) = IPD_Data(nb)%Statein%phii(ix,k) + prsi(i,j,k) = GFS_data(nb)%Statein%prsi(ix,k) + phii(i,j,k) = GFS_data(nb)%Statein%phii(ix,k) !--- layer values - prsl(i,j,k) = IPD_Data(nb)%Statein%prsl(ix,k) - phil(i,j,k) = IPD_Data(nb)%Statein%phil(ix,k) - temp(i,j,k) = IPD_Data(nb)%Stateout%gt0(ix,k) - ua (i,j,k) = IPD_Data(nb)%Stateout%gu0(ix,k) - va (i,j,k) = IPD_Data(nb)%Stateout%gv0(ix,k) - vvl (i,j,k) = IPD_Data(nb)%Statein%vvl (ix,k) - dkt (i,j,k) = IPD_Data(nb)%Coupling%dkt(ix,k) - dqdt(i,j,k) = IPD_Data(nb)%Coupling%dqdti(ix,k) + prsl(i,j,k) = GFS_data(nb)%Statein%prsl(ix,k) + phil(i,j,k) = GFS_data(nb)%Statein%phil(ix,k) + temp(i,j,k) = GFS_data(nb)%Stateout%gt0(ix,k) + ua (i,j,k) = GFS_data(nb)%Stateout%gu0(ix,k) + va (i,j,k) = GFS_data(nb)%Stateout%gv0(ix,k) + vvl (i,j,k) = GFS_data(nb)%Statein%vvl (ix,k) + dkt (i,j,k) = GFS_data(nb)%Coupling%dkt(ix,k) + dqdt(i,j,k) = GFS_data(nb)%Coupling%dqdti(ix,k) enddo enddo enddo @@ -1429,15 +1339,15 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - prsi(i,j,k) = IPD_Data(nb)%Statein%prsi(ix,k) - phii(i,j,k) = IPD_Data(nb)%Statein%phii(ix,k) + prsi(i,j,k) = GFS_data(nb)%Statein%prsi(ix,k) + phii(i,j,k) = GFS_data(nb)%Statein%phii(ix,k) enddo enddo !--- tracers quantities do it = 1, nt !$OMP parallel do default (none) & -!$OMP shared (it, nk, nj, ni, Atm_block, IPD_Data, q) & +!$OMP shared (it, nk, nj, ni, Atm_block, GFS_data, q) & !$OMP private (k, j, jb, i, ib, nb, ix) do k = 1, nk do j = 1, nj @@ -1446,14 +1356,14 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - q(i,j,k,it) = IPD_Data(nb)%Stateout%gq0(ix,k,it) + q(i,j,k,it) = GFS_data(nb)%Stateout%gq0(ix,k,it) enddo enddo enddo enddo !$OMP parallel do default (none) & -!$OMP shared (nj, ni, Atm_block, IPD_Data, & +!$OMP shared (nj, ni, Atm_block, GFS_data, & !$OMP hpbl, area, stype, rainc, rain, uustar, sfcdsw, & !$OMP slmsk, snowd, tsfc, shfsfc, vtype, vfrac, zorl, slc) & !$OMP private (j, jb, i, ib, nb, ix) @@ -1463,28 +1373,28 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - hpbl(i,j) = IPD_Data(nb)%Tbd%hpbl(ix) - area(i,j) = IPD_Data(nb)%Grid%area(ix) - stype(i,j) = IPD_Data(nb)%Sfcprop%stype(ix) - rainc(i,j) = IPD_Data(nb)%Coupling%rainc_cpl(ix) - rain(i,j) = IPD_Data(nb)%Coupling%rain_cpl(ix) & - + IPD_Data(nb)%Coupling%snow_cpl(ix) - uustar(i,j) = IPD_Data(nb)%Sfcprop%uustar(ix) - sfcdsw(i,j) = IPD_Data(nb)%Coupling%sfcdsw(ix) - slmsk(i,j) = IPD_Data(nb)%Sfcprop%slmsk(ix) - snowd(i,j) = IPD_Data(nb)%Sfcprop%snowd(ix) - tsfc(i,j) = IPD_Data(nb)%Sfcprop%tsfc(ix) - shfsfc(i,j) = IPD_Data(nb)%Coupling%ushfsfci(ix) - vtype(i,j) = IPD_Data(nb)%Sfcprop%vtype(ix) - vfrac(i,j) = IPD_Data(nb)%Sfcprop%vfrac(ix) - zorl(i,j) = IPD_Data(nb)%Sfcprop%zorl(ix) - slc(i,j,:) = IPD_Data(nb)%Sfcprop%slc(ix,:) + hpbl(i,j) = GFS_data(nb)%Tbd%hpbl(ix) + area(i,j) = GFS_data(nb)%Grid%area(ix) + stype(i,j) = GFS_data(nb)%Sfcprop%stype(ix) + rainc(i,j) = GFS_data(nb)%Coupling%rainc_cpl(ix) + rain(i,j) = GFS_data(nb)%Coupling%rain_cpl(ix) & + + GFS_data(nb)%Coupling%snow_cpl(ix) + uustar(i,j) = GFS_data(nb)%Sfcprop%uustar(ix) + sfcdsw(i,j) = GFS_data(nb)%Coupling%sfcdsw(ix) + slmsk(i,j) = GFS_data(nb)%Sfcprop%slmsk(ix) + snowd(i,j) = GFS_data(nb)%Sfcprop%snowd(ix) + tsfc(i,j) = GFS_data(nb)%Sfcprop%tsfc(ix) + shfsfc(i,j) = GFS_data(nb)%Coupling%ushfsfci(ix) + vtype(i,j) = GFS_data(nb)%Sfcprop%vtype(ix) + vfrac(i,j) = GFS_data(nb)%Sfcprop%vfrac(ix) + zorl(i,j) = GFS_data(nb)%Sfcprop%zorl(ix) + slc(i,j,:) = GFS_data(nb)%Sfcprop%slc(ix,:) enddo enddo ! -- zero out accumulated fields !$OMP parallel do default (none) & -!$OMP shared (nj, ni, Atm_block, IPD_Control, IPD_Data) & +!$OMP shared (nj, ni, Atm_block, GFS_control, GFS_data) & !$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 @@ -1492,15 +1402,15 @@ subroutine update_atmos_chemistry(state, rc) ib = i + Atm_block%isc - 1 nb = Atm_block%blkno(ib,jb) ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%coupling%rainc_cpl(ix) = zero - if (.not.IPD_Control%cplflx) then - IPD_Data(nb)%coupling%rain_cpl(ix) = zero - IPD_Data(nb)%coupling%snow_cpl(ix) = zero + GFS_data(nb)%coupling%rainc_cpl(ix) = zero + if (.not.GFS_control%cplflx) then + GFS_data(nb)%coupling%rain_cpl(ix) = zero + GFS_data(nb)%coupling%snow_cpl(ix) = zero end if enddo enddo - if (IPD_Control%debug) then + if (GFS_control%debug) then ! -- diagnostics write(6,'("update_atmos: prsi - min/max/avg",3g16.6)') minval(prsi), maxval(prsi), sum(prsi)/size(prsi) write(6,'("update_atmos: phii - min/max/avg",3g16.6)') minval(phii), maxval(phii), sum(phii)/size(phii) @@ -1616,27 +1526,27 @@ subroutine assign_importdata(rc) type(ESMF_TypeKind_Flag) :: datatype real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d - real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 - real(kind=IPD_kind_phys) :: tem, ofrac + real(kind=GFS_kind_phys), dimension(:,:), pointer :: datar8 + real(kind=GFS_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice - real (kind=IPD_kind_phys), parameter :: z0ice=1.1 ! (in cm) + real (kind=GFS_kind_phys), parameter :: z0ice=1.1 ! (in cm) ! !------------------------------------------------------------------------------ ! ! set up local dimension rc = -999 - isc = IPD_control%isc - iec = IPD_control%isc+IPD_control%nx-1 - jsc = IPD_control%jsc - jec = IPD_control%jsc+IPD_control%ny-1 + isc = GFS_control%isc + iec = GFS_control%isc+GFS_control%nx-1 + jsc = GFS_control%jsc + jec = GFS_control%jsc+GFS_control%ny-1 lcpl_fice = .false. allocate(datar8(isc:iec,jsc:jec)) ! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,dim=',isc,iec,jsc,jec -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,IPD_Data, size', size(IPD_Data) -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,tsfc, size', size(IPD_Data(1)%sfcprop%tsfc) -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,tsfc, min_seaice', IPD_Control%min_seaice +! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,GFS_data, size', size(GFS_data) +! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,tsfc, size', size(GFS_data(1)%sfcprop%tsfc) +! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplImp,tsfc, min_seaice', GFS_control%min_seaice do n=1,nImportFields ! Each import field is only available if it was connected in the import state. @@ -1680,7 +1590,7 @@ subroutine assign_importdata(rc) ! do i=isc,iec ! nb = Atm_block%blkno(i,j) ! ix = Atm_block%ixp(i,j) -! IPD_Data(nb)%Coupling%slimskin_cpl(ix) = datar8(i,j) +! GFS_data(nb)%Coupling%slimskin_cpl(ix) = datar8(i,j) ! enddo ! enddo ! if( mpp_pe()==mpp_root_pe()) print *,'get land mask from mediator' @@ -1693,19 +1603,19 @@ subroutine assign_importdata(rc) fldname = 'wave_z0_roughness_length' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) - if (importFieldsValid(findex) .and. IPD_control%cplwav2atm) then + if (importFieldsValid(findex) .and. GFS_control%cplwav2atm) then !$omp parallel do default(shared) private(i,j,nb,ix,tem) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > zorlmin) then - tem = 100.0_IPD_kind_phys * min(0.1_IPD_kind_phys, datar8(i,j)) -! IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem - IPD_Data(nb)%Sfcprop%zorlo(ix) = tem - IPD_Data(nb)%Sfcprop%zorlw(ix) = tem + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > zorlmin) then + tem = 100.0_GFS_kind_phys * min(0.1_GFS_kind_phys, datar8(i,j)) +! GFS_data(nb)%Coupling%zorlwav_cpl(ix) = tem + GFS_data(nb)%Sfcprop%zorlo(ix) = tem + GFS_data(nb)%Sfcprop%zorlw(ix) = tem else - IPD_Data(nb)%Sfcprop%zorlw(ix) = -999.0_IPD_kind_phys + GFS_data(nb)%Sfcprop%zorlw(ix) = -999.0_GFS_kind_phys endif enddo @@ -1724,9 +1634,9 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then -! IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) - IPD_Data(nb)%Sfcprop%tisfc(ix) = datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then +! GFS_data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + GFS_data(nb)%Sfcprop%tisfc(ix) = datar8(i,j) endif enddo enddo @@ -1744,9 +1654,9 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then -! IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) - IPD_Data(nb)%Sfcprop%tsfco(ix) = datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then +! GFS_data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) + GFS_data(nb)%Sfcprop%tsfco(ix) = datar8(i,j) endif enddo enddo @@ -1767,20 +1677,20 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) - ofrac = IPD_Data(nb)%Sfcprop%oceanfrac(ix) + GFS_data(nb)%Coupling%slimskin_cpl(ix) = GFS_data(nb)%Sfcprop%slmsk(ix) + ofrac = GFS_data(nb)%Sfcprop%oceanfrac(ix) if (ofrac > zero) then - IPD_Data(nb)%Sfcprop%fice(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area - if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then - if (IPD_Data(nb)%Sfcprop%fice(ix) > one-epsln) IPD_Data(nb)%Sfcprop%fice(ix) = one - if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys !slmsk=2 crashes in gcycle on partial land points -! IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4.0_IPD_kind_phys + GFS_data(nb)%Sfcprop%fice(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area + if (GFS_data(nb)%Sfcprop%fice(ix) >= GFS_control%min_seaice) then + if (GFS_data(nb)%Sfcprop%fice(ix) > one-epsln) GFS_data(nb)%Sfcprop%fice(ix) = one + if (abs(one-ofrac) < epsln) GFS_data(nb)%Sfcprop%slmsk(ix) = 2.0_GFS_kind_phys !slmsk=2 crashes in gcycle on partial land points +! GFS_data(nb)%Sfcprop%slmsk(ix) = 2.0_GFS_kind_phys + GFS_data(nb)%Coupling%slimskin_cpl(ix) = 4.0_GFS_kind_phys else - IPD_Data(nb)%Sfcprop%fice(ix) = zero + GFS_data(nb)%Sfcprop%fice(ix) = zero if (abs(one-ofrac) < epsln) then - IPD_Data(nb)%Sfcprop%slmsk(ix) = zero - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero + GFS_data(nb)%Sfcprop%slmsk(ix) = zero + GFS_data(nb)%Coupling%slimskin_cpl(ix) = zero endif endif endif @@ -1801,15 +1711,15 @@ subroutine assign_importdata(rc) ! do i=isc,iec ! nb = Atm_block%blkno(i,j) ! ix = Atm_block%ixp(i,j) -! if (IPD_Data(nb)%Sfcprop%slmsk(ix) < 0.1 .or. IPD_Data(nb)%Sfcprop%slmsk(ix) > 1.9) then -! IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -datar8(i,j) +! if (GFS_data(nb)%Sfcprop%slmsk(ix) < 0.1 .or. GFS_data(nb)%Sfcprop%slmsk(ix) > 1.9) then +! GFS_data(nb)%Coupling%ulwsfcin_cpl(ix) = -datar8(i,j) ! endif ! enddo do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%ulwsfcin_cpl(ix) = -datar8(i,j) endif enddo enddo @@ -1828,8 +1738,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%dqsfcin_cpl(ix) = -datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%dqsfcin_cpl(ix) = -datar8(i,j) endif enddo enddo @@ -1848,8 +1758,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%dtsfcin_cpl(ix) = -datar8(i,j) endif enddo enddo @@ -1868,8 +1778,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%dusfcin_cpl(ix) = -datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%dusfcin_cpl(ix) = -datar8(i,j) endif enddo enddo @@ -1888,8 +1798,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%dvsfcin_cpl(ix) = -datar8(i,j) endif enddo enddo @@ -1908,9 +1818,9 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then -! IPD_Data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) - IPD_Data(nb)%Sfcprop%hice(ix) = datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then +! GFS_data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) + GFS_data(nb)%Sfcprop%hice(ix) = datar8(i,j) endif enddo enddo @@ -1929,8 +1839,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = datar8(i,j) + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then + GFS_data(nb)%Coupling%hsnoin_cpl(ix) = datar8(i,j) endif enddo enddo @@ -1951,37 +1861,37 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then + if (GFS_data(nb)%Sfcprop%oceanfrac(ix) > zero) then !if it is ocean or ice get surface temperature from mediator - if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then - -! if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then -! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) -! IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) -! IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) -! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) - - IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & - / max(0.01_IPD_kind_phys, IPD_Data(nb)%Sfcprop%fice(ix)) -! / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) - IPD_Data(nb)%Sfcprop%zorli(ix) = z0ice + if (GFS_data(nb)%Sfcprop%fice(ix) >= GFS_control%min_seaice) then + +! if(GFS_data(nb)%Coupling%ficein_cpl(ix) >= GFS_control%min_seaice) then +! GFS_data(nb)%Sfcprop%tisfc(ix) = GFS_data(nb)%Coupling%tisfcin_cpl(ix) +! GFS_data(nb)%Sfcprop%fice(ix) = GFS_data(nb)%Coupling%ficein_cpl(ix) +! GFS_data(nb)%Sfcprop%hice(ix) = GFS_data(nb)%Coupling%hicein_cpl(ix) +! GFS_data(nb)%Sfcprop%snowd(ix) = GFS_data(nb)%Coupling%hsnoin_cpl(ix) + + GFS_data(nb)%Coupling%hsnoin_cpl(ix) = GFS_data(nb)%Coupling%hsnoin_cpl(ix) & + / max(0.01_GFS_kind_phys, GFS_data(nb)%Sfcprop%fice(ix)) +! / max(0.01_GFS_kind_phys, GFS_data(nb)%Coupling%ficein_cpl(ix)) + GFS_data(nb)%Sfcprop%zorli(ix) = z0ice else -! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Sfcprop%tsfco(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = zero - IPD_Data(nb)%Sfcprop%hice(ix) = zero -! IPD_Data(nb)%Sfcprop%snowd(ix) = zero - IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = zero +! GFS_data(nb)%Sfcprop%tisfc(ix) = GFS_data(nb)%Coupling%tseain_cpl(ix) + GFS_data(nb)%Sfcprop%tisfc(ix) = GFS_data(nb)%Sfcprop%tsfco(ix) + GFS_data(nb)%Sfcprop%fice(ix) = zero + GFS_data(nb)%Sfcprop%hice(ix) = zero +! GFS_data(nb)%Sfcprop%snowd(ix) = zero + GFS_data(nb)%Coupling%hsnoin_cpl(ix) = zero ! - IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! over open water - should not be used in ATM - IPD_Data(nb)%Coupling%dqsfcin_cpl(ix) = -99999.0 ! ,, - IPD_Data(nb)%Coupling%dusfcin_cpl(ix) = -99999.0 ! ,, - IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, - IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, - IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then ! 100% open water - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero - IPD_Data(nb)%Sfcprop%slmsk(ix) = zero + GFS_data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! over open water - should not be used in ATM + GFS_data(nb)%Coupling%dqsfcin_cpl(ix) = -99999.0 ! ,, + GFS_data(nb)%Coupling%dusfcin_cpl(ix) = -99999.0 ! ,, + GFS_data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, + GFS_data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, + GFS_data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, + if (abs(one-GFS_data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then ! 100% open water + GFS_data(nb)%Coupling%slimskin_cpl(ix) = zero + GFS_data(nb)%Sfcprop%slmsk(ix) = zero endif endif endif @@ -1994,13 +1904,13 @@ subroutine assign_importdata(rc) ! do i=isc,iec ! nb = Atm_block%blkno(i,j) ! ix = Atm_block%ixp(i,j) -! if (abs(IPD_Data(nb)%Grid%xlon_d(ix)-2.89) < 0.1 .and. & -! abs(IPD_Data(nb)%Grid%xlat_d(ix)+58.99) < 0.1) then -! write(0,*)' in assign tisfc=',IPD_Data(nb)%Sfcprop%tisfc(ix), & -! ' oceanfrac=',IPD_Data(nb)%Sfcprop%oceanfrac(ix),' i=',i,' j=',j,& -!! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & -! ' tisfcin=',IPD_Data(nb)%Sfcprop%tisfc(ix), & -! ' fice=',IPD_Data(nb)%Sfcprop%fice(ix) +! if (abs(GFS_data(nb)%Grid%xlon_d(ix)-2.89) < 0.1 .and. & +! abs(GFS_data(nb)%Grid%xlat_d(ix)+58.99) < 0.1) then +! write(0,*)' in assign tisfc=',GFS_data(nb)%Sfcprop%tisfc(ix), & +! ' oceanfrac=',GFS_data(nb)%Sfcprop%oceanfrac(ix),' i=',i,' j=',j,& +!! ' tisfcin=',GFS_data(nb)%Coupling%tisfcin_cpl(ix), & +! ' tisfcin=',GFS_data(nb)%Sfcprop%tisfc(ix), & +! ' fice=',GFS_data(nb)%Sfcprop%fice(ix) ! endif ! enddo ! enddo @@ -2027,20 +1937,20 @@ subroutine setup_exportdata (rc) !--- local variables integer :: j, i, ix, nb, isc, iec, jsc, jec, idx - real(IPD_kind_phys) :: rtime, rtimek + real(GFS_kind_phys) :: rtime, rtimek ! if (mpp_pe() == mpp_root_pe()) print *,'enter setup_exportdata' - isc = IPD_control%isc - iec = IPD_control%isc+IPD_control%nx-1 - jsc = IPD_control%jsc - jec = IPD_control%jsc+IPD_control%ny-1 + isc = GFS_control%isc + iec = GFS_control%isc+GFS_control%nx-1 + jsc = GFS_control%jsc + jec = GFS_control%jsc+GFS_control%ny-1 - rtime = one / IPD_control%dtp - rtimek = IPD_control%rho_h2o * rtime + rtime = one / GFS_control%dtp + rtimek = GFS_control%rho_h2o * rtime ! print *,'in cplExp,dim=',isc,iec,jsc,jec,'nExportFields=',nExportFields -! print *,'in cplExp,IPD_Data, size', size(IPD_Data) -! print *,'in cplExp,u10micpl, size', size(IPD_Data(1)%coupling%u10mi_cpl) +! print *,'in cplExp,GFS_data, size', size(GFS_data) +! print *,'in cplExp,u10micpl, size', size(GFS_data(1)%coupling%u10mi_cpl) if(.not.allocated(exportData)) then allocate(exportData(isc:iec,jsc:jec,nExportFields)) @@ -2048,7 +1958,7 @@ subroutine setup_exportdata (rc) ! set cpl fields to export Data - if (IPD_Control%cplflx .or. IPD_Control%cplwav) then + if (GFS_control%cplflx .or. GFS_control%cplwav) then ! Instantaneous u wind (m/s) 10 m above ground idx = queryfieldlist(exportFieldsList,'inst_zonal_wind_height10m') if (idx > 0 ) then @@ -2058,7 +1968,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%u10mi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%u10mi_cpl(ix) enddo enddo endif @@ -2072,7 +1982,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%v10mi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%v10mi_cpl(ix) enddo enddo if (mpp_pe() == mpp_root_pe() .and. debug) print *,'cpl, get v10mi_cpl, exportData=',exportData(isc,jsc,idx),'idx=',idx @@ -2080,7 +1990,7 @@ subroutine setup_exportdata (rc) endif !if cplflx or cplwav - if (IPD_Control%cplflx) then + if (GFS_control%cplflx) then ! MEAN Zonal compt of momentum flux (N/m**2) idx = queryfieldlist(exportFieldsList,'mean_zonal_moment_flx_atm') if (idx > 0 ) then @@ -2089,7 +1999,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dusfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dusfc_cpl(ix) * rtime enddo enddo endif @@ -2102,7 +2012,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dvsfc_cpl(ix) * rtime enddo enddo endif @@ -2115,7 +2025,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dtsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dtsfc_cpl(ix) * rtime enddo enddo endif @@ -2128,7 +2038,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dqsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dqsfc_cpl(ix) * rtime enddo enddo endif @@ -2141,7 +2051,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dlwsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dlwsfc_cpl(ix) * rtime enddo enddo endif @@ -2154,7 +2064,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dswsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dswsfc_cpl(ix) * rtime enddo enddo endif @@ -2167,7 +2077,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%rain_cpl(ix) * rtimek + exportData(i,j,idx) = GFS_data(nb)%coupling%rain_cpl(ix) * rtimek enddo enddo endif @@ -2180,7 +2090,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dusfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dusfci_cpl(ix) enddo enddo endif @@ -2193,7 +2103,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dvsfci_cpl(ix) enddo enddo endif @@ -2206,7 +2116,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dtsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dtsfci_cpl(ix) enddo enddo endif @@ -2219,7 +2129,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dqsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dqsfci_cpl(ix) enddo enddo endif @@ -2232,7 +2142,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dlwsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dlwsfci_cpl(ix) enddo enddo endif @@ -2245,7 +2155,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dswsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dswsfci_cpl(ix) enddo enddo endif @@ -2258,7 +2168,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%t2mi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%t2mi_cpl(ix) enddo enddo endif @@ -2271,7 +2181,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%q2mi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%q2mi_cpl(ix) enddo enddo endif @@ -2284,7 +2194,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%tsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%tsfci_cpl(ix) enddo enddo endif @@ -2297,7 +2207,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%psurfi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%psurfi_cpl(ix) enddo enddo endif @@ -2310,7 +2220,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%oro_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%oro_cpl(ix) enddo enddo endif @@ -2323,7 +2233,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nlwsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nlwsfc_cpl(ix) * rtime enddo enddo endif @@ -2336,7 +2246,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nswsfc_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nswsfc_cpl(ix) * rtime enddo enddo endif @@ -2349,7 +2259,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nlwsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nlwsfci_cpl(ix) enddo enddo endif @@ -2362,7 +2272,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nswsfci_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nswsfci_cpl(ix) enddo enddo endif @@ -2375,7 +2285,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dnirbm_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dnirbm_cpl(ix) * rtime enddo enddo endif @@ -2388,7 +2298,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dnirdf_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dnirdf_cpl(ix) * rtime enddo enddo endif @@ -2401,7 +2311,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvisbm_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dvisbm_cpl(ix) * rtime enddo enddo endif @@ -2414,7 +2324,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvisdf_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%dvisdf_cpl(ix) * rtime enddo enddo endif @@ -2427,7 +2337,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dnirbmi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dnirbmi_cpl(ix) enddo enddo endif @@ -2440,7 +2350,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dnirdfi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dnirdfi_cpl(ix) enddo enddo endif @@ -2453,7 +2363,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvisbmi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dvisbmi_cpl(ix) enddo enddo endif @@ -2466,7 +2376,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%dvisdfi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%dvisdfi_cpl(ix) enddo enddo endif @@ -2479,7 +2389,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nnirbm_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nnirbm_cpl(ix) * rtime enddo enddo endif @@ -2492,7 +2402,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nnirdf_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nnirdf_cpl(ix) * rtime enddo enddo endif @@ -2505,7 +2415,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nvisbm_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nvisbm_cpl(ix) * rtime enddo enddo endif @@ -2518,7 +2428,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nvisdf_cpl(ix) * rtime + exportData(i,j,idx) = GFS_data(nb)%coupling%nvisdf_cpl(ix) * rtime enddo enddo endif @@ -2531,7 +2441,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nnirbmi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nnirbmi_cpl(ix) enddo enddo endif @@ -2544,7 +2454,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nnirdfi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nnirdfi_cpl(ix) enddo enddo endif @@ -2557,7 +2467,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nvisbmi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nvisbmi_cpl(ix) enddo enddo endif @@ -2570,7 +2480,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%nvisdfi_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%nvisdfi_cpl(ix) enddo enddo endif @@ -2583,7 +2493,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%slmsk_cpl(ix) + exportData(i,j,idx) = GFS_data(nb)%coupling%slmsk_cpl(ix) enddo enddo endif @@ -2705,7 +2615,7 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%snow_cpl(ix) * rtimek + exportData(i,j,idx) = GFS_data(nb)%coupling%snow_cpl(ix) * rtimek enddo enddo endif @@ -2716,34 +2626,34 @@ subroutine setup_exportdata (rc) call fillExportFields(exportData) !--- - if (IPD_Control%cplflx) then + if (GFS_control%cplflx) then ! zero out accumulated fields !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%coupling%dusfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dvsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dtsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dqsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dlwsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dswsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%rain_cpl(ix) = zero - IPD_Data(nb)%coupling%nlwsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%nswsfc_cpl(ix) = zero - IPD_Data(nb)%coupling%dnirbm_cpl(ix) = zero - IPD_Data(nb)%coupling%dnirdf_cpl(ix) = zero - IPD_Data(nb)%coupling%dvisbm_cpl(ix) = zero - IPD_Data(nb)%coupling%dvisdf_cpl(ix) = zero - IPD_Data(nb)%coupling%nnirbm_cpl(ix) = zero - IPD_Data(nb)%coupling%nnirdf_cpl(ix) = zero - IPD_Data(nb)%coupling%nvisbm_cpl(ix) = zero - IPD_Data(nb)%coupling%nvisdf_cpl(ix) = zero - IPD_Data(nb)%coupling%snow_cpl(ix) = zero + GFS_data(nb)%coupling%dusfc_cpl(ix) = zero + GFS_data(nb)%coupling%dvsfc_cpl(ix) = zero + GFS_data(nb)%coupling%dtsfc_cpl(ix) = zero + GFS_data(nb)%coupling%dqsfc_cpl(ix) = zero + GFS_data(nb)%coupling%dlwsfc_cpl(ix) = zero + GFS_data(nb)%coupling%dswsfc_cpl(ix) = zero + GFS_data(nb)%coupling%rain_cpl(ix) = zero + GFS_data(nb)%coupling%nlwsfc_cpl(ix) = zero + GFS_data(nb)%coupling%nswsfc_cpl(ix) = zero + GFS_data(nb)%coupling%dnirbm_cpl(ix) = zero + GFS_data(nb)%coupling%dnirdf_cpl(ix) = zero + GFS_data(nb)%coupling%dvisbm_cpl(ix) = zero + GFS_data(nb)%coupling%dvisdf_cpl(ix) = zero + GFS_data(nb)%coupling%nnirbm_cpl(ix) = zero + GFS_data(nb)%coupling%nnirdf_cpl(ix) = zero + GFS_data(nb)%coupling%nvisbm_cpl(ix) = zero + GFS_data(nb)%coupling%nvisdf_cpl(ix) = zero + GFS_data(nb)%coupling%snow_cpl(ix) = zero enddo enddo - if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling accumulated fields at kdt= ',IPD_Control%kdt + if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling accumulated fields at kdt= ',GFS_control%kdt endif !cplflx ! if (mpp_pe() == mpp_root_pe()) print *,'end of setup_exportdata' @@ -2765,10 +2675,10 @@ subroutine addLsmask2grid(fcstGrid, rc) integer, allocatable :: lsmask(:,:) integer(kind=ESMF_KIND_I4), pointer :: maskPtr(:,:) ! - isc = IPD_control%isc - iec = IPD_control%isc+IPD_control%nx-1 - jsc = IPD_control%jsc - jec = IPD_control%jsc+IPD_control%ny-1 + isc = GFS_control%isc + iec = GFS_control%isc+GFS_control%nx-1 + jsc = GFS_control%jsc + jec = GFS_control%jsc+GFS_control%ny-1 allocate(lsmask(isc:iec,jsc:jec)) ! !$omp parallel do default(shared) private(i,j,nb,ix) @@ -2777,7 +2687,7 @@ subroutine addLsmask2grid(fcstGrid, rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) ! use land sea mask: land:1, ocean:0 - lsmask(i,j) = floor(one + epsln - IPD_Data(nb)%SfcProp%oceanfrac(ix)) + lsmask(i,j) = floor(one + epsln - GFS_data(nb)%SfcProp%oceanfrac(ix)) enddo enddo ! diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index 750ae5c14..760e09a8e 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -25,8 +25,6 @@ endif() # Set include directories for make, also set CCPP_... for external projects INCLUDE_DIRECTORIES(${CMAKE_CURRENT_BINARY_DIR}/framework/src) INCLUDE_DIRECTORIES(${CMAKE_CURRENT_BINARY_DIR}/physics) -SET(CCPP_INCLUDE_DIRS "${CMAKE_CURRENT_BINARY_DIR}/framework/src;${CMAKE_CURRENT_BINARY_DIR}/physics") -SET(CCPP_LIB_DIRS "${CMAKE_CURRENT_BINARY_DIR}/framework/src;${CMAKE_CURRENT_BINARY_DIR}/physics") #------------------------------------------------------------------------------ # Generate Compiler flags for C/CXX/Fortran - set to match NEMSfv3gfs flags @@ -121,11 +119,9 @@ elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") elseif (${CMAKE_BUILD_TYPE} MATCHES "Release") # Specify aggressive optimization flags (to be overwritten for individual files in ccpp-physics' CMakeLists.txt) if (AVX2) - if (SIMDMULTIARCH) - set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,AVX,CORE-AVX2,CORE-AVX512") - else (SIMDMULTIARCH) - set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2") - endif (SIMDMULTIARCH) + set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2") + elseif (SIMDMULTIARCH) + set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,CORE-AVX2") endif (AVX2) set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -debug minimal -fp-model source -qoverride-limits -qopt-prefetch=3") endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") @@ -160,10 +156,6 @@ else (APPLE) message (FATAL_ERROR "Unsupported platform, only Linux and MacOSX are supported at this time.") endif(APPLE) -#------------------------------------------------------------------------------ -# Add -DCCPP preprocessor flag (needed to preprocess GFS_typedefs.F90 from FV3) -ADD_DEFINITIONS(-DCCPP) - #------------------------------------------------------------------------------ # Add host-model specific preprocessor flag (needed for some physics schemes) ADD_DEFINITIONS(-DFV3) diff --git a/ccpp/build_ccpp.sh b/ccpp/build_ccpp.sh deleted file mode 100755 index 2e9aa9a11..000000000 --- a/ccpp/build_ccpp.sh +++ /dev/null @@ -1,193 +0,0 @@ -#!/bin/bash - -set +x -set -eu - -# List of valid/tested machines -VALID_MACHINES=( wcoss_cray wcoss_dell_p3 gaea.intel jet.intel \ - hera.intel hera.gnu orion.intel \ - cheyenne.intel cheyenne.gnu \ - endeavor.intel stampede.intel \ - macosx.gnu \ - linux.intel linux.gnu linux.pgi ) - -################################################################################################### - -function usage { - echo "Usage: " - echo "build_ccpp.sh MACHINE_ID CCPP_DIR CCPP_MK [ 'MAKE_OPT' ] [ clean_before ] [ clean_after ]" - echo " Where: MACHINE [required] can be : ${VALID_MACHINES[@]}" - echo " CCPP_DIR [required] is the target installation directory for CCPP" - echo " CCPP_MK [required] is the location/name of the CCPP ESMF makefile fragment" - echo " MAKE_OPT [optional] can be any of the NEMSfv3gfs MAKE_OPT options," - echo " enclosed in a single string; used:" - echo " SION=Y/N (default N)" - echo " DEBUG=Y/N (default N)" - echo " REPRO=Y/N (default N)" - echo " OPENMP=Y/N (default Y)" - echo " 32BIT=Y/N (default N, affects dynamics/fast physics only)" - echo " SUITES=ABC,XYZ (comma-separated list of CCPP suites; " - echo " corresponding filenames: suite_ABC.xml. ...)" - echo " MULTI_GASES=Y/N (default N)" - echo " clean_before [optional] can be 'YES' (default) or 'NO'" - echo " clean_after [optional] can be 'YES' (default) or 'NO'" - exit 1 -} - -function checkvalid { -# Ensure value ($2) of variable ($1) is contained in list of validvalues ($3) - if [ $# -lt 3 ]; then - echo $FUNCNAME requires at least 3 arguments: stopping - exit 1 - fi - - var_name=$1 && shift - input_val=$1 && shift - valid_vars=($@) - - for x in ${valid_vars[@]}; do - if [ "$input_val" == "$x" ]; then - echo "${var_name}=${input_val} is valid." - return - fi - done - echo "ERROR: ${var_name}=${input_val} is invalid." - usage - exit 1 -} - -function trim { - local var="$1" - # remove leading whitespace characters - var="${var#"${var%%[![:space:]]*}"}" - # remove trailing whitespace characters - var="${var%"${var##*[![:space:]]}"}" - echo -n "$var" -} - -################################################################################################### - -# Check and process command line arguments - -if [[ $# -lt 2 ]]; then usage; fi - -readonly MACHINE_ID=$1 -readonly CCPP_DIR=$2 -readonly CCPP_MK=$3 -readonly MAKE_OPT=${4:-} -readonly clean_before=${5:-YES} -readonly clean_after=${6:-YES} - -checkvalid MACHINE_ID $MACHINE_ID ${VALID_MACHINES[@]} - -# Set compilers for cmake -source ./set_compilers.sh - -# Obtain ESMF_LIB from ESMFMKFILE's ESMF_LIBSDIR entry -readonly ESMF_LIB=$(cat $ESMFMKFILE | grep -E '^ESMF_LIBSDIR=.+' | cut -d = -f 2) -echo "Obtained ESMF_LIB=${ESMF_LIB} from ${ESMFMKFILE}" - -# Account for inconsistencies in HPC modules: if environment variable -# NETCDF is undefined, try to set from NETCDF_DIR, NETCDF_ROOT, ... -if [[ "${MACHINE_ID}" == "wcoss_cray" || "${MACHINE_ID}" == "gaea.intel" ]]; then - NETCDF=${NETCDF:-${NETCDF_DIR}} -fi - -# Generate CCPP cmake flags from MAKE_OPT -CCPP_CMAKE_FLAGS="-DCMAKE_INSTALL_PREFIX=${CCPP_DIR} -DNETCDF_DIR=${NETCDF} -DMPI=ON" -CCPP_MAKE_FLAGS="" -if [[ "${MAKE_OPT}" == *"SION=Y"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DSIONLIB=${SIONLIB}" -fi -if [[ "${MAKE_OPT}" == *"DEBUG=Y"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DCMAKE_BUILD_TYPE=Debug" - CCPP_MAKE_FLAGS="${CCPP_MAKE_FLAGS} VERBOSE=1" -elif [[ "${MAKE_OPT}" == *"REPRO=Y"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DCMAKE_BUILD_TYPE=Bitforbit" - CCPP_MAKE_FLAGS="${CCPP_MAKE_FLAGS} VERBOSE=1" -else - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DCMAKE_BUILD_TYPE=Release" - # Don't use the AVX512 flags yet on hera - #if [[ "${MACHINE_ID}" == "jet.intel" || "${MACHINE_ID}" == "hera.intel" ]]; then - if [[ "${MACHINE_ID}" == "jet.intel" ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DSIMDMULTIARCH=ON" - fi - CCPP_MAKE_FLAGS="${CCPP_MAKE_FLAGS} VERBOSE=1" -fi -if [[ "${MAKE_OPT}" == *"OPENMP=N"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DOPENMP=OFF" -else - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DOPENMP=ON" -fi -if [[ "${MAKE_OPT}" == *"32BIT=Y"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DDYN32=ON" -else - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DDYN32=OFF" -fi -if [[ "${MAKE_OPT}" == *"MULTI_GASES=Y"* ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DMULTI_GASES=ON" -else - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DMULTI_GASES=OFF" -fi - -# Flag to cmake that modern Intel compilers are used -CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DLEGACY_INTEL=OFF" - -# Generate additional CCPP cmake flags depending on machine / compiler -if [[ "${MACHINE_ID}" == "macosx.gnu" ]]; then - # Intel MKL (for FFTW) - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DMKL_DIR=${MKL_DIR}" - # ESMF (for DGEMM) - replace with MKL version in the future? - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DESMF_LIB_DIR=${ESMF_LIB}" - # netCDF (needed when linking ESMF) - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DNETCDF_DIR=${NETCDF}" -elif [[ "${MACHINE_ID}" == "linux.gnu" ]]; then - # ESMF (for DGEMM) - replace with MKL version in the future? - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DESMF_LIB_DIR=${ESMF_LIB}" - # netCDF (needed when linking ESMF) - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DNETCDF_DIR=${NETCDF}" -elif [[ "${MACHINE_ID}" == "gaea.intel" || "${MACHINE_ID}" == "wcoss_cray" ]]; then - # Fix broken libxml2 installation on gaea by - # using own version (not known to the system) - if [[ "${MACHINE_ID}" == "gaea.intel" ]]; then - CCPP_CMAKE_FLAGS="${CCPP_CMAKE_FLAGS} -DLIBXML2_LIB_DIR=${LIBXML2_LIB_DIR} -DLIBXML2_INCLUDE_DIR=${LIBXML2_INCLUDE_DIR}" - fi -fi - -CCPP_CMAKE_FLAGS=$(trim "${CCPP_CMAKE_FLAGS}") -CCPP_MAKE_FLAGS=$(trim "${CCPP_MAKE_FLAGS}") - -# Build and install CCPP - -echo "Building CCPP with options '${CCPP_CMAKE_FLAGS}' ..." -PATH_CCPP=${PWD} -PATH_CCPP_BUILD=${PWD}/build -PATH_CCPP_INC=${PWD}/include -PATH_CCPP_LIB=${PWD}/lib - -if [ $clean_before = YES ]; then - rm -fr ${PATH_CCPP_BUILD} - rm -fr ${PATH_CCPP_INC} - rm -fr ${PATH_CCPP_LIB} - rm -f ${CCPP_MK} -fi -mkdir -p ${PATH_CCPP_BUILD} -cd ${PATH_CCPP_BUILD} -cmake ${CCPP_CMAKE_FLAGS} ${PATH_CCPP} -make ${CCPP_MAKE_FLAGS} -make ${CCPP_MAKE_FLAGS} install - -# Generate ESMF makefile fragment - -set -u - -# Set linker flags -CCPP_LINK_OBJS="-L${PATH_CCPP_LIB} -lccpp -lccppphys" - -echo "ESMF_DEP_INCPATH=${PATH_CCPP_INC} ${PATH_CCPP_BUILD}/physics" > ${CCPP_MK} -echo "ESMF_DEP_LINK_OBJS=${CCPP_LINK_OBJS}" >> ${CCPP_MK} - -if [ $clean_after = YES ]; then - rm -fr ${PATH_CCPP_BUILD} -fi - diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index cfa0b5eb6..0dc6da2c1 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -17,10 +17,12 @@ # actual variable definition files 'ccpp/physics/physics/machine.F', 'ccpp/physics/physics/radsw_param.f', + 'ccpp/physics/physics/h2o_def.f', + 'ccpp/physics/physics/ozne_def.f', 'ccpp/physics/physics/radlw_param.f', - 'gfsphysics/CCPP_layer/CCPP_typedefs.F90', - 'gfsphysics/GFS_layer/GFS_typedefs.F90', - 'gfsphysics/CCPP_layer/CCPP_data.F90', + 'ccpp/data/CCPP_typedefs.F90', + 'ccpp/data/GFS_typedefs.F90', + 'ccpp/data/CCPP_data.F90', 'ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90', 'ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90', 'ccpp/physics/physics/rte-rrtmgp/rte/mo_optical_props.F90', @@ -113,6 +115,8 @@ 'ccpp/physics/physics/cires_ugwp_post.F90', 'ccpp/physics/physics/unified_ugwp.F90', 'ccpp/physics/physics/unified_ugwp_post.F90', + 'ccpp/physics/physics/ugwpv1_gsldrag.F90', + 'ccpp/physics/physics/ugwpv1_gsldrag_post.F90', 'ccpp/physics/physics/cnvc90.f', 'ccpp/physics/physics/cs_conv.F90', 'ccpp/physics/physics/cs_conv_aw_adj.F90', @@ -199,8 +203,10 @@ 'ccpp/physics/physics/rrtmgp_lw_cloud_sampling.F90', 'ccpp/physics/physics/rrtmgp_sw_cloud_sampling.F90', 'ccpp/physics/physics/GFS_cloud_diagnostics.F90', + 'ccpp/physics/physics/GFS_rrtmgp_thompsonmp_pre.F90', 'ccpp/physics/physics/GFS_rrtmgp_gfdlmp_pre.F90', 'ccpp/physics/physics/GFS_rrtmgp_zhaocarr_pre.F90', + 'ccpp/physics/physics/GFS_rrtmgp_cloud_overlap_pre.F90', 'ccpp/physics/physics/GFS_rrtmgp_sw_post.F90' ] @@ -295,12 +301,6 @@ 'rime_factor', ], }, - 'rrtmgp_lw_rte' : { - 'rrtmgp_lw_rte_run' : [ - 'RRTMGP_jacobian_of_lw_flux_profile_upward', - 'RRTMGP_jacobian_of_lw_flux_profile_downward', - ], - }, 'rrtmgp_sw_rte' : { 'rrtmgp_sw_rte_run' : [ 'components_of_surface_downward_shortwave_fluxes', @@ -317,12 +317,6 @@ 'tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step', ], }, - 'GFS_suite_interstitial_2' : { - 'GFS_suite_interstitial_2_run' : [ - 'RRTMGP_jacobian_of_lw_flux_profile_upward', - 'RRTMGP_lw_flux_profile_upward_allsky', - ], - }, #'subroutine_name_1' : 'all', #'subroutine_name_2' : 'none', #'subroutine_name_2' : [ 'var1', 'var3'], diff --git a/gfsphysics/CCPP_layer/CCPP_data.F90 b/ccpp/data/CCPP_data.F90 similarity index 100% rename from gfsphysics/CCPP_layer/CCPP_data.F90 rename to ccpp/data/CCPP_data.F90 diff --git a/gfsphysics/CCPP_layer/CCPP_data.meta b/ccpp/data/CCPP_data.meta similarity index 93% rename from gfsphysics/CCPP_layer/CCPP_data.meta rename to ccpp/data/CCPP_data.meta index 70c783820..43b82a22b 100644 --- a/gfsphysics/CCPP_layer/CCPP_data.meta +++ b/ccpp/data/CCPP_data.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = CCPP_data type = module - dependencies = ../../ccpp/framework/src/ccpp_types.F90,CCPP_typedefs.F90,../GFS_layer/GFS_typedefs.F90 + dependencies = ../framework/src/ccpp_types.F90,CCPP_typedefs.F90,GFS_typedefs.F90 [ccpp-arg-table] name = CCPP_data diff --git a/gfsphysics/CCPP_layer/CCPP_typedefs.F90 b/ccpp/data/CCPP_typedefs.F90 similarity index 100% rename from gfsphysics/CCPP_layer/CCPP_typedefs.F90 rename to ccpp/data/CCPP_typedefs.F90 diff --git a/gfsphysics/CCPP_layer/CCPP_typedefs.meta b/ccpp/data/CCPP_typedefs.meta similarity index 99% rename from gfsphysics/CCPP_layer/CCPP_typedefs.meta rename to ccpp/data/CCPP_typedefs.meta index 868dccebd..60c9420c1 100644 --- a/gfsphysics/CCPP_layer/CCPP_typedefs.meta +++ b/ccpp/data/CCPP_typedefs.meta @@ -342,7 +342,7 @@ [ccpp-table-properties] name = CCPP_typedefs type = module - dependencies = ../../ccpp/physics/physics/machine.F + dependencies = ../physics/physics/machine.F [ccpp-arg-table] name = CCPP_typedefs diff --git a/ccpp/data/CMakeLists.txt b/ccpp/data/CMakeLists.txt new file mode 100644 index 000000000..71ba6311d --- /dev/null +++ b/ccpp/data/CMakeLists.txt @@ -0,0 +1,43 @@ + +if(NOT DYN32) + remove_definitions(-DOVERLOAD_R8) + remove_definitions(-DOVERLOAD_R4) +endif() + +message ("Force 64 bits in ccpp/data") +if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") + if(REPRO) + string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") + else() + string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64 -no-prec-div -no-prec-sqrt" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") + endif() +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") +endif() + +list(APPEND _ccppdata_defs_private NEMS_GSM + MOIST_CAPPA + USE_COND + INTERNAL_FILE_NML) + +if(MULTI_GASES) + list(APPEND _ccppdata_defs_private MULTI_GASES) +endif() + +add_library( + ccppdata + + CCPP_typedefs.F90 + GFS_typedefs.F90 + CCPP_data.F90 +) + +target_link_libraries(ccppdata ccpp) +target_link_libraries(ccppdata ccppphys) + +target_include_directories(ccppdata PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src + ${CMAKE_BINARY_DIR}/FV3/ccpp/physics) + +set_target_properties(ccppdata PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod) +target_compile_definitions(ccppdata PRIVATE "${_ccppdata_defs_private}") +target_include_directories(ccppdata PUBLIC $) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 similarity index 94% rename from gfsphysics/GFS_layer/GFS_typedefs.F90 rename to ccpp/data/GFS_typedefs.F90 index 8868ae0b8..f91fdc06f 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -3,7 +3,6 @@ module GFS_typedefs use machine, only: kind_phys -#ifdef CCPP use physcons, only: con_cp, con_fvirt, con_g, & con_hvap, con_hfus, con_pi, con_rd, con_rv, & con_t0c, con_cvap, con_cliq, con_eps, con_epsq, & @@ -14,23 +13,16 @@ module GFS_typedefs use module_radsw_parameters, only: topfsw_type, sfcfsw_type, profsw_type, cmpfsw_type, NBDSW use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type, NBDLW + use ozne_def, only: levozp, oz_coeff + use h2o_def, only: levh2o, h2o_coeff use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl,ty_optical_props_2str use mo_cloud_optics, only: ty_cloud_optics use mo_gas_concentrations, only: ty_gas_concs use mo_source_functions, only: ty_source_func_lw -#else - use physcons, only: rhowater, con_p0 - 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 aerclm_def, only: ntrcaer, ntrcaerm -#endif implicit none -#ifdef CCPP ! To ensure that these values match what's in the physics, ! array sizes are compared during model init in GFS_rrtmg_setup_init() private :: NF_AESW, NF_AELW, NSPC, NSPC1, NF_CLDS, NF_VGAS, NF_ALBD, ntrcaerm @@ -48,11 +40,11 @@ module GFS_typedefs ! from aerclm_def integer, parameter :: ntrcaerm = 15 - ! These will be set later in GFS_Control%initialize, - ! since they depend on the runtime config (e.g. Model%ntoz, Model%h2o_phys, Model%aero_in) - private :: levozp, oz_coeff, levh2o, h2o_coeff, ntrcaer - integer :: levozp, oz_coeff, levh2o, h2o_coeff, ntrcaer -#endif + ! This will be set later in GFS_Control%initialize, since + ! it depends on the runtime config (Model%aero_in) + private :: ntrcaer + integer :: ntrcaer + ! If these are changed to >99, need to adjust formatting string in GFS_diagnostics.F90 (and names in diag_tables) integer, parameter :: naux2dmax = 20 !< maximum number of auxiliary 2d arrays in output (for debugging) integer, parameter :: naux3dmax = 20 !< maximum number of auxiliary 3d arrays in output (for debugging) @@ -74,7 +66,7 @@ module GFS_typedefs 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 -#ifdef CCPP + ! optional extra top layer on top of low ceiling models ! this parameter was originally defined in the radiation driver ! (and is still for standard non-CCPP builds), but is required @@ -83,7 +75,6 @@ module GFS_typedefs ! LTP=0: no extra top layer integer, parameter :: LTP = 0 ! no extra top layer !integer, parameter :: LTP = 1 ! add an extra top layer -#endif !---------------- ! Data Containers @@ -96,16 +87,14 @@ module GFS_typedefs ! 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_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_cldprop_type !< cloud fields needed by radiation from physics ! GFS_radtend_type !< radiation tendencies needed in physics ! GFS_diag_type !< fields targetted for diagnostic output -#ifdef CCPP ! GFS_interstitial_type !< fields required to replace interstitial code in GFS_{physics,radiation}_driver.F90 in CCPP ! GFS_data_type !< combined type of all of the above except GFS_control_type and GFS_interstitial_type -#endif !-------------------------------------------------------------------------------- ! GFS_init_type @@ -138,12 +127,10 @@ module GFS_typedefs 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 -#ifdef CCPP !--- restart information logical :: restart !< flag whether this is a coldstart (.false.) or a warmstart/restart (.true.) !--- hydrostatic/non-hydrostatic flag logical :: hydrostatic !< flag whether this is a hydrostatic or non-hydrostatic run -#endif !--- blocking data integer, pointer :: blksz(:) !< for explicit data blocking !< default blksz(1)=[nx*ny] @@ -172,7 +159,7 @@ module GFS_typedefs !! type GFS_statein_type -!--- level geopotential and pressures +!--- 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 @@ -195,7 +182,7 @@ module GFS_typedefs 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 - + contains procedure :: create => statein_create !< allocate array data end type GFS_statein_type @@ -235,7 +222,7 @@ module GFS_typedefs 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 :: lakedepth(:) => null() !< lake depth [ m ] + real (kind=kind_phys), pointer :: lakedepth(:) => null() !< lake depth [ m ] real (kind=kind_phys), pointer :: tsfc (:) => null() !< surface air temperature in K !< [tsea in gbphys.f] real (kind=kind_phys), pointer :: tsfco (:) => null() !< sst in K @@ -274,16 +261,14 @@ module GFS_typedefs 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 (:) => null() !< orography real (kind=kind_phys), pointer :: oro_uf (:) => null() !< unfiltered orography real (kind=kind_phys), pointer :: evap (:) => null() !< real (kind=kind_phys), pointer :: hflx (:) => null() !< real (kind=kind_phys), pointer :: qss (:) => null() !< !-- In/Out -#ifdef CCPP - real (kind=kind_phys), pointer :: conv_act(:) => null() !< convective activity counter hli 09/2017 -#endif + real (kind=kind_phys), pointer :: conv_act(:) => null() !< convective activity counter for Grell-Freitas 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 @@ -299,9 +284,7 @@ module GFS_typedefs !--- Out real (kind=kind_phys), pointer :: t2m (:) => null() !< 2 meter temperature -#ifdef CCPP real (kind=kind_phys), pointer :: th2m (:) => null() !< 2 meter potential temperature -#endif real (kind=kind_phys), pointer :: q2m (:) => null() !< 2 meter humidity ! -- In/Out for Noah MP @@ -364,7 +347,6 @@ module GFS_typedefs 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) -#ifdef CCPP ! Soil properties for RUC LSM (number of levels different from NOAH 4-layer model) real (kind=kind_phys), pointer :: wetness(:) => null() !< normalized soil wetness for lsm real (kind=kind_phys), pointer :: sh2o(:,:) => null() !< volume fraction of unfrozen soil moisture for lsm @@ -393,7 +375,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: chs2(:) => null() !exch coeff for heat at 2m real (kind=kind_phys), pointer :: cqs2(:) => null() !exch coeff for moisture at 2m real (kind=kind_phys), pointer :: lh(:) => null() !latent heating at the surface -#endif !---- precipitation amounts from previous time step for RUC LSM/NoahMP LSM real (kind=kind_phys), pointer :: raincprv (:) => null() !< explicit rainfall from previous timestep @@ -424,7 +405,7 @@ module GFS_typedefs 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 :: 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) @@ -440,7 +421,8 @@ module GFS_typedefs !< 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 - + real (kind=kind_phys), pointer :: sfculw(:) => null() !< total sky sfc upward lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: sfculw_jac(:) => null() !< Jacobian of total sky sfc upward lw flux ( w/m**2/K ) !--- 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) @@ -460,7 +442,7 @@ module GFS_typedefs !--- outgoing accumulated quantities real (kind=kind_phys), pointer :: rain_cpl (:) => null() !< total rain precipitation real (kind=kind_phys), pointer :: rainc_cpl (:) => null() !< convective rain precipitation - real (kind=kind_phys), pointer :: snow_cpl (:) => null() !< total snow 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 @@ -509,7 +491,7 @@ module GFS_typedefs !--- cellular automata real (kind=kind_phys), pointer :: ca1 (:) => null() ! real (kind=kind_phys), pointer :: ca2 (:) => null() ! - real (kind=kind_phys), pointer :: ca3 (:) => null() ! + real (kind=kind_phys), pointer :: ca3 (:) => 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() ! @@ -543,7 +525,7 @@ module GFS_typedefs !---------------------------------------------------------------------------------- ! 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 +! list of those that can be modified during the run are at the bottom of the list !---------------------------------------------------------------------------------- !! \section arg_table_GFS_control_type !! \htmlinclude GFS_control_type.html @@ -552,19 +534,15 @@ module GFS_typedefs integer :: me !< MPI rank designator integer :: master !< MPI rank of master atmosphere processor -#ifdef CCPP integer :: communicator !< MPI communicator integer :: ntasks !< MPI size in communicator integer :: nthreads !< OpenMP threads available for physics -#endif integer :: nlunit !< unit for namelist character(len=64) :: fn_nml !< namelist filename for surface data cycling character(len=256), pointer :: input_nml_file(:) !< character string containing full namelist - !< for use with internal file reads -#ifdef CCPP - integer :: input_nml_file_length + !< for use with internal file reads + integer :: input_nml_file_length !< length (number of lines) in namelist for internal reads integer :: logunit -#endif real(kind=kind_phys) :: fhzero !< hours between clearing of diagnostic buckets logical :: ldiag3d !< flag for 3d diagnostic fields logical :: qdiag3d !< flag for 3d tracer diagnostic fields @@ -589,13 +567,11 @@ module GFS_typedefs 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 - !--- 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) -#ifdef CCPP + !--- 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) integer :: levsp1 !< number of vertical levels plus one integer :: levsm1 !< number of vertical levels minus one -#endif 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 @@ -603,9 +579,7 @@ module GFS_typedefs integer :: tile_num integer :: nblks !< for explicit data blocking: number of blocks integer, pointer :: blksz(:) !< for explicit data blocking: block sizes of all blocks -#ifdef CCPP integer :: ncols !< total number of columns for all blocks -#endif !--- coupling parameters logical :: cplflx !< default no cplflx collection @@ -638,18 +612,12 @@ module GFS_typedefs real(kind=kind_phys) :: fhlwr !< frequency for longwave radiation (secs) integer :: nsswr !< integer trigger for shortwave radiation integer :: nslwr !< integer trigger for longwave radiation -#ifdef CCPP integer :: nhfrad !< number of timesteps for which to call radiation on physics timestep (coldstarts) -#endif integer :: levr !< number of vertical levels for radiation calculations -#ifdef CCPP integer :: levrp1 !< number of vertical levels for radiation calculations plus one -#endif integer :: nfxr !< second dimension for fluxr diagnostic variable (radiation) logical :: iaerclm !< flag for initializing aerosol data -#ifdef CCPP integer :: ntrcaer !< number of aerosol tracers for Morrison-Gettelman microphysics -#endif logical :: lmfshal !< parameter for radiation logical :: lmfdeep2 !< parameter for radiation integer :: nrcm !< second dimension of random number stream for RAS @@ -663,7 +631,7 @@ module GFS_typedefs integer :: icliq_sw !< sw optical property for liquid clouds integer :: icice_sw !< sw optical property for ice clouds integer :: icliq_lw !< lw optical property for liquid clouds - integer :: icice_lw !< lw optical property for ice clouds + integer :: icice_lw !< lw optical property for ice clouds integer :: iovr !< max-random overlap clouds for sw & lw (maximum of both) integer :: ictm !< ictm=0 => use data at initial cond time, if not !< available; use latest; no extrapolation. @@ -671,7 +639,7 @@ module GFS_typedefs !< 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, + !< 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. @@ -682,17 +650,17 @@ module GFS_typedefs !< =1 => sub-grid cloud with prescribed seeds !< =2 => sub-grid cloud with randomly generated !< seeds - integer :: idcor !< Decorrelation length type for overlap assumption - !< =0 => Use constant decorrelation length, decorr_con - !< =1 => Use spatially varying decorrelation length (Hogan et al. 2010) - !< =2 => Use spatially and temporally varyint decorrelation length (Oreopoulos et al. 2012) - real(kind_phys) :: dcorr_con !< Decorrelation length constant (km) (if idcor = 0) + integer :: idcor !< Decorrelation length type for overlap assumption + !< =0 => Use constant decorrelation length, decorr_con + !< =1 => Use spatially varying decorrelation length (Hogan et al. 2010) + !< =2 => Use spatially and temporally varyint decorrelation length (Oreopoulos et al. 2012) + real(kind_phys) :: dcorr_con !< Decorrelation length constant (km) (if idcor = 0) logical :: crick_proof !< CRICK-Proof cloud water - logical :: ccnorm !< Cloud condensate normalized by cloud cover + 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) -#ifdef CCPP + ! RRTMGP logical :: do_RRTMGP !< Use RRTMGP character(len=128) :: active_gases !< Character list of active gases used in RRTMGP @@ -706,17 +674,18 @@ module GFS_typedefs character(len=128) :: sw_file_clouds !< RRTMGP file containing coefficients used to compute clouds optical properties integer :: rrtmgp_nBandsSW !< Number of RRTMGP SW bands. integer :: rrtmgp_nGptsSW !< Number of RRTMGP SW spectral points. - logical :: doG_cldoptics !< Use legacy RRTMG cloud-optics? - logical :: doGP_cldoptics_PADE !< Use RRTMGP cloud-optics: PADE approximation? - logical :: doGP_cldoptics_LUT !< Use RRTMGP cloud-optics: LUTs? + logical :: doG_cldoptics !< Use legacy RRTMG cloud-optics? + logical :: doGP_cldoptics_PADE !< Use RRTMGP cloud-optics: PADE approximation? + logical :: doGP_cldoptics_LUT !< Use RRTMGP cloud-optics: LUTs? integer :: rrtmgp_nrghice !< Number of ice-roughness categories integer :: rrtmgp_nGauss_ang !< Number of angles used in Gaussian quadrature logical :: do_GPsw_Glw !< If set to true use rrtmgp for SW calculation, rrtmg for LW. character(len=128) :: active_gases_array(100) !< character array for each trace gas name logical :: use_LW_jacobian !< If true, use Jacobian of LW to update radiation tendency. -#endif + logical :: doGP_lwscat !< If true, include scattering in longwave cloud-optics, only compatible w/ GP cloud-optics + !--- microphysical switch - integer :: ncld !< choice of cloud scheme + integer :: ncld !< choice of cloud scheme !--- new microphysical switch integer :: imp_physics !< choice of microphysics scheme integer :: imp_physics_gfdl = 11 !< choice of GFDL microphysics scheme @@ -745,7 +714,7 @@ module GFS_typedefs integer :: fprcp !< no prognostic rain and snow (MG) integer :: pdfflag !< pdf flag for MG macrophysics real(kind=kind_phys) :: mg_dcs !< Morrison-Gettelman microphysics parameters - real(kind=kind_phys) :: mg_qcvar + real(kind=kind_phys) :: mg_qcvar real(kind=kind_phys) :: mg_ts_auto_ice(2) !< ice auto conversion time scale real(kind=kind_phys) :: mg_rhmini !< relative humidity threshold parameter for nucleating ice @@ -786,7 +755,7 @@ module GFS_typedefs real(kind=kind_phys) :: ttendlim !< temperature tendency limiter per time step in K/s !--- GFDL microphysical paramters - logical :: lgfdlmprad !< flag for GFDL mp scheme and radiation consistency + logical :: lgfdlmprad !< flag for GFDL mp scheme and radiation consistency !--- Thompson,GFDL mp parameter logical :: lrefres !< flag for radar reflectivity in restart file @@ -798,7 +767,7 @@ module GFS_typedefs integer :: lsm_ruc=3 !< flag for RUC land surface model integer :: lsm_noah_wrfv4 = 4 !< flag for NOAH land surface from WRF v4.0 integer :: lsoil !< number of soil layers - integer :: ivegsrc !< ivegsrc = 0 => USGS, + integer :: ivegsrc !< ivegsrc = 0 => USGS, !< ivegsrc = 1 => IGBP (20 category) !< ivegsrc = 2 => UMD (13 category) !< ivegsrc = 3 => NLCD40 (40 category, NOAH WRFv4 only) @@ -807,7 +776,7 @@ module GFS_typedefs integer :: isot !< isot = 0 => Zobler soil type ( 9 category) !< isot = 1 => STATSGO soil type (19 category, AKA 'STAS'(?)) !< isot = 2 => STAS-RUC soil type (19 category, NOAH WRFv4 only) -#ifdef CCPP + integer :: kice !< number of layers in sice integer :: lsoil_lsm !< number of soil layers internal to land surface model integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model integer :: lsnow_lsm_lbound!< lower bound for snow arrays, depending on lsnow_lsm @@ -825,12 +794,8 @@ module GFS_typedefs integer :: iopt_thcnd !< option to treat thermal conductivity in Noah LSM (new in 3.8) !< = 1, original (default) !< = 2, McCumber and Pielke for silt loam and sandy loam - integer :: kice !< number of layers in ice model -#else - integer :: kice=2 !< number of layers in sice -#endif - ! -- the Noah MP options + ! -- 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) @@ -846,14 +811,12 @@ module GFS_typedefs logical :: use_ufo !< flag for gcycle surface option -#ifdef CCPP ! GFDL Surface Layer options logical :: lcurr_sf !< flag for taking ocean currents into account in GFDL surface layer logical :: pert_cd !< flag for perturbing the surface drag coefficient for momentum in surface layer scheme (1 = True) integer :: ntsflg !< flag for updating skin temperature in the GFDL surface layer scheme real(kind=kind_phys) :: sfenth !< enthalpy flux factor 0 zot via charnock ..>0 zot enhanced>15m/s -#endif - + !--- flake model parameters integer :: lkm !< flag for flake model @@ -864,7 +827,6 @@ module GFS_typedefs logical :: trans_trac !< flag for convective transport of tracers (RAS, CS, or SAMF) logical :: old_monin !< flag for diff monin schemes logical :: cnvgwd !< flag for conv gravity wave drag -#ifdef CCPP integer :: gwd_opt !< gwd_opt = 1 => original GFS gwd (gwdps.f) !< gwd_opt = 2 => unified ugwp GWD !< gwd_opt = 22 => unified ugwp GWD with extra output @@ -872,22 +834,21 @@ module GFS_typedefs !< gwd_opt = 33 => GSL drag suite with extra output logical :: do_ugwp_v0 !< flag for version 0 ugwp GWD logical :: do_ugwp_v0_orog_only !< flag for version 0 ugwp GWD (orographic drag only) + logical :: do_ugwp_v0_nst_only !< flag for version 0 ugwp GWD (non-stationary GWD only) logical :: do_gsl_drag_ls_bl !< flag for GSL drag (large-scale GWD and blocking only) logical :: do_gsl_drag_ss !< flag for GSL drag (small-scale GWD only) logical :: do_gsl_drag_tofd !< flag for GSL drag (turbulent orog form drag only) logical :: do_ugwp_v1 !< flag for version 1 ugwp GWD logical :: do_ugwp_v1_orog_only !< flag for version 1 ugwp GWD (orographic drag only) -#endif + logical :: do_ugwp_v1_w_gsldrag !< flag for version 1 ugwp with OGWD of GSL 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 -#ifdef CCPP real(kind=kind_phys) :: rhgrd !< fer_hires microphysics only logical :: spec_adv !< flag for individual cloud species advected integer :: icloud !< cloud effect to the optical depth in radiation; this also controls the cloud fraction options !< 3: with cloud effect, and use cloud fraction option 3, based on Sundqvist et al. (1989) -#endif logical :: do_aw !< AW scale-aware option in cs convection logical :: do_awdd !< AW scale-aware option in cs convection logical :: flx_form !< AW scale-aware option in cs convection @@ -895,10 +856,8 @@ module GFS_typedefs logical :: shocaftcnv !< flag for SHOC logical :: shoc_cld !< flag for clouds logical :: uni_cld !< flag for clouds in grrad -#ifdef CCPP logical :: oz_phys !< flag for old (2006) ozone physics logical :: oz_phys_2015 !< flag for new (2015) ozone physics -#endif logical :: h2o_phys !< flag for stratosphere h2o logical :: pdfcld !< flag for pdfcld logical :: shcnvcw !< flag for shallow convective cloud @@ -909,12 +868,11 @@ module GFS_typedefs logical :: shinhong !< flag for scale-aware Shinhong vertical turbulent mixing scheme logical :: do_ysu !< flag for YSU turbulent mixing scheme logical :: dspheat !< flag for tke dissipative heating -#ifdef CCPP logical :: hurr_pbl !< flag for hurricane-specific options in PBL scheme -#endif logical :: lheatstrg !< flag for canopy heat storage parameterization - logical :: cnvcld + logical :: cnvcld logical :: random_clds !< flag controls whether clouds are random + logical :: shal_cnv !< flag for calling shallow convection logical :: do_deep !< whether to do deep convection integer :: imfshalcnv !< flag for mass-flux shallow convection scheme @@ -925,13 +883,11 @@ module GFS_typedefs !< 4: New Tiedtke scheme (CAPS) !< 0: modified Tiedtke's eddy-diffusion shallow conv scheme !< -1: no shallow convection used -#ifdef CCPP integer :: imfshalcnv_sas = 1 !< flag for SAS mass-flux shallow convection scheme integer :: imfshalcnv_samf = 2 !< flag for SAMF scale- & aerosol-aware mass-flux shallow convection scheme integer :: imfshalcnv_gf = 3 !< flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) integer :: imfshalcnv_ntiedtke = 4 !< flag for new Tiedtke scheme (CAPS) logical :: hwrf_samfdeep !< flag for HWRF SAMF deepcnv scheme (HWRF) -#endif integer :: imfdeepcnv !< flag for mass-flux deep convection scheme !< 1: July 2010 version of SAS conv scheme !< current operational version as of 2016 @@ -939,20 +895,17 @@ module GFS_typedefs !< 3: scale- & aerosol-aware Grell-Freitas scheme (GSD) !< 4: New Tiedtke scheme (CAPS) !< 0: old SAS Convection scheme before July 2010 -#ifdef CCPP integer :: imfdeepcnv_sas = 1 !< flag for SAS mass-flux deep convection scheme integer :: imfdeepcnv_samf = 2 !< flag for SAMF scale- & aerosol-aware mass-flux deep convection scheme integer :: imfdeepcnv_gf = 3 !< flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) integer :: imfdeepcnv_ntiedtke = 4 !< flag for new Tiedtke scheme (CAPS) logical :: hwrf_samfshal !< flag for HWRF SAMF shalcnv scheme (HWRF) -#endif integer :: isatmedmf !< flag for scale-aware TKE-based moist edmf scheme !< 0: initial version of satmedmf (Nov. 2018) !< 1: updated version of satmedmf (as of May 2019) -#ifdef CCPP integer :: isatmedmf_vdif = 0 !< flag for initial version of satmedmf (Nov. 2018) integer :: isatmedmf_vdifq = 1 !< flag for updated version of satmedmf (as of May 2019) -#endif + integer :: nmtvr !< number of topographic variables such as variance etc !< used in the GWD parameterization - 10 more added if !< GSL orographic drag scheme is used @@ -964,11 +917,11 @@ module GFS_typedefs !< workfunction for RAS real(kind=kind_phys) :: cdmbgwd(4) !< multiplication factors for cdmb, gwd and NS gwd, tke based enhancement 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 + 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 + real(kind=kind_phys) :: dlqf(2) !< factor for cloud condensate detrainment !< from cloud edges for RAS real(kind=kind_phys) :: psauras(2) !< [in] auto conversion coeff from ice to snow in ras real(kind=kind_phys) :: prauras(2) !< [in] auto conversion coeff from cloud to rain in ras @@ -977,7 +930,7 @@ module GFS_typedefs integer :: seed0 !< random seed for radiation real(kind=kind_phys) :: rbcr !< Critical Richardson Number in the PBL scheme -#ifdef CCPP + !--- MYNN parameters/switches logical :: do_mynnedmf logical :: do_mynnsfclay @@ -1002,7 +955,6 @@ module GFS_typedefs ! MYJ switches logical :: do_myjsfc !< flag for MYJ surface layer scheme logical :: do_myjpbl !< flag for MYJ PBL scheme -#endif !--- Rayleigh friction real(kind=kind_phys) :: prslrd0 !< pressure level from which Rayleigh Damping is applied @@ -1053,7 +1005,7 @@ module GFS_typedefs !< nstf_name(5) : zsea2 in mm !--- fractional grid logical :: frac_grid !< flag for fractional grid - logical :: ignore_lake !< flag for ignoring lakes + 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 @@ -1087,10 +1039,10 @@ module GFS_typedefs integer :: ncells !< cellular automata finer grid integer :: nca_g !< number of independent cellular automata integer :: nlives_g !< cellular automata lifetime - integer :: ncells_g !< cellular automata finer grid - real(kind=kind_phys) :: nfracseed !< cellular automata seed probability + integer :: ncells_g !< cellular automata finer grid + real(kind=kind_phys) :: nfracseed !< cellular automata seed probability integer :: nseed !< cellular automata seed frequency - integer :: nseed_g !< cellular automata seed frequency + integer :: nseed_g !< 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 @@ -1115,18 +1067,16 @@ module GFS_typedefs logical :: lndp_each_step ! flag to indicate that land perturbations are applied at every time step, ! otherwise they are applied only after gcycle is run character(len=3) :: lndp_var_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def - real(kind=kind_phys) :: lndp_prt_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def - ! also previous code had dimension 5 for each pert, to allow - ! multiple patterns. It wasn't fully coded (and wouldn't have worked - ! with nlndp>1, so I just dropped it). If we want to code it properly, + real(kind=kind_phys) :: lndp_prt_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def + ! also previous code had dimension 5 for each pert, to allow + ! multiple patterns. It wasn't fully coded (and wouldn't have worked + ! with nlndp>1, so I just dropped it). If we want to code it properly, ! we'd need to make this dim(6,5). !--- tracer handling character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core integer :: ntrac !< number of tracers -#ifdef CCPP integer :: ntracp1 !< number of tracers plus one integer :: nqrimef !< tracer index for mass weighted rime factor -#endif integer :: ntqv !< tracer index for water vapor (specific humidity) integer :: ntoz !< tracer index for ozone mixing ratio integer :: ntcw !< tracer index for cloud condensate (or liquid water) @@ -1168,7 +1118,6 @@ module GFS_typedefs integer :: nreffr !< the index of rain effective radius in phy_f3d integer :: nseffr !< the index of snow effective radius in phy_f3d integer :: ngeffr !< the index of graupel effective radius in phy_f3d -#ifdef CCPP integer :: nkbfshoc !< the index of upward kinematic buoyancy flux from SHOC in phy_f3d integer :: nahdshoc !< the index of diffusivity for heat from from SHOC in phy_f3d integer :: nscfshoc !< the index of subgrid-scale cloud fraction from from SHOC in phy_f3d @@ -1178,10 +1127,10 @@ module GFS_typedefs integer :: nqvdelt !< the index of specific humidity at the previous timestep for Z-C MP in phy_f3d integer :: nps2delt !< the index of surface air pressure 2 timesteps back for Z-C MP in phy_f2d integer :: npsdelt !< the index of surface air pressure at the previous timestep for Z-C MP in phy_f2d -#endif + integer :: ncnvwind !< the index of surface wind enhancement due to convection for MYNN SFC and RAS CNV in phy f2d !--- debug flag - logical :: debug + logical :: debug logical :: pre_rad !< flag for testing purpose !--- variables modified at each time step @@ -1194,17 +1143,15 @@ module GFS_typedefs 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) + 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 !< current forecast hour real(kind=kind_phys) :: zhour !< previous hour diagnostic buckets emptied integer :: kdt !< current forecast iteration -#ifdef CCPP logical :: first_time_step !< flag signaling first time step for time integration routine logical :: restart !< flag whether this is a coldstart (.false.) or a warmstart/restart (.true.) logical :: hydrostatic !< flag whether this is a hydrostatic or non-hydrostatic run -#endif integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) integer :: imn !< initial forecast month @@ -1213,9 +1160,7 @@ module GFS_typedefs ! integer :: iccn !< using IN CCN forcing for MG2/3 real(kind=kind_phys), pointer :: si(:) !< vertical sigma coordinate for model initialization -#ifdef CCPP real(kind=kind_phys) :: sec !< seconds since model initialization -#endif !--- IAU integer :: iau_offset @@ -1224,13 +1169,11 @@ module GFS_typedefs real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files logical :: iau_filter_increments, iau_drymassfixer -#ifdef CCPP ! From physcons.F90, updated/set in control_initialize real(kind=kind_phys) :: dxinv ! inverse scaling factor for critical relative humidity, replaces dxinv in physcons.F90 real(kind=kind_phys) :: dxmax ! maximum scaling factor for critical relative humidity, replaces dxmax in physcons.F90 real(kind=kind_phys) :: dxmin ! minimum scaling factor for critical relative humidity, replaces dxmin in physcons.F90 real(kind=kind_phys) :: rhcmax ! maximum critical relative humidity, replaces rhc_max in physcons.F90 -#endif contains procedure :: init => control_initialize @@ -1246,11 +1189,11 @@ module GFS_typedefs !! \htmlinclude GFS_grid_type.html !! 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 + !! -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 :: xlon_d (:) => null() !< grid longitude in degrees, default to 0 -> @@ -1285,6 +1228,13 @@ module GFS_typedefs real (kind=kind_phys), pointer :: ddx_aer (:) => null() !< interpolation weight for iaerclm integer, pointer :: iindx1_aer (:) => null() !< interpolation low index for iaerclm integer, pointer :: iindx2_aer (:) => null() !< interpolation high index for iaerclm + +!--- grid-related interpolation data for cires_ugwp_v1 + real (kind=kind_phys), pointer :: ddy_j1tau (:) => null() !< interpolation weight for tau_ugwp + real (kind=kind_phys), pointer :: ddy_j2tau (:) => null() !< interpolation weight for tau_ugwp + integer, pointer :: jindx1_tau (:) => null() !< interpolation low index for tau_ugwp + integer, pointer :: jindx2_tau (:) => null() !< interpolation high index for tau_ugwp + contains procedure :: create => grid_create !< allocate array data end type GFS_grid_type @@ -1311,12 +1261,12 @@ module GFS_typedefs real (kind=kind_phys), pointer :: in_nm (:,:) => null() !< IN number concentration real (kind=kind_phys), pointer :: ccn_nm (:,:) => null() !< CCN number concentration real (kind=kind_phys), pointer :: aer_nm (:,:,:) => null() !< GOCART aerosol climo + real (kind=kind_phys), pointer :: tau_amf (: ) => null() !< nonsta-gw monthly data - !--- active when ((.not. newsas .or. cal_pre) .and. random_clds) -#ifdef CCPP integer, pointer :: imap (:) => null() !< map of local index ix to global index i for this block integer, pointer :: jmap (:) => null() !< map of local index ix to global index j for this block -#endif + + !--- active when ((.not. newsas .or. cal_pre) .and. random_clds) real (kind=kind_phys), pointer :: rann (:,:) => null() !< random number array (0-1) !--- In/Out @@ -1339,12 +1289,6 @@ module GFS_typedefs !--- Diagnostic that needs to be carried over to the next time step (removed from diag_type) real (kind=kind_phys), pointer :: hpbl (:) => null() !< Planetary boundary layer height -#ifndef CCPP -!--- for explicit data blocking - integer :: blkno !< block number of this block -#endif - -#ifdef CCPP !--- dynamical forcing variables for Grell-Freitas convection real (kind=kind_phys), pointer :: forcet (:,:) => null() !< real (kind=kind_phys), pointer :: forceq (:,:) => null() !< @@ -1364,19 +1308,18 @@ module GFS_typedefs real (kind=kind_phys), pointer :: cov (:,:) => null() ! !--- MYJ schemes saved variables (from previous time step) - real (kind=kind_phys), pointer :: phy_myj_qsfc(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_thz0(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_qz0(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_uz0(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_vz0(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_akhs(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_akms(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_chkqlm(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_elflx(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_a1u(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_a1t(:) => null() ! - real (kind=kind_phys), pointer :: phy_myj_a1q(:) => null() ! -#endif + real (kind=kind_phys), pointer :: phy_myj_qsfc(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_thz0(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_qz0(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_uz0(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_vz0(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_akhs(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_akms(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_chkqlm(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_elflx(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_a1u(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_a1t(:) => null() ! + real (kind=kind_phys), pointer :: phy_myj_a1q(:) => null() ! contains procedure :: create => tbd_create !< allocate array data @@ -1385,7 +1328,7 @@ module GFS_typedefs !------------------------------------------------------------------ ! GFS_cldprop_type -! cloud properties and tendencies needed by radiation from physics +! cloud properties and tendencies needed by radiation from physics !------------------------------------------------------------------ !! \section arg_table_GFS_cldprop_type !! \htmlinclude GFS_cldprop_type.html @@ -1434,7 +1377,7 @@ module GFS_typedefs 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 :: 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) @@ -1451,7 +1394,7 @@ module GFS_typedefs !---------------------------------------------------------------- ! GFS_diag_type -! internal diagnostic type used as arguments to gbphys and grrad +! internal diagnostic type used as arguments to gbphys and grrad !---------------------------------------------------------------- !! \section arg_table_GFS_diag_type !! \htmlinclude GFS_diag_type.html @@ -1518,7 +1461,6 @@ module GFS_typedefs 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) -#ifdef CCPP !--- MYNN variables real (kind=kind_phys), pointer :: edmf_a (:,:) => null() ! real (kind=kind_phys), pointer :: edmf_w (:,:) => null() ! @@ -1536,25 +1478,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: exch_h (:,:) => null() ! real (kind=kind_phys), pointer :: exch_m (:,:) => null() ! - !--- Drag Suite variables - real (kind=kind_phys), pointer :: dtaux2d_ls (:,:) => null() ! - real (kind=kind_phys), pointer :: dtauy2d_ls (:,:) => null() ! - real (kind=kind_phys), pointer :: dtaux2d_bl (:,:) => null() ! - real (kind=kind_phys), pointer :: dtauy2d_bl (:,:) => null() ! - real (kind=kind_phys), pointer :: dtaux2d_ss (:,:) => null() ! - real (kind=kind_phys), pointer :: dtauy2d_ss (:,:) => null() ! - real (kind=kind_phys), pointer :: dtaux2d_fd (:,:) => null() ! - real (kind=kind_phys), pointer :: dtauy2d_fd (:,:) => null() ! - real (kind=kind_phys), pointer :: dusfc_ls (:) => null() ! - real (kind=kind_phys), pointer :: dvsfc_ls (:) => null() ! - real (kind=kind_phys), pointer :: dusfc_bl (:) => null() ! - real (kind=kind_phys), pointer :: dvsfc_bl (:) => null() ! - real (kind=kind_phys), pointer :: dusfc_ss (:) => null() ! - real (kind=kind_phys), pointer :: dvsfc_ss (:) => null() ! - real (kind=kind_phys), pointer :: dusfc_fd (:) => null() ! - real (kind=kind_phys), pointer :: dvsfc_fd (:) => null() ! -#endif - ! Output - only in physics real (kind=kind_phys), pointer :: u10m (:) => null() !< 10 meter u/v wind speed real (kind=kind_phys), pointer :: v10m (:) => null() !< 10 meter u/v wind speed @@ -1571,9 +1494,7 @@ module GFS_typedefs 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 ) -#ifdef CCPP real (kind=kind_phys), pointer :: nswsfci(:) => null() !< instantaneous sfc net dnwd sw flux ( w/m**2 ) -#endif 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 @@ -1590,9 +1511,9 @@ module GFS_typedefs real (kind=kind_phys), pointer :: tdomip (:) => null() !< dominant accumulated sleet type real (kind=kind_phys), pointer :: tdoms (:) => null() !< dominant accumulated snow type - real (kind=kind_phys), pointer :: ca1 (:) => null() ! + real (kind=kind_phys), pointer :: ca1 (:) => null() ! real (kind=kind_phys), pointer :: ca2 (:) => null() ! - real (kind=kind_phys), pointer :: ca3 (:) => null() ! + real (kind=kind_phys), pointer :: ca3 (:) => null() ! 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 @@ -1619,13 +1540,36 @@ module GFS_typedefs 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 !--- F-A MP scheme -#ifdef CCPP - real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1) -#endif - real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction - !--- MP quantities for 3D diagnositics + real (kind=kind_phys), pointer :: train (:,:) => null() !< accumulated stratiform T tendency (K s-1) + real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction + !--- MP quantities for 3D diagnositics real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm - +! +!---vay-2018 UGWP-diagnostics instantaneous +! +! OGWs +NGWs + real (kind=kind_phys), pointer :: dudt_gw(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_gw(:,:) => null() !< + real (kind=kind_phys), pointer :: dtdt_gw(:,:) => null() !< + real (kind=kind_phys), pointer :: kdis_gw(:,:) => null() !< +!oro-GWs + real (kind=kind_phys), pointer :: dudt_ogw(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_ogw(:,:) => null() !< + real (kind=kind_phys), pointer :: dudt_obl(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_obl(:,:) => null() !< + real (kind=kind_phys), pointer :: dudt_oss(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_oss(:,:) => null() !< + real (kind=kind_phys), pointer :: dudt_ofd(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_ofd(:,:) => null() !< + + real (kind=kind_phys), pointer :: du_ogwcol(:) => null() !< + real (kind=kind_phys), pointer :: dv_ogwcol(:) => null() !< + real (kind=kind_phys), pointer :: du_oblcol(:) => null() !< + real (kind=kind_phys), pointer :: dv_oblcol(:) => null() !< + real (kind=kind_phys), pointer :: du_osscol(:) => null() !< + real (kind=kind_phys), pointer :: dv_osscol(:) => null() !< + real (kind=kind_phys), pointer :: du_ofdcol(:) => null() !< + real (kind=kind_phys), pointer :: dv_ofdcol(:) => null() !< ! !---vay-2018 UGWP-diagnostics daily mean ! @@ -1670,15 +1614,15 @@ module GFS_typedefs real (kind=kind_phys), pointer :: gwp_scheat(:,:) => null() ! instant shal-conv heat tendency real (kind=kind_phys), pointer :: gwp_dcheat(:,:) => null() ! instant deep-conv heat tendency - real (kind=kind_phys), pointer :: gwp_precip(:) => null() ! total precip rates - integer , pointer :: gwp_klevs(:,:)=> null() ! instant levels for GW-launches - real (kind=kind_phys), pointer :: gwp_fgf(:) => null() ! fgf triggers - real (kind=kind_phys), pointer :: gwp_okw(:) => null() ! okw triggers - - real (kind=kind_phys), pointer :: gwp_ax(:,:) => null() ! instant total UGWP tend m/s/s EW - real (kind=kind_phys), pointer :: gwp_ay(:,:) => null() ! instant total UGWP tend m/s/s NS - real (kind=kind_phys), pointer :: gwp_dtdt(:,:) => null() ! instant total heat tend K/s - real (kind=kind_phys), pointer :: gwp_kdis(:,:) => null() ! instant total eddy mixing m2/s + real (kind=kind_phys), pointer :: gwp_precip(:) => null() ! total precip rates + integer , pointer :: gwp_klevs(:,:) => null() ! instant levels for GW-launches + real (kind=kind_phys), pointer :: gwp_fgf(:) => null() ! fgf triggers + real (kind=kind_phys), pointer :: gwp_okw(:) => null() ! okw triggers + + real (kind=kind_phys), pointer :: gwp_ax(:,:) => null() ! instant total UGWP tend m/s/s EW + real (kind=kind_phys), pointer :: gwp_ay(:,:) => null() ! instant total UGWP tend m/s/s NS + real (kind=kind_phys), pointer :: gwp_dtdt(:,:) => null() ! instant total heat tend K/s + real (kind=kind_phys), pointer :: gwp_kdis(:,:) => null() ! instant total eddy mixing m2/s real (kind=kind_phys), pointer :: gwp_axc(:,:) => null() ! instant con-UGWP tend m/s/s EW real (kind=kind_phys), pointer :: gwp_ayc(:,:) => null() ! instant con-UGWP tend m/s/s NS real (kind=kind_phys), pointer :: gwp_axo(:,:) => null() ! instant oro-UGWP tend m/s/s EW @@ -1686,26 +1630,24 @@ module GFS_typedefs real (kind=kind_phys), pointer :: gwp_axf(:,:) => null() ! instant jet-UGWP tend m/s/s EW real (kind=kind_phys), pointer :: gwp_ayf(:,:) => null() ! instant jet-UGWP tend m/s/s NS - real (kind=kind_phys), pointer :: uav_ugwp(:,:) => null() ! aver wind UAV from physics - real (kind=kind_phys), pointer :: tav_ugwp(:,:) => null() ! aver temp UAV from physics - real (kind=kind_phys), pointer :: du3dt_dyn(:,:) => null() ! U Tend-dynamics "In"-"PhysOut" + real (kind=kind_phys), pointer :: uav_ugwp(:,:) => null() ! aver wind UAV from physics + real (kind=kind_phys), pointer :: tav_ugwp(:,:) => null() ! aver temp UAV from physics + real (kind=kind_phys), pointer :: du3dt_dyn(:,:) => null() ! U Tend-dynamics "In"-"PhysOut" !--- COODRE ORO diagnostics - real (kind=kind_phys), pointer :: zmtb(:) => null() ! - real (kind=kind_phys), pointer :: zogw(:) => null() ! - real (kind=kind_phys), pointer :: zlwb(:) => null() !! - real (kind=kind_phys), pointer :: tau_ogw(:) => null() !! - real (kind=kind_phys), pointer :: tau_ngw(:) => null() !! - real (kind=kind_phys), pointer :: tau_mtb(:) => null() ! - real (kind=kind_phys), pointer :: tau_tofd(:) => null() ! + real (kind=kind_phys), pointer :: zmtb(:) => null() ! + real (kind=kind_phys), pointer :: zogw(:) => null() ! + real (kind=kind_phys), pointer :: zlwb(:) => null() ! + real (kind=kind_phys), pointer :: tau_ogw(:) => null() ! + real (kind=kind_phys), pointer :: tau_ngw(:) => null() ! + real (kind=kind_phys), pointer :: tau_mtb(:) => null() ! + real (kind=kind_phys), pointer :: tau_tofd(:) => null() ! !---vay-2018 UGWP-diagnostics !--- Output diagnostics for coupled chemistry -#ifdef CCPP integer :: ndust !< number of dust bins for diagnostics integer :: nseasalt !< number of seasalt bins for diagnostics integer :: ntchmdiag !< number of chemical tracers for diagnostics -#endif real (kind=kind_phys), pointer :: duem (:,:) => null() !< instantaneous dust emission flux ( kg/m**2/s ) real (kind=kind_phys), pointer :: ssem (:,:) => null() !< instantaneous sea salt emission flux ( kg/m**2/s ) real (kind=kind_phys), pointer :: sedim (:,:) => null() !< instantaneous sedimentation ( kg/m**2/s ) @@ -1728,7 +1670,6 @@ module GFS_typedefs procedure :: chem_init => diag_chem_init end type GFS_diag_type -#ifdef CCPP !--------------------------------------------------------------------- ! GFS_interstitial_type ! fields required for interstitial code in CCPP schemes, previously @@ -1867,8 +1808,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: graupelmp(:) => null() !< real (kind=kind_phys), pointer :: gwdcu(:,:) => null() !< real (kind=kind_phys), pointer :: gwdcv(:,:) => null() !< - integer :: h2o_coeff !< - real (kind=kind_phys), pointer :: h2o_pres(:) => null() !< real (kind=kind_phys), pointer :: hefac(:) => null() !< real (kind=kind_phys), pointer :: hffac(:) => null() !< real (kind=kind_phys), pointer :: hflxq(:) => null() !< @@ -1902,8 +1841,6 @@ module GFS_typedefs integer, pointer :: ktop(:) => null() !< integer :: latidxprnt !< integer :: levi !< - integer :: levh2o !< - integer :: levozp !< integer :: lmk !< integer :: lmp !< integer, pointer :: mbota(:,:) => null() !< @@ -1933,9 +1870,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: oc(:) => null() !< real (kind=kind_phys), pointer :: olyr(:,:) => null() !< logical , pointer :: otspt(:,:) => null() !< - integer :: oz_coeff !< integer :: oz_coeffp5 !< - real (kind=kind_phys), pointer :: oz_pres(:) => null() !< logical :: phys_hydrostatic !< real (kind=kind_phys), pointer :: plvl(:,:) => null() !< real (kind=kind_phys), pointer :: plyr(:,:) => null() !< @@ -2042,7 +1977,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: vdftra(:,:,:) => null() !< real (kind=kind_phys), pointer :: vegf1d(:) => null() !< real (kind=kind_phys) :: lndp_vgf !< - + integer, pointer :: vegtype(:) => null() !< real (kind=kind_phys), pointer :: w_upi(:,:) => null() !< real (kind=kind_phys), pointer :: wcbmax(:) => null() !< @@ -2062,26 +1997,33 @@ module GFS_typedefs real (kind=kind_phys), pointer :: zorl_land(:) => null() !< real (kind=kind_phys), pointer :: zorl_ocean(:) => null() !< real (kind=kind_phys), pointer :: zt1d(:) => null() !< - real (kind=kind_phys), pointer :: gw_dudt(:,:) => null() !< - real (kind=kind_phys), pointer :: gw_dvdt(:,:) => null() !< - real (kind=kind_phys), pointer :: gw_dtdt(:,:) => null() !< - real (kind=kind_phys), pointer :: gw_kdis(:,:) => null() !< +!================================================================================================== +! UGWP - five mechnanisms of momentum deposition due to various types of GWs +! (oss, ofd, obl, ogw) + ngw = sum( sso + ngw) +!================================================================================================== +! nGWs + real (kind=kind_phys), pointer :: dudt_ngw(:,:) => null() !< + real (kind=kind_phys), pointer :: dvdt_ngw(:,:) => null() !< + real (kind=kind_phys), pointer :: dtdt_ngw(:,:) => null() !< + real (kind=kind_phys), pointer :: kdis_ngw(:,:) => null() !< + + real (kind=kind_phys), pointer :: tau_oss(: ) => null() !< instantaneous momentum flux due to OSS real (kind=kind_phys), pointer :: tau_tofd(:) => null() !< instantaneous momentum flux due to TOFD - real (kind=kind_phys), pointer :: tau_mtb(:) => null() !< instantaneous momentum flux due to mountain blocking drag - real (kind=kind_phys), pointer :: tau_ogw(:) => null() !< instantaneous momentum flux due to orographic gravity wave drag - real (kind=kind_phys), pointer :: tau_ngw(:) => null() !< instantaneous momentum flux due to nonstationary gravity waves + real (kind=kind_phys), pointer :: tau_mtb(:) => null() !< instantaneous momentum of mountain blocking drag + real (kind=kind_phys), pointer :: tau_ogw(:) => null() !< instantaneous momentum flux of OGWs + real (kind=kind_phys), pointer :: tau_ngw(:) => null() !< instantaneous momentum flux of NGWs + + real (kind=kind_phys), pointer :: zngw(:) => null() !< launch levels of NGWs real (kind=kind_phys), pointer :: zmtb(:) => null() !< mountain blocking height real (kind=kind_phys), pointer :: zlwb(:) => null() !< low level wave breaking height - real (kind=kind_phys), pointer :: zogw(:) => null() !< height of drag due to orographic gravity wave - real (kind=kind_phys), pointer :: dudt_mtb(:,:) => null() !< daily aver u-wind tend due to mountain blocking drag - real (kind=kind_phys), pointer :: dudt_ogw(:,:) => null() !< daily aver u-wind tend due to orographic gravity wave drag + real (kind=kind_phys), pointer :: zogw(:) => null() !< height of OGW-launch + + real (kind=kind_phys), pointer :: dudt_mtb(:,:) => null() !< daily aver u-wind tend due to mountain blocking real (kind=kind_phys), pointer :: dudt_tms(:,:) => null() !< daily aver u-wind tend due to TMS -#ifdef CCPP ! RRTMGP integer :: ipsdlw0 !< integer :: ipsdsw0 !< - real (kind=kind_phys), pointer :: sktp1r(:) => null() !< real (kind=kind_phys), pointer :: p_lay(:,:) => null() !< real (kind=kind_phys), pointer :: p_lev(:,:) => null() !< real (kind=kind_phys), pointer :: t_lev(:,:) => null() !< @@ -2115,7 +2057,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: fluxswUP_clrsky(:,:) => null() !< RRTMGP upward shortwave clr-sky flux profile real (kind=kind_phys), pointer :: fluxswDOWN_clrsky(:,:) => null() !< RRTMGP downward shortwave clr-sky flux profile real (kind=kind_phys), pointer :: fluxlwUP_jac(:,:) => null() !< RRTMGP upward Jacobian of longwave flux - real (kind=kind_phys), pointer :: fluxlwDOWN_jac(:,:) => null() !< RRTMGP downward Jacobian of longwave flux + real (kind=kind_phys), pointer :: fluxlwDOWN_jac(:,:) => null() !< RRTMGP downward Jacobian of longwave flux real (kind=kind_phys), pointer :: sfc_emiss_byband(:,:) => null() !< real (kind=kind_phys), pointer :: sec_diff_byband(:,:) => null() !< real (kind=kind_phys), pointer :: sfc_alb_nir_dir(:,:) => null() !< @@ -2133,10 +2075,10 @@ module GFS_typedefs type(ty_gas_optics_rrtmgp) :: sw_gas_props !< RRTMGP DDT type(ty_cloud_optics) :: lw_cloud_props !< RRTMGP DDT type(ty_cloud_optics) :: sw_cloud_props !< RRTMGP DDT - type(ty_optical_props_1scl) :: lw_optical_props_cloudsByBand !< RRTMGP DDT - type(ty_optical_props_1scl) :: lw_optical_props_clouds !< RRTMGP DDT - type(ty_optical_props_1scl) :: lw_optical_props_precipByBand !< RRTMGP DDT - type(ty_optical_props_1scl) :: lw_optical_props_precip !< RRTMGP DDT + type(ty_optical_props_2str) :: lw_optical_props_cloudsByBand !< RRTMGP DDT + type(ty_optical_props_2str) :: lw_optical_props_clouds !< RRTMGP DDT + type(ty_optical_props_2str) :: lw_optical_props_precipByBand !< RRTMGP DDT + type(ty_optical_props_2str) :: lw_optical_props_precip !< RRTMGP DDT type(ty_optical_props_1scl) :: lw_optical_props_clrsky !< RRTMGP DDT type(ty_optical_props_1scl) :: lw_optical_props_aerosol !< RRTMGP DDT type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand !< RRTMGP DDT @@ -2147,7 +2089,6 @@ module GFS_typedefs type(ty_optical_props_2str) :: sw_optical_props_aerosol !< RRTMGP DDT type(ty_gas_concs) :: gas_concentrations !< RRTMGP DDT type(ty_source_func_lw) :: sources !< RRTMGP DDT -#endif !-- HWRF physics: dry mixing ratios real (kind=kind_phys), pointer :: qv_r(:,:) => null() !< @@ -2177,12 +2118,11 @@ module GFS_typedefs procedure :: mprint => interstitial_print !< print array data end type GFS_interstitial_type -#endif !------------------------- ! GFS sub-containers !------------------------- -#ifdef CCPP + !------------------------------------------------------------------------------------ ! combined type of all of the above except GFS_control_type and GFS_interstitial_type !------------------------------------------------------------------------------------ @@ -2200,7 +2140,6 @@ module GFS_typedefs type(GFS_radtend_type) :: Radtend type(GFS_diag_type) :: Intdiag end type GFS_data_type -#endif !---------------- ! PUBLIC ENTITIES @@ -2210,9 +2149,7 @@ module GFS_typedefs GFS_coupling_type public GFS_control_type, GFS_grid_type, GFS_tbd_type, & GFS_cldprop_type, GFS_radtend_type, GFS_diag_type -#ifdef CCPP - public GFS_interstitial_type -#endif + public GFS_interstitial_type, GFS_data_type !******************************************************************************************* CONTAINS @@ -2220,7 +2157,7 @@ module GFS_typedefs !------------------------ ! GFS_statein_type%create !------------------------ - subroutine statein_create (Statein, IM, Model) + subroutine statein_create (Statein, IM, Model) implicit none class(GFS_statein_type) :: Statein @@ -2437,16 +2374,12 @@ subroutine sfcprop_create (Sfcprop, IM, Model) !--- Out allocate (Sfcprop%t2m (IM)) -#ifdef CCPP allocate (Sfcprop%th2m(IM)) -#endif allocate (Sfcprop%q2m (IM)) - Sfcprop%t2m = clear_val -#ifdef CCPP + Sfcprop%t2m = clear_val Sfcprop%th2m = clear_val -#endif - Sfcprop%q2m = clear_val + Sfcprop%q2m = clear_val if (Model%nstf_name(1) > 0) then allocate (Sfcprop%tref (IM)) @@ -2532,19 +2465,11 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%smcwtdxy (IM)) allocate (Sfcprop%deeprechxy (IM)) allocate (Sfcprop%rechxy (IM)) -#ifdef CCPP allocate (Sfcprop%snicexy (IM, Model%lsnow_lsm_lbound:0)) allocate (Sfcprop%snliqxy (IM, Model%lsnow_lsm_lbound:0)) allocate (Sfcprop%tsnoxy (IM, Model%lsnow_lsm_lbound:0)) allocate (Sfcprop%smoiseq (IM, Model%lsoil_lsm)) allocate (Sfcprop%zsnsoxy (IM, Model%lsnow_lsm_lbound:Model%lsoil_lsm)) -#else - 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)) -#endif Sfcprop%snowxy = clear_val Sfcprop%tvxy = clear_val @@ -2581,7 +2506,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%tsnoxy = clear_val Sfcprop%smoiseq = clear_val Sfcprop%zsnsoxy = clear_val - + allocate(Sfcprop%draincprv (IM)) allocate(Sfcprop%drainncprv (IM)) allocate(Sfcprop%diceprv (IM)) @@ -2593,17 +2518,16 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%diceprv = clear_val Sfcprop%dsnowprv = clear_val Sfcprop%dgraupelprv = clear_val - + endif -#ifdef CCPP ! HWRF NOAH LSM allocate and init when used ! if (Model%lsm == Model%lsm_noah_wrfv4 ) then allocate(Sfcprop%snotime(IM)) Sfcprop%snotime = clear_val end if - + if (Model%do_myjsfc.or.Model%do_myjpbl.or.(Model%lsm == Model%lsm_noah_wrfv4)) then allocate(Sfcprop%z0base(IM)) Sfcprop%z0base = clear_val @@ -2612,7 +2536,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate(Sfcprop%semisbase(IM)) Sfcprop%semisbase = clear_val end if - + if (Model%lsm == Model%lsm_ruc) then ! For land surface models with different numbers of levels than the four NOAH levels allocate (Sfcprop%wetness (IM)) @@ -2681,8 +2605,6 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%conv_act(IM)) Sfcprop%conv_act = zero end if - -#endif end subroutine sfcprop_create @@ -2702,12 +2624,12 @@ subroutine coupling_create (Coupling, IM, Model) !--- 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)) + 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 @@ -2721,10 +2643,14 @@ subroutine coupling_create (Coupling, IM, Model) allocate (Coupling%sfcdsw (IM)) allocate (Coupling%sfcnsw (IM)) allocate (Coupling%sfcdlw (IM)) + allocate (Coupling%sfculw (IM)) + allocate (Coupling%sfculw_jac (IM)) Coupling%sfcdsw = clear_val Coupling%sfcnsw = clear_val Coupling%sfcdlw = clear_val + Coupling%sfculw = clear_val + Coupling%sfculw_jac = clear_val if (Model%cplflx .or. Model%do_sppt .or. Model%cplchm .or. Model%ca_global) then allocate (Coupling%rain_cpl (IM)) @@ -2734,13 +2660,13 @@ subroutine coupling_create (Coupling, IM, Model) endif if (Model%cplflx .or. Model%cplwav) then - !--- instantaneous quantities + !--- instantaneous quantities allocate (Coupling%u10mi_cpl (IM)) allocate (Coupling%v10mi_cpl (IM)) Coupling%u10mi_cpl = clear_val Coupling%v10mi_cpl = clear_val - endif + endif ! if (Model%cplwav2atm) then !--- incoming quantities @@ -2878,7 +2804,7 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%ca_turb = clear_val Coupling%ca_shal = clear_val Coupling%ca_rad = clear_val - Coupling%ca_micro = clear_val + Coupling%ca_micro = clear_val Coupling%condition = clear_val endif @@ -2932,12 +2858,10 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%nifa2d = clear_val endif -#ifdef CCPP if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then allocate (Coupling%qci_conv (IM,Model%levs)) Coupling%qci_conv = clear_val endif -#endif end subroutine coupling_create @@ -2951,23 +2875,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & dt_phys, iau_offset, idat, jdat, & tracer_names, & input_nml_file, tile_num, blksz, & - ak,bk & -#ifdef CCPP - ,restart, hydrostatic, & - communicator, ntasks, nthreads & -#endif - ) + ak, bk, restart, hydrostatic, & + communicator, ntasks, nthreads) !--- modules -#ifdef CCPP use physcons, only: con_rerth, con_pi -! use rascnv, only: nrcmax -#else - use physcons, only: dxmax, dxmin, dxinv, con_rerth, con_pi, rhc_max - use module_ras, only: nrcmax - use wam_f107_kp_mod, only: f107_kp_size, f107_kp_interval, & - f107_kp_skip_size, f107_kp_data_size -#endif use mersenne_twister, only: random_setseed, random_number use parse_tracers, only: get_tracer_index ! @@ -3000,13 +2912,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer, intent(in) :: blksz(:) real(kind=kind_phys), dimension(:), intent(in) :: ak real(kind=kind_phys), dimension(:), intent(in) :: bk -#ifdef CCPP logical, intent(in) :: restart logical, intent(in) :: hydrostatic integer, intent(in) :: communicator integer, intent(in) :: ntasks integer, intent(in) :: nthreads -#endif + !--- local variables integer :: i, j, n integer :: ios @@ -3043,12 +2954,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- radiation parameters real(kind=kind_phys) :: fhswr = 3600. !< frequency for shortwave radiation (secs) real(kind=kind_phys) :: fhlwr = 3600. !< frequency for longwave radiation (secs) -#ifdef CCPP integer :: nhfrad = 0 !< number of timesteps for which to call radiation on physics timestep (coldstarts) -#endif integer :: levr = -99 !< number of vertical levels for radiation calculations - integer :: nfxr = 39+6 !< second dimension of input/output array fluxr - logical :: iaerclm = .false. !< flag for initializing aero data + integer :: nfxr = 39+6 !< second dimension of input/output array fluxr + logical :: iaerclm = .false. !< flag for initializing aero data integer :: iccn = 0 !< logical to use IN CCN forcing for MG2/3 integer :: iflip = 1 !< iflip - is not the same as flipv integer :: isol = 0 !< use prescribed solar constant @@ -3058,9 +2967,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: iems = 0 !< use fixed value of 1.0 integer :: iaer = 1 !< default aerosol effect in sw only integer :: icliq_sw = 1 !< sw optical property for liquid clouds - integer :: icice_sw = 3 !< sw optical property for ice clouds - integer :: icliq_lw = 1 !< lw optical property for liquid clouds - integer :: icice_lw = 3 !< lw optical property for ice clouds + integer :: icice_sw = 3 !< sw optical property for ice clouds + integer :: icliq_lw = 1 !< lw optical property for liquid clouds + integer :: icice_lw = 3 !< lw optical property for ice clouds integer :: iovr = 1 !< cloud-overlap: max-random overlap clouds integer :: ictm = 1 !< ictm=0 => use data at initial cond time, if not !< available; use latest; no extrapolation. @@ -3068,7 +2977,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< 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, + !< 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. @@ -3085,32 +2994,31 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< =2 => Use spatially and temporally varyint decorrelation length (Oreopoulos et al. 2012) real(kind_phys) :: dcorr_con = 2.5 !< Decorrelation length constant (km) (if idcor = 0) logical :: crick_proof = .false. !< CRICK-Proof cloud water - logical :: ccnorm = .false. !< Cloud condensate normalized by cloud cover + 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) - ! RRTMGP -#ifdef CCPP - logical :: do_RRTMGP = .false. !< Use RRTMGP? - character(len=128) :: active_gases = '' !< Character list of active gases used in RRTMGP - integer :: nGases = 0 !< Number of active gases - character(len=128) :: rrtmgp_root = '' !< Directory of rte+rrtmgp source code - character(len=128) :: lw_file_gas = '' !< RRTMGP K-distribution file, coefficients to compute optics for gaseous atmosphere - character(len=128) :: lw_file_clouds = '' !< RRTMGP file containing coefficients used to compute clouds optical properties - integer :: rrtmgp_nBandsLW = 16 !< Number of RRTMGP LW bands. - integer :: rrtmgp_nGptsLW = 256 !< Number of RRTMGP LW spectral points. - character(len=128) :: sw_file_gas = '' !< RRTMGP K-distribution file, coefficients to compute optics for gaseous atmosphere - character(len=128) :: sw_file_clouds = '' !< RRTMGP file containing coefficients used to compute clouds optical properties - integer :: rrtmgp_nBandsSW = 14 !< Number of RRTMGP SW bands. - integer :: rrtmgp_nGptsSW = 224 !< Number of RRTMGP SW spectral points. - logical :: doG_cldoptics = .false. !< Use legacy RRTMG cloud-optics? + ! RRTMGP + logical :: do_RRTMGP = .false. !< Use RRTMGP? + character(len=128) :: active_gases = '' !< Character list of active gases used in RRTMGP + integer :: nGases = 0 !< Number of active gases + character(len=128) :: rrtmgp_root = '' !< Directory of rte+rrtmgp source code + character(len=128) :: lw_file_gas = '' !< RRTMGP K-distribution file, coefficients to compute optics for gaseous atmosphere + character(len=128) :: lw_file_clouds = '' !< RRTMGP file containing coefficients used to compute clouds optical properties + integer :: rrtmgp_nBandsLW = 16 !< Number of RRTMGP LW bands. + integer :: rrtmgp_nGptsLW = 256 !< Number of RRTMGP LW spectral points. + character(len=128) :: sw_file_gas = '' !< RRTMGP K-distribution file, coefficients to compute optics for gaseous atmosphere + character(len=128) :: sw_file_clouds = '' !< RRTMGP file containing coefficients used to compute clouds optical properties + integer :: rrtmgp_nBandsSW = 14 !< Number of RRTMGP SW bands. + integer :: rrtmgp_nGptsSW = 224 !< Number of RRTMGP SW spectral points. + logical :: doG_cldoptics = .false. !< Use legacy RRTMG cloud-optics? logical :: doGP_cldoptics_PADE = .false. !< Use RRTMGP cloud-optics: PADE approximation? - logical :: doGP_cldoptics_LUT = .false. !< Use RRTMGP cloud-optics: LUTs? - integer :: rrtmgp_nrghice = 0 !< Number of ice-roughness categories - integer :: rrtmgp_nGauss_ang=1 !< Number of angles used in Gaussian quadrature - logical :: do_GPsw_Glw = .false. - logical :: use_LW_jacobian = .false. !< Use Jacobian of LW to update LW radiation tendencies. -#endif + logical :: doGP_cldoptics_LUT = .false. !< Use RRTMGP cloud-optics: LUTs? + integer :: rrtmgp_nrghice = 0 !< Number of ice-roughness categories + integer :: rrtmgp_nGauss_ang = 1 !< Number of angles used in Gaussian quadrature + logical :: do_GPsw_Glw = .false. + logical :: use_LW_jacobian = .false. !< Use Jacobian of LW to update LW radiation tendencies. + logical :: doGP_lwscat = .false. !< If true, include scattering in longwave cloud-optics, only compatible w/ GP cloud-optics !--- Z-C microphysical parameters integer :: ncld = 1 !< choice of cloud scheme integer :: imp_physics = 99 !< choice of cloud scheme @@ -3121,12 +3029,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !---Max hourly real(kind=kind_phys) :: avg_max_length = 3600. !< reset value in seconds for max hourly !--- Ferrier-Aligo microphysical parameters -#ifdef CCPP real(kind=kind_phys) :: rhgrd = 1.0 !< fer_hires microphysics only; for 3-km domain logical :: spec_adv = .true. !< Individual cloud species advected integer :: icloud = 0 !< cloud effect to the optical depth in radiation; this also controls the cloud fraction options !< 3: with cloud effect from FA, and use cloud fraction option 3, based on Sundqvist et al. (1989) -#endif !--- M-G microphysical parameters integer :: fprcp = 0 !< no prognostic rain and snow (MG) integer :: pdfflag = 4 !< pdf flag for MG macro physics @@ -3162,12 +3068,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- Thompson microphysical parameters logical :: ltaerosol = .false. !< flag for aerosol version - logical :: lradar = .false. !< flag for radar reflectivity + logical :: lradar = .false. !< flag for radar reflectivity real(kind=kind_phys) :: nsradar_reset = -999.0 !< seconds between resetting radar reflectivity calculation, set to <0 for every time step real(kind=kind_phys) :: ttendlim = -999.0 !< temperature tendency limiter, set to <0 to deactivate !--- GFDL microphysical parameters - logical :: lgfdlmprad = .false. !< flag for GFDLMP radiation interaction + logical :: lgfdlmprad = .false. !< flag for GFDLMP radiation interaction !--- Thompson,GFDL microphysical parameter logical :: lrefres = .false. !< flag for radar reflectivity in restart file @@ -3175,7 +3081,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- land/surface model parameters integer :: lsm = 1 !< flag for land surface model to use =0 for osu lsm; =1 for noah lsm; =2 for noah mp lsm; =3 for RUC lsm integer :: lsoil = 4 !< number of soil layers -#ifdef CCPP integer :: lsoil_lsm = -1 !< number of soil layers internal to land surface model; -1 use lsoil integer :: lsnow_lsm = 3 !< maximum number of snow layers internal to land surface model logical :: rdlai = .false. !< read LAI from input file (for RUC LSM or NOAH LSM WRFv4) @@ -3187,7 +3092,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< = 1, original (default) !< = 2, McCumber and Pielke for silt loam and sandy loam integer :: kice = 2 !< number of layers in ice; default is 2 (GFS sice) -#endif integer :: ivegsrc = 2 !< ivegsrc = 0 => USGS, !< ivegsrc = 1 => IGBP (20 category) !< ivegsrc = 2 => UMD (13 category) @@ -3212,12 +3116,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: use_ufo = .false. !< flag for gcycle surface option -#ifdef CCPP logical :: lcurr_sf = .false. !< flag for taking ocean currents into account in GFDL surface layer logical :: pert_cd = .false. !< flag for perturbing the surface drag coefficient for momentum in surface layer scheme integer :: ntsflg = 0 !< flag for updating skin temperature in the GFDL surface layer scheme real(kind=kind_phys) :: sfenth = 0.0 !< enthalpy flux factor 0 zot via charnock ..>0 zot enhanced>15m/s -#endif !--- flake model parameters integer :: lkm = 0 !< flag for flake model @@ -3236,11 +3138,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< gwd_opt = 33: GSL drag suite with extra output logical :: do_ugwp_v0 = .true. !< flag for version 0 ugwp GWD logical :: do_ugwp_v0_orog_only = .false. !< flag for version 0 ugwp GWD (orographic drag only) + logical :: do_ugwp_v0_nst_only = .false. !< flag for version 0 ugwp GWD (non-stationary GWD only) logical :: do_gsl_drag_ls_bl = .false. !< flag for GSL drag (large-scale GWD and blocking only) logical :: do_gsl_drag_ss = .false. !< flag for GSL drag (small-scale GWD only) logical :: do_gsl_drag_tofd = .false. !< flag for GSL drag (turbulent orog form drag only) logical :: do_ugwp_v1 = .false. !< flag for version 1 ugwp GWD logical :: do_ugwp_v1_orog_only = .false. !< flag for version 1 ugwp GWD (orographic drag only) + logical :: do_ugwp_v1_w_gsldrag = .false. !< flag for version 1 ugwp GWD (orographic drag only) !--- vay-2018 logical :: ldiag_ugwp = .false. !< flag for UGWP diag fields logical :: do_ugwp = .false. !< flag do UGWP+RF @@ -3259,10 +3163,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: do_shoc = .false. !< flag for SHOC logical :: shocaftcnv = .false. !< flag for SHOC logical :: shoc_cld = .false. !< flag for SHOC in grrad -#ifdef CCPP logical :: oz_phys = .true. !< flag for old (2006) ozone physics logical :: oz_phys_2015 = .false. !< flag for new (2015) ozone physics -#endif logical :: h2o_phys = .false. !< flag for stratosphere h2o logical :: pdfcld = .false. !< flag for pdfcld logical :: shcnvcw = .false. !< flag for shallow convective cloud @@ -3273,9 +3175,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: shinhong = .false. !< flag for scale-aware Shinhong vertical turbulent mixing scheme logical :: do_ysu = .false. !< flag for YSU vertical turbulent mixing scheme logical :: dspheat = .false. !< flag for tke dissipative heating -#ifdef CCPP logical :: hurr_pbl = .false. !< flag for hurricane-specific options in PBL scheme -#endif logical :: lheatstrg = .false. !< flag for canopy heat storage parameterization logical :: cnvcld = .false. logical :: random_clds = .false. !< flag controls whether clouds are random @@ -3298,9 +3198,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< 0: initial version of satmedmf (Nov. 2018) !< 1: updated version of satmedmf (as of May 2019) logical :: do_deep = .true. !< whether to do deep convection -#ifdef CCPP - logical :: hwrf_samfdeep = .false. !< flag for HWRF SAMF deepcnv scheme - logical :: hwrf_samfshal = .false. !< flag for HWRF SAMF shalcnv scheme + + logical :: hwrf_samfdeep = .false. !< flag for HWRF SAMF deepcnv scheme + logical :: hwrf_samfshal = .false. !< flag for HWRF SAMF shalcnv scheme logical :: do_mynnedmf = .false. !< flag for MYNN-EDMF logical :: do_mynnsfclay = .false. !< flag for MYNN Surface Layer Scheme ! DH* TODO - move to MYNN namelist section @@ -3323,7 +3223,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ! *DH logical :: do_myjsfc = .false. !< flag for MYJ surface layer scheme logical :: do_myjpbl = .false. !< flag for MYJ PBL scheme -#endif + 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 @@ -3336,18 +3236,16 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: cdmbgwd(4) = (/2.0d0,0.25d0,1.0d0,1.0d0/) !< multiplication factors for cdmb, gwd, and NS gwd, tke based enhancement real(kind=kind_phys) :: sup = 1.0 !< supersaturation in pdf cloud (IMP_physics=98) when t is very low !< or ice super saturation in SHOC (when do_shoc=.true.) - real(kind=kind_phys) :: ctei_rm(2) = (/10.0d0,10.0d0/) !< critical cloud top entrainment instability criteria + 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 + real(kind=kind_phys) :: dlqf(2) = (/0.0d0,0.0d0/) !< factor for cloud condensate detrainment !< from cloud edges for RAS real(kind=kind_phys) :: psauras(2) = (/1.0d-3,1.0d-3/) !< [in] auto conversion coeff from ice to snow in ras real(kind=kind_phys) :: prauras(2) = (/2.0d-3,2.0d-3/) !< [in] auto conversion coeff from cloud to rain in ras real(kind=kind_phys) :: wminras(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for ras -#ifdef CCPP integer :: nrcmax = 32 !< number of random numbers used in RAS -#endif real(kind=kind_phys) :: rbcr = 0.25 !< Critical Richardson Number in PBL scheme real(kind=kind_phys) :: shoc_parm(5) = (/7000.0,1.0,4.2857143,0.7,-999.0/) !< some tunable parameters for shoc @@ -3372,7 +3270,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< 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 + !< as Nccn=100 for sea and Nccn=1000 for land !--- mass flux shallow convection real(kind=kind_phys) :: clam_shal = 0.3 !< c_e for shallow convection (Han and Pan, 2011, eq(6)) @@ -3386,7 +3284,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< 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 + !< as Nccn=100 for sea and Nccn=1000 for land !--- near surface sea temperature model logical :: nst_anl = .false. !< flag for NSSTM analysis in gcycle/sfcsub @@ -3414,9 +3312,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< negative when cplwav2atm=.true. - i.e. two way wave coupling !--- vertical diffusion - real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum - real(kind=kind_phys) :: xkzm_h = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q - real(kind=kind_phys) :: xkzm_s = 1.0d0 !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion + real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum + real(kind=kind_phys) :: xkzm_h = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q + real(kind=kind_phys) :: xkzm_s = 1.0d0 !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion real(kind=kind_phys) :: xkzminv = 0.3 !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac = 1.0 !< turbulence diffusion coefficient factor real(kind=kind_phys) :: dspfac = 1.0 !< tke dissipative heating factor @@ -3427,7 +3325,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: z0fac = 0.3 real(kind=kind_phys) :: e0fac = 0.5 - + !---Cellular automaton options integer :: nca = 1 integer :: ncells = 5 @@ -3446,7 +3344,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: ca_smooth = .false. real(kind=kind_phys) :: nthresh = 0.0 real :: ca_amplitude = 500. - integer :: nsmooth = 100 + integer :: nsmooth = 100 logical :: ca_closure = .false. logical :: ca_entr = .false. logical :: ca_trigger = .false. @@ -3492,7 +3390,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & fhswr, fhlwr, levr, nfxr, iaerclm, iflip, isol, ico2, ialb, & isot, iems, iaer, icliq_sw, iovr, ictm, isubc_sw, & isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, & -#ifdef CCPP nhfrad, idcor, dcorr_con, & ! --- RRTMGP do_RRTMGP, active_gases, nGases, rrtmgp_root, & @@ -3500,8 +3397,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & sw_file_gas, sw_file_clouds, rrtmgp_nBandsSW, rrtmgp_nGptsSW,& doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & rrtmgp_nrghice, rrtmgp_nGauss_ang, do_GPsw_Glw, & - use_LW_jacobian, & -#endif + use_LW_jacobian, doGP_lwscat, & ! IN CCN forcing iccn, & !--- microphysical parameterizations @@ -3517,28 +3413,19 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- max hourly avg_max_length, & !--- land/surface model control -#ifdef CCPP lsm, lsoil, lsoil_lsm, lsnow_lsm, kice, rdlai, & nmtvr, ivegsrc, use_ufo, iopt_thcnd, ua_phys, usemonalb, & aoasis, fasdas, & -#else - lsm, lsoil, nmtvr, ivegsrc, use_ufo, & -#endif ! 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, & -#ifdef CCPP ! GFDL surface layer options lcurr_sf, pert_cd, ntsflg, sfenth, & -#endif - !--- lake model control - lkm, & - + lkm, & !--- physical parameterizations ras, trans_trac, old_monin, cnvgwd, mstrat, moist_adj, & cscnv, cal_pre, do_aw, do_shoc, shocaftcnv, shoc_cld, & -#ifdef CCPP oz_phys, oz_phys_2015, & do_mynnedmf, do_mynnsfclay, & ! DH* TODO - move to MYNN namelist section @@ -3547,12 +3434,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & bl_mynn_mixqt, bl_mynn_output, icloud_bl, bl_mynn_tkeadvect, & ! *DH gwd_opt, do_ugwp_v0, do_ugwp_v0_orog_only, & + do_ugwp_v0_nst_only, & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - do_ugwp_v1, do_ugwp_v1_orog_only, & + do_ugwp_v1, do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, & var_ric, coef_ric_l, coef_ric_s, hurr_pbl, & do_myjsfc, do_myjpbl, & hwrf_samfdeep, hwrf_samfshal, & -#endif h2o_phys, pdfcld, shcnvcw, redrag, hybedmf, satmedmf, & shinhong, do_ysu, dspheat, lheatstrg, cnvcld, & random_clds, shal_cnv, imfshalcnv, imfdeepcnv, isatmedmf, & @@ -3564,9 +3451,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- Rayleigh friction prslrd0, ral_ts, ldiag_ugwp, do_ugwp, do_tofd, & ! --- Ferrier-Aligo -#ifdef CCPP spec_adv, rhgrd, icloud, & -#endif !--- mass flux deep convection clam_deep, c0s_deep, c1_deep, betal_deep, & betas_deep, evfact_deep, evfactl_deep, pgcon_deep, & @@ -3588,7 +3473,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & nca, ncells, nlives, nca_g, ncells_g, nlives_g, nfracseed, & nseed, nseed_g, nthresh, do_ca, & ca_sgs, ca_global,iseed_ca,ca_smooth, & - nspinup,ca_amplitude,nsmooth,ca_closure,ca_entr,ca_trigger, & + nspinup,ca_amplitude,nsmooth,ca_closure,ca_entr,ca_trigger, & !--- IAU iau_delthrs,iaufhrs,iau_inc_files,iau_filter_increments, & iau_drymassfixer, & @@ -3600,7 +3485,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- aerosol scavenging factors ('name:value' string array) fscav_aero -!--- other parameters +!--- other parameters integer :: nctp = 0 !< number of cloud types in CS scheme logical :: gen_coord_hybrid = .false. !< for Henry's gen coord @@ -3616,10 +3501,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & #ifdef INTERNAL_FILE_NML Model%input_nml_file => input_nml_file read(Model%input_nml_file, nml=gfs_physics_nml) -#ifdef CCPP ! Set length (number of lines) in namelist for internal reads Model%input_nml_file_length = size(Model%input_nml_file) -#endif #else inquire (file=trim(fn_nml), exist=exists) if (.not. exists) then @@ -3631,11 +3514,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & rewind(nlunit) read (nlunit, nml=gfs_physics_nml) close (nlunit) -#ifdef CCPP ! Set length (number of lines) in namelist for internal reads Model%input_nml_file_length = 0 #endif -#endif !--- write version number and namelist to log file --- if (me == master) then write(logunit, '(a80)') '================================================================================' @@ -3646,16 +3527,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- MPI parameters Model%me = me Model%master = master -#ifdef CCPP Model%communicator = communicator Model%ntasks = ntasks Model%nthreads = nthreads -#endif Model%nlunit = nlunit Model%fn_nml = fn_nml -#ifdef CCPP Model%logunit = logunit -#endif Model%fhzero = fhzero Model%ldiag3d = ldiag3d Model%qdiag3d = qdiag3d @@ -3668,8 +3545,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%flag_for_scnv_generic_tend = .true. Model%flag_for_dcnv_generic_tend = .true. -#ifdef CCPP - if(gwd_opt==1) then if(me==master) & write(0,*) 'FLAG: gwd_opt==1 so gwd not generic' @@ -3719,7 +3594,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & elseif(me==master) then write(0,*) 'NO FLAG: dcnv is generic' endif -#endif + ! !VAY-ugwp --- set some GW-related switches ! @@ -3764,10 +3639,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & allocate(Model%bk(1:size(bk))) Model%ak = ak Model%bk = bk -#ifdef CCPP Model%levsp1 = Model%levs + 1 Model%levsm1 = Model%levs - 1 -#endif Model%cnx = cnx Model%cny = cny Model%lonr = gnx ! number longitudinal points @@ -3775,9 +3648,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%nblks = size(blksz) allocate(Model%blksz(1:Model%nblks)) Model%blksz = blksz -#ifdef CCPP Model%ncols = sum(Model%blksz) -#endif !--- coupling parameters Model%cplflx = cplflx @@ -3787,6 +3658,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- integrated dynamics through earth's atmosphere Model%lsidea = lsidea + if (Model%lsidea) then + print *,' LSIDEA is active but needs to be reworked for FV3 - shutting down' + stop + endif !--- calendars and time parameters and activation triggers Model%dtp = dt_phys @@ -3806,7 +3681,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%fhlwr = fhlwr Model%nsswr = nint(fhswr/Model%dtp) Model%nslwr = nint(fhlwr/Model%dtp) -#ifdef CCPP if (restart) then Model%nhfrad = 0 if (Model%me == Model%master .and. nhfrad>0) & @@ -3816,15 +3690,14 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if (Model%me == Model%master .and. nhfrad>0) & write(*,'(a,i0)') 'Number of high-frequency radiation calls for coldstart run: ', nhfrad endif -#endif + if (levr < 0) then Model%levr = levs else Model%levr = levr endif -#ifdef CCPP Model%levrp1 = Model%levr + 1 -#endif + Model%nfxr = nfxr Model%iccn = iccn ! further down: set Model%iccn to .false. @@ -3843,11 +3716,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & else ntrcaer = 1 endif -#ifdef CCPP Model%ntrcaer = ntrcaer Model%idcor = idcor Model%dcorr_con = dcorr_con -#endif Model%icliq_sw = icliq_sw Model%icice_sw = icice_sw Model%icliq_lw = icliq_lw @@ -3860,7 +3731,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ccnorm = ccnorm Model%lwhtr = lwhtr Model%swhtr = swhtr -#ifdef CCPP + ! RRTMGP Model%do_RRTMGP = do_RRTMGP Model%rrtmgp_nrghice = rrtmgp_nrghice @@ -3881,11 +3752,17 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%doGP_cldoptics_PADE = doGP_cldoptics_PADE Model%doGP_cldoptics_LUT = doGP_cldoptics_LUT Model%use_LW_jacobian = use_LW_jacobian + Model%doGP_lwscat = doGP_lwscat ! RRTMGP incompatible with levr /= levs if (Model%do_RRTMGP .and. Model%levr /= Model%levs) then write(0,*) "Logic error, RRTMGP only works with levr = levs" stop end if + ! RRTMGP LW scattering calculation not supported w/ RRTMG cloud-optics + if (Model%doGP_lwscat .and. Model%doG_cldoptics) then + write(0,*) "Logic error, RRTMGP Longwave cloud-scattering not supported with RRTMG cloud-optics." + stop + end if ! The CCPP versions of the RRTMG lw/sw schemes are configured ! such that lw and sw heating rate are output, i.e. they rely @@ -3895,7 +3772,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & " of the lw/sw heating rates to be turned on (namelist options lwhtr and swhtr)" stop end if -#endif !--- microphysical switch Model%ncld = ncld @@ -3947,13 +3823,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%nsradar_reset = nsradar_reset Model%ttendlim = ttendlim !--- F-A MP parameters -#ifdef CCPP Model%rhgrd = rhgrd Model%spec_adv = spec_adv Model%icloud = icloud -#endif -!--- gfdl MP parameters +!--- GFDL MP parameters Model%lgfdlmprad = lgfdlmprad !--- Thompson,GFDL MP parameter Model%lrefres = lrefres @@ -3961,7 +3835,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- land/surface model parameters Model%lsm = lsm Model%lsoil = lsoil -#ifdef CCPP + ! Consistency check for HWRF Noah LSM if (Model%lsm == Model%lsm_noah_wrfv4 .and. Model%nscyc>0) then write(0,*) 'Logic error: NOAH WRFv4 LSM cannot be used with surface data cycling at this point (fhcyc>0)' @@ -4009,19 +3883,16 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%usemonalb = usemonalb Model%aoasis = aoasis Model%fasdas = fasdas -#endif Model%ivegsrc = ivegsrc Model%isot = isot Model%use_ufo = use_ufo -#ifdef CCPP ! GFDL surface layer options Model%lcurr_sf = lcurr_sf Model%pert_cd = pert_cd Model%ntsflg = ntsflg Model%sfenth = sfenth -#endif - + !--- flake model parameters Model%lkm = lkm @@ -4056,7 +3927,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%shoc_parm = shoc_parm Model%shocaftcnv = shocaftcnv Model%shoc_cld = shoc_cld -#ifdef CCPP + !HWRF physics suite if (hwrf_samfdeep .and. imfdeepcnv/=2) then write(*,*) 'Logic error: hwrf_samfdeep requires imfdeepcnv=2' @@ -4068,17 +3939,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & end if Model%hwrf_samfdeep = hwrf_samfdeep Model%hwrf_samfshal = hwrf_samfshal -#endif -#ifdef CCPP + if (oz_phys .and. oz_phys_2015) then write(*,*) 'Logic error: can only use one ozone physics option (oz_phys or oz_phys_2015), not both. Exiting.' stop end if Model%oz_phys = oz_phys Model%oz_phys_2015 = oz_phys_2015 -#endif Model%h2o_phys = h2o_phys -#ifdef CCPP + ! To ensure that these values match what's in the physics, ! array sizes are compared during model init in GFS_phys_time_vary_init() ! @@ -4090,7 +3959,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & levh2o = 1 h2o_coeff = 1 end if -#endif + Model%pdfcld = pdfcld Model%shcnvcw = shcnvcw Model%redrag = redrag @@ -4099,9 +3968,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%shinhong = shinhong Model%do_ysu = do_ysu Model%dspheat = dspheat -#ifdef CCPP Model%hurr_pbl = hurr_pbl -#endif Model%lheatstrg = lheatstrg Model%cnvcld = cnvcld Model%random_clds = random_clds @@ -4124,10 +3991,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%prauras = prauras Model%wminras = wminras Model%rbcr = rbcr - Model%do_gwd = maxval(Model%cdmbgwd) > 0.0 - - Model%do_cnvgwd = Model%cnvgwd .and. maxval(Model%cdmbgwd(3:4)) == 0.0 -#ifdef CCPP + Model%do_gwd = maxval(Model%cdmbgwd) > 0.0 ! flag to restore OGWs of GFS-v15 +! OLD GFS-v12-15 conv scheme +! Model%do_cnvgwd = Model%cnvgwd .and. maxval(Model%cdmbgwd(3:4)) == 0.0 + Model%do_cnvgwd = .false. ! this avoids all "mysteries" to use Convective GWs in UFS Model%do_mynnedmf = do_mynnedmf Model%do_mynnsfclay = do_mynnsfclay ! DH* TODO - move to MYNN namelist section @@ -4147,6 +4014,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%coef_ric_l = coef_ric_l Model%coef_ric_s = coef_ric_s ! *DH + Model%gwd_opt = gwd_opt if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22) then @@ -4155,14 +4023,29 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & end if Model%do_ugwp_v0 = do_ugwp_v0 Model%do_ugwp_v0_orog_only = do_ugwp_v0_orog_only + Model%do_ugwp_v0_nst_only = do_ugwp_v0_nst_only Model%do_gsl_drag_ls_bl = do_gsl_drag_ls_bl Model%do_gsl_drag_ss = do_gsl_drag_ss Model%do_gsl_drag_tofd = do_gsl_drag_tofd Model%do_ugwp_v1 = do_ugwp_v1 Model%do_ugwp_v1_orog_only = do_ugwp_v1_orog_only + Model%do_ugwp_v1_w_gsldrag = do_ugwp_v1_w_gsldrag +! +! consistency in application of the combined ugwp-v1 and gsldrag +! + if ( Model%do_ugwp_v1_w_gsldrag) then + if(Model%gwd_opt == 1 )then + Model%gwd_opt =2 + Model%nmtvr = 24 + endif + Model%do_gsl_drag_ls_bl = .true. + Model%do_gsl_drag_tofd = .true. + Model%do_gsl_drag_ss = .true. + Model%do_ugwp_v1_orog_only = .false. + endif + Model%do_myjsfc = do_myjsfc Model%do_myjpbl = do_myjpbl -#endif !--- Rayleigh friction Model%prslrd0 = prslrd0 @@ -4244,8 +4127,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ca_sgs = ca_sgs Model%iseed_ca = iseed_ca Model%ca_smooth = ca_smooth - Model%nspinup = nspinup - Model%nthresh = nthresh + Model%nspinup = nspinup + Model%nthresh = nthresh Model%ca_amplitude = ca_amplitude Model%nsmooth = nsmooth Model%ca_closure = ca_closure @@ -4267,9 +4150,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- tracer handling Model%ntrac = size(tracer_names) -#ifdef CCPP Model%ntracp1 = Model%ntrac + 1 -#endif allocate (Model%tracer_names(Model%ntrac)) Model%tracer_names(:) = tracer_names(:) Model%ntqv = 1 @@ -4292,9 +4173,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & 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) -#ifdef CCPP Model%nqrimef = get_tracer_index(Model%tracer_names, 'q_rimef', Model%me, Model%master, Model%debug) -#endif 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 @@ -4349,7 +4228,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & enddo endif -#ifdef CCPP ! To ensure that these values match what's in the physics, ! array sizes are compared during model init in GFS_phys_time_vary_init() ! @@ -4371,10 +4249,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & stop else levozp = 1 - oz_coeff = 0 + oz_coeff = 1 end if end if -#endif !--- quantities to be used to derive phy_f*d totals Model%nshoc_2d = nshoc_2d @@ -4393,17 +4270,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%sdec = -9999. Model%cdec = -9999. Model%clstp = -9999 - rinc(1:5) = 0 + 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 -#ifdef CCPP Model%first_time_step = .true. Model%restart = restart Model%hydrostatic = hydrostatic -#endif Model%jdat(1:8) = jdat(1:8) allocate(Model%si(Model%levr+1)) !--- Define sigma level for radiation initialization @@ -4411,29 +4286,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- 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 Model%si = (ak + bk * con_p0 - ak(Model%levr+1)) / (con_p0 - ak(Model%levr+1)) -#ifdef CCPP Model%sec = 0 Model%yearlen = 365 Model%julian = -9999. -#endif - -#ifndef CCPP - ! Beware! The values set here reside in wam_f107_kp_mod and determine sizes of arrays - ! inside that module. These arrays get used later in modules idea_tracer.f, idea_ion.f, - ! idea_solar_heating.f, efield.f, and idea_composition.f. - ! Since in wam_f107_kp_mod no default values are assigned to the four integers below, not - ! setting them here can lead to memory corruption that is hard to detect. -!--- stored in wam_f107_kp module - f107_kp_size = 56 - f107_kp_skip_size = 0 - f107_kp_data_size = 56 - f107_kp_interval = 10800 -#endif !--- BEGIN CODE FROM GFS_PHYSICS_INITIALIZE !--- define physcons module variables - tem = con_rerth*con_rerth*(con_pi+con_pi)*con_pi -#ifdef CCPP + tem = con_rerth*con_rerth*(con_pi+con_pi)*con_pi Model%dxmax = log(tem/(max_lon*max_lat)) Model%dxmin = log(tem/(min_lon*min_lat)) Model%dxinv = 1.0d0 / (Model%dxmax-Model%dxmin) @@ -4441,18 +4300,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if (Model%me == Model%master) write(*,*)' dxmax=',Model%dxmax,' dxmin=',Model%dxmin,' dxinv=',Model%dxinv, & 'max_lon=',max_lon,' max_lat=',max_lat,' min_lon=',min_lon,' min_lat=',min_lat, & ' rhc_max=',Model%rhcmax -#else - dxmax = log(tem/(max_lon*max_lat)) - dxmin = log(tem/(min_lon*min_lat)) - dxinv = 1.0d0 / (dxmax-dxmin) - rhc_max = rhcmax - if (Model%me == Model%master) write(*,*)' dxmax=',dxmax,' dxmin=',dxmin,' dxinv=',dxinv, & - 'max_lon=',max_lon,' max_lat=',max_lat,' min_lon=',min_lon,' min_lat=',min_lat, & - ' rhc_max=',rhc_max -#endif - -!--- set nrcm +!--- set nrcm if (Model%ras) then Model%nrcm = min(nrcmax, Model%levs-1) * (Model%dtp/1200.d0) + 0.10001d0 else @@ -4469,6 +4318,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- BEGIN CODE FROM COMPNS_PHYSICS !--- shoc scheme if (do_shoc) then + if (Model%imp_physics == Model%imp_physics_thompson) then + print *,'SHOC is not currently compatible with Thompson MP -- shutting down' + stop + endif Model%nshoc_3d = 3 Model%nshoc_2d = 0 Model%shal_cnv = .false. @@ -4482,7 +4335,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' ntke=',Model%ntke,' shoc_parm=',shoc_parm endif -#ifdef CCPP !--- mynn-edmf scheme if (Model%do_mynnedmf) then if (Model%do_shoc .or. Model%hybedmf .or. Model%satmedmf) then @@ -4504,7 +4356,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' bl_mynn_edmf=',Model%bl_mynn_edmf, & ' bl_mynn_output=',Model%bl_mynn_output endif -#endif !--- set number of cloud types if (Model%cscnv) then @@ -4547,16 +4398,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,'iopt_snf = ', Model%iopt_snf print *,'iopt_tbot = ',Model%iopt_tbot print *,'iopt_stc = ', Model%iopt_stc -#ifdef CCPP elseif (Model%lsm == Model%lsm_ruc) then print *,' RUC Land Surface Model used' elseif (Model%lsm == Model%lsm_noah_wrfv4) then print *,' NOAH WRFv4 Land Surface Model used' -#else - elseif (Model%lsm == Model%lsm_ruc) then - print *,' RUC Land Surface Model only available through CCPP - job aborted' - stop -#endif else print *,' Unsupported LSM type - job aborted - lsm=',Model%lsm stop @@ -4583,7 +4428,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' nstf_name(5)=',Model%nstf_name(5) endif if (Model%do_deep) then -#ifdef CCPP ! Consistency check for NTDK convection: deep and shallow convection are bundled ! and cannot be combined with any other deep or shallow convection scheme if ( (Model%imfdeepcnv == Model%imfdeepcnv_ntiedtke .or. Model%imfshalcnv == Model%imfshalcnv_ntiedtke) .and. & @@ -4591,15 +4435,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & write(0,*) "Logic error: if NTDK deep convection is used, must also use NTDK shallow convection (and vice versa)" stop end if -#else - if (Model%imfdeepcnv == 3 .or. Model%imfshalcnv == 3) then - write(0,*) "Error, GF convection scheme only available through CCPP" - stop - else if (Model%imfdeepcnv == 4 .or. Model%imfshalcnv == 4) then - write(0,*) "Error, NTDK convection scheme only available through CCPP" - stop - end if -#endif + if (.not. Model%cscnv) then if (Model%ras) then print *,' RAS Convection scheme used with ccwf=',Model%ccwf @@ -4607,7 +4443,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & else if (Model%imfdeepcnv == 0) then print *,' old SAS Convection scheme before July 2010 used' -#ifdef CCPP elseif(Model%imfdeepcnv == Model%imfdeepcnv_sas) then print *,' July 2010 version of SAS conv scheme used' elseif(Model%imfdeepcnv == Model%imfdeepcnv_samf) then @@ -4616,12 +4451,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' Grell-Freitas scale & aerosol-aware mass-flux deep conv scheme' elseif(Model%imfdeepcnv == Model%imfdeepcnv_ntiedtke) then print *,' New Tiedtke cumulus scheme' -#else - elseif(Model%imfdeepcnv == 1) then - print *,' July 2010 version of SAS conv scheme used' - elseif(Model%imfdeepcnv == 2) then - print *,' scale & aerosol-aware mass-flux deep conv scheme' -#endif endif endif else @@ -4637,29 +4466,19 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print*, ' Deep convection scheme disabled' endif if (Model%satmedmf) then -#ifdef CCPP if (Model%isatmedmf == Model%isatmedmf_vdif) then print *,' initial version (Nov 2018) of sale-aware TKE-based moist EDMF scheme used' elseif(Model%isatmedmf == Model%isatmedmf_vdifq) then print *,' update version (May 2019) of sale-aware TKE-based moist EDMF scheme used' endif -#else - if (Model%isatmedmf == 0) then - print *,' initial version (Nov 2018) of sale-aware TKE-based moist EDMF scheme used' - elseif(Model%isatmedmf == 1) then - print *,' update version (May 2019) of sale-aware TKE-based moist EDMF scheme used' - endif -#endif elseif (Model%hybedmf) then print *,' scale-aware hybrid edmf PBL scheme used' elseif (Model%old_monin) then print *,' old (old_monin) PBL scheme used' -#ifdef CCPP elseif (Model%do_mynnedmf) then print *,' MYNN PBL scheme used' elseif (Model%do_myjpbl)then print *,' MYJ PBL scheme used' -#endif endif if (.not. Model%shal_cnv) then Model%imfshalcnv = -1 @@ -4667,7 +4486,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & else if (Model%imfshalcnv == 0) then print *,' modified Tiedtke eddy-diffusion shallow conv scheme used' -#ifdef CCPP elseif (Model%imfshalcnv == Model%imfshalcnv_sas) then print *,' July 2010 version of mass-flux shallow conv scheme used' elseif (Model%imfshalcnv == Model%imfshalcnv_samf) then @@ -4676,12 +4494,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' Grell-Freitas scale- & aerosol-aware mass-flux shallow conv scheme (2013)' elseif (Model%imfshalcnv == Model%imfshalcnv_ntiedtke) then print *,' New Tiedtke cumulus scheme' -#else - elseif (Model%imfshalcnv == 1) then - print *,' July 2010 version of mass-flux shallow conv scheme used' - elseif (Model%imfshalcnv == 2) then - print *,' scale- & aerosol-aware mass-flux shallow conv scheme (2017)' -#endif else print *,' unknown mass-flux scheme in use - defaulting to no shallow convection' Model%imfshalcnv = -1 @@ -4882,13 +4694,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. -#ifdef CCPP if(Model%do_shoc .or. Model%pdfcld .or. Model%do_mynnedmf) Model%cnvcld = .false. -#else - if(Model%do_shoc .or. Model%pdfcld) Model%cnvcld = .false. -#endif if(Model%cnvcld) Model%ncnvcld3d = 1 +!--- get cnvwind index in phy_f2d; last entry in phy_f2d array + Model%ncnvwind = Model%num_p2d + !--- get cnvw and cnvc indices in phy_f3d Model%ncnvw = -999 Model%ncnvc = -999 @@ -4898,7 +4709,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then Model%ncnvw = Model%num_p3d + 1 endif - + !--- 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 @@ -4915,7 +4726,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%indcld = Model%ntot3d - 2 endif -#ifdef CCPP if (Model%do_shoc) then Model%nkbfshoc = Model%ntot3d !< the index of upward kinematic buoyancy flux from SHOC in phy_f3d Model%nahdshoc = Model%ntot3d-1 !< the index of diffusivity for heat from from SHOC in phy_f3d @@ -4925,7 +4735,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%nahdshoc = -999 Model%nscfshoc = -999 endif -#endif if (me == Model%master) & write(0,*) ' num_p3d=', Model%num_p3d, ' num_p2d=', Model%num_p2d, & @@ -4934,10 +4743,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' 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, & -#ifdef CCPP ' nkbfshoc=', Model%nkbfshoc, ' nahdshoc=', Model%nahdshoc, & ' nscfshoc=', Model%nscfshoc, & -#endif ' uni_cld=', Model%uni_cld, & ' ntot3d=', Model%ntot3d, ' ntot2d=', Model%ntot2d, & ' shocaftcnv=',Model%shocaftcnv,' indcld=', Model%indcld, & @@ -4951,13 +4758,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- set up parameters for Xu & Randall's cloudiness computation (Radiation) Model%lmfshal = (Model%shal_cnv .and. Model%imfshalcnv > 0) -#ifdef CCPP Model%lmfdeep2 = (Model%imfdeepcnv == Model%imfdeepcnv_samf & .or. Model%imfdeepcnv == Model%imfdeepcnv_gf & .or. Model%imfdeepcnv == Model%imfdeepcnv_ntiedtke) -#else - Model%lmfdeep2 = (Model%imfdeepcnv == 2) -#endif !--- END CODE FROM GLOOPR !--- BEGIN CODE FROM GLOOPB @@ -4988,15 +4791,13 @@ subroutine control_print(Model) !--- 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 -#ifdef CCPP print *, ' communicator : ', Model%communicator -#endif print *, ' nlunit : ', Model%nlunit print *, ' fn_nml : ', trim(Model%fn_nml) print *, ' fhzero : ', Model%fhzero @@ -5028,9 +4829,7 @@ subroutine control_print(Model) print *, ' latr : ', Model%latr print *, ' blksz(1) : ', Model%blksz(1) print *, ' blksz(nblks) : ', Model%blksz(Model%nblks) -#ifdef CCPP print *, ' Model%ncols : ', Model%ncols -#endif print *, ' ' print *, 'coupling parameters' print *, ' cplflx : ', Model%cplflx @@ -5054,14 +4853,10 @@ subroutine control_print(Model) print *, ' fhlwr : ', Model%fhlwr print *, ' nsswr : ', Model%nsswr print *, ' nslwr : ', Model%nslwr -#ifdef CCPP print *, ' nhfrad : ', Model%nhfrad -#endif print *, ' levr : ', Model%levr print *, ' nfxr : ', Model%nfxr -#ifdef CCPP print *, ' ntrcaer : ', Model%ntrcaer -#endif print *, ' lmfshal : ', Model%lmfshal print *, ' lmfdeep2 : ', Model%lmfdeep2 print *, ' nrcm : ', Model%nrcm @@ -5086,7 +4881,6 @@ subroutine control_print(Model) print *, ' norad_precip : ', Model%norad_precip print *, ' lwhtr : ', Model%lwhtr print *, ' swhtr : ', Model%swhtr -#ifdef CCPP if (Model%do_RRTMGP) then print *, ' rrtmgp_nrghice : ', Model%rrtmgp_nrghice print *, ' rrtmgp_nrghice : ', Model%rrtmgp_nrghice @@ -5106,8 +4900,8 @@ subroutine control_print(Model) print *, ' doGP_cldoptics_PADE: ', Model%doGP_cldoptics_PADE print *, ' doGP_cldoptics_LUT : ', Model%doGP_cldoptics_LUT print *, ' use_LW_jacobian : ', Model%use_LW_jacobian + print *, ' doGP_lwscat : ', Model%doGP_lwscat endif -#endif print *, ' ' print *, 'microphysical switch' print *, ' ncld : ', Model%ncld @@ -5149,7 +4943,6 @@ subroutine control_print(Model) print *, ' lrefres : ', Model%lrefres print *, ' ' endif -#ifdef CCPP if (Model%imp_physics == Model%imp_physics_fer_hires) then print *, ' Ferrier-Aligo microphysical parameters' print *, ' spec_adv : ', Model%spec_adv @@ -5157,11 +4950,9 @@ subroutine control_print(Model) print *, ' icloud : ', Model%icloud print *, ' ' endif -#endif print *, 'land/surface model parameters' print *, ' lsm : ', Model%lsm print *, ' lsoil : ', Model%lsoil -#ifdef CCPP print *, ' rdlai : ', Model%rdlai print *, ' lsoil_lsm : ', Model%lsoil_lsm print *, ' lsnow_lsm : ', Model%lsnow_lsm @@ -5173,7 +4964,6 @@ subroutine control_print(Model) print *, ' kice : ', Model%kice print *, ' shape(pores) : ', shape(Model%pores) print *, ' shape(resid) : ', shape(Model%resid) -#endif print *, ' ivegsrc : ', Model%ivegsrc print *, ' isot : ', Model%isot @@ -5193,12 +4983,10 @@ subroutine control_print(Model) print *, ' iopt_stc : ', Model%iopt_stc endif print *, ' use_ufo : ', Model%use_ufo -#ifdef CCPP print *, ' lcurr_sf : ', Model%lcurr_sf print *, ' pert_cd : ', Model%pert_cd print *, ' ntsflg : ', Model%ntsflg print *, ' sfenth : ', Model%sfenth -#endif print *, ' ' print *, 'flake model parameters' print *, 'lkm : ', Model%lkm @@ -5227,6 +5015,8 @@ subroutine control_print(Model) print *, ' shocaftcnv : ', Model%shocaftcnv print *, ' shoc_cld : ', Model%shoc_cld print *, ' uni_cld : ', Model%uni_cld + print *, ' oz_phys : ', Model%oz_phys + print *, ' oz_phys_2015 : ', Model%oz_phys_2015 print *, ' h2o_phys : ', Model%h2o_phys print *, ' pdfcld : ', Model%pdfcld print *, ' shcnvcw : ', Model%shcnvcw @@ -5257,7 +5047,6 @@ subroutine control_print(Model) print *, ' dlqf : ', Model%dlqf print *, ' seed0 : ', Model%seed0 print *, ' rbcr : ', Model%rbcr -#ifdef CCPP print *, ' do_mynnedmf : ', Model%do_mynnedmf print *, ' do_mynnsfclay : ', Model%do_mynnsfclay print *, ' do_myjsfc : ', Model%do_myjsfc @@ -5266,16 +5055,17 @@ subroutine control_print(Model) print *, ' gwd_opt : ', Model%gwd_opt print *, ' do_ugwp_v0 : ', Model%do_ugwp_v0 print *, ' do_ugwp_v0_orog_only : ', Model%do_ugwp_v0_orog_only + print *, ' do_ugwp_v0_nst_only : ', Model%do_ugwp_v0_nst_only print *, ' do_gsl_drag_ls_bl : ', Model%do_gsl_drag_ls_bl print *, ' do_gsl_drag_ss : ', Model%do_gsl_drag_ss print *, ' do_gsl_drag_tofd : ', Model%do_gsl_drag_tofd print *, ' do_ugwp_v1 : ', Model%do_ugwp_v1 print *, ' do_ugwp_v1_orog_only : ', Model%do_ugwp_v1_orog_only + print *, ' do_ugwp_v1_w_gsldrag : ', Model%do_ugwp_v1_w_gsldrag print *, ' hurr_pbl : ', Model%hurr_pbl print *, ' var_ric : ', Model%var_ric print *, ' coef_ric_l : ', Model%coef_ric_l print *, ' coef_ric_s : ', Model%coef_ric_s -#endif print *, ' ' print *, 'Rayleigh friction' print *, ' prslrd0 : ', Model%prslrd0 @@ -5359,9 +5149,7 @@ subroutine control_print(Model) print *, 'tracers' print *, ' tracer_names : ', Model%tracer_names print *, ' ntrac : ', Model%ntrac -#ifdef CCPP print *, ' nqrimef : ', Model%nqrimef -#endif print *, ' ntqv : ', Model%ntqv print *, ' ntoz : ', Model%ntoz print *, ' ntcw : ', Model%ntcw @@ -5394,14 +5182,12 @@ subroutine control_print(Model) print *, ' ncnvcld3d : ', Model%ncnvcld3d print *, ' npdf3d : ', Model%npdf3d print *, ' nctp : ', Model%nctp -#ifdef CCPP print *, ' nkbfshoc : ', Model%nkbfshoc print *, ' nahdshoc : ', Model%nahdshoc print *, ' nscfshoc : ', Model%nscfshoc -#endif print *, ' ' print *, 'debug flags' - print *, ' debug : ', Model%debug + print *, ' debug : ', Model%debug print *, ' pre_rad : ', Model%pre_rad print *, ' ' print *, 'variables modified at each time step' @@ -5421,12 +5207,10 @@ subroutine control_print(Model) print *, ' kdt : ', Model%kdt print *, ' jdat : ', Model%jdat print *, ' si : ', Model%si -#ifdef CCPP print *, ' sec : ', Model%sec print *, ' first_time_step : ', Model%first_time_step print *, ' restart : ', Model%restart print *, ' hydrostatic : ', Model%hydrostatic -#endif endif end subroutine control_print @@ -5494,25 +5278,27 @@ subroutine grid_create (Grid, IM, Model) allocate (Grid%iindx1_aer(IM)) allocate (Grid%iindx2_aer(IM)) endif + +!--- Model%do_ugwpv1 + if ( Model%do_ugwp_v1 ) then + allocate (Grid%ddy_j1tau (IM)) + allocate (Grid%ddy_j2tau (IM)) + allocate (Grid%jindx1_tau (IM)) + allocate (Grid%jindx2_tau (IM)) + endif + end subroutine grid_create !-------------------- ! GFS_tbd_type%create !-------------------- -#ifndef CCPP - subroutine tbd_create (Tbd, IM, BLKNO, Model) -#else subroutine tbd_create (Tbd, IM, Model) -#endif implicit none class(GFS_tbd_type) :: Tbd integer, intent(in) :: IM -#ifndef CCPP - integer, intent(in) :: BLKNO -#endif type(GFS_control_type), intent(in) :: Model !--- In @@ -5525,8 +5311,6 @@ subroutine tbd_create (Tbd, IM, Model) endif !--- ozone and stratosphere h2o needs - ! DH* oz_coeff is set to zero if both ozphys options are false, - ! better to use conditional allocations here for ozpl (and h2opl)? *DH allocate (Tbd%ozpl (IM,levozp,oz_coeff)) allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) Tbd%ozpl = clear_val @@ -5544,15 +5328,16 @@ subroutine tbd_create (Tbd, IM, Model) allocate (Tbd%aer_nm (IM,Model%levs,ntrcaer)) Tbd%aer_nm = clear_val -#ifdef CCPP -! DH* TODO - MOVE THIS TO a block-vector dependent structure in GFS_control? -! e.g. GFS_Control%imap(blk), GFS_Control%jmap(blk), or ii instead if imap etc? *DH +!--- tau_amf for NGWs + ! DH* allocate only for UGWP ? *DH + allocate (Tbd%tau_amf(im) ) + Tbd%tau_amf = clear_val + !--- maps of local index ix to global indices i and j for this block allocate (Tbd%imap (IM)) allocate (Tbd%jmap (IM)) Tbd%imap = 0 Tbd%jmap = 0 -#endif allocate (Tbd%rann (IM,Model%nrcm)) Tbd%rann = rann_init @@ -5598,11 +5383,6 @@ subroutine tbd_create (Tbd, IM, Model) allocate (Tbd%hpbl (IM)) Tbd%hpbl = clear_val -#ifndef CCPP - Tbd%blkno = BLKNO -#endif - -#ifdef CCPP if (Model%imfdeepcnv == Model%imfdeepcnv_gf .or. Model%imfdeepcnv == Model%imfdeepcnv_ntiedtke) then allocate(Tbd%forcet(IM, Model%levs)) allocate(Tbd%forceq(IM, Model%levs)) @@ -5647,32 +5427,31 @@ subroutine tbd_create (Tbd, IM, Model) if (Model%do_myjsfc.or.Model%do_myjpbl) then !print*,"Allocating all MYJ surface variables:" allocate (Tbd%phy_myj_qsfc (IM)) - allocate (Tbd%phy_myj_thz0 (IM)) - allocate (Tbd%phy_myj_qz0 (IM)) - allocate (Tbd%phy_myj_uz0 (IM)) - allocate (Tbd%phy_myj_vz0 (IM)) - allocate (Tbd%phy_myj_akhs (IM)) - allocate (Tbd%phy_myj_akms (IM)) - allocate (Tbd%phy_myj_chkqlm (IM)) - allocate (Tbd%phy_myj_elflx (IM)) - allocate (Tbd%phy_myj_a1u (IM)) - allocate (Tbd%phy_myj_a1t (IM)) + allocate (Tbd%phy_myj_thz0 (IM)) + allocate (Tbd%phy_myj_qz0 (IM)) + allocate (Tbd%phy_myj_uz0 (IM)) + allocate (Tbd%phy_myj_vz0 (IM)) + allocate (Tbd%phy_myj_akhs (IM)) + allocate (Tbd%phy_myj_akms (IM)) + allocate (Tbd%phy_myj_chkqlm (IM)) + allocate (Tbd%phy_myj_elflx (IM)) + allocate (Tbd%phy_myj_a1u (IM)) + allocate (Tbd%phy_myj_a1t (IM)) allocate (Tbd%phy_myj_a1q (IM)) !print*,"Allocating all MYJ schemes variables:" - Tbd%phy_myj_qsfc = clear_val - Tbd%phy_myj_thz0 = clear_val - Tbd%phy_myj_qz0 = clear_val - Tbd%phy_myj_uz0 = clear_val - Tbd%phy_myj_vz0 = clear_val - Tbd%phy_myj_akhs = clear_val - Tbd%phy_myj_akms = clear_val - Tbd%phy_myj_chkqlm = clear_val - Tbd%phy_myj_elflx = clear_val - Tbd%phy_myj_a1u = clear_val - Tbd%phy_myj_a1t = clear_val - Tbd%phy_myj_a1q = clear_val + Tbd%phy_myj_qsfc = clear_val + Tbd%phy_myj_thz0 = clear_val + Tbd%phy_myj_qz0 = clear_val + Tbd%phy_myj_uz0 = clear_val + Tbd%phy_myj_vz0 = clear_val + Tbd%phy_myj_akhs = clear_val + Tbd%phy_myj_akms = clear_val + Tbd%phy_myj_chkqlm = clear_val + Tbd%phy_myj_elflx = clear_val + Tbd%phy_myj_a1u = clear_val + Tbd%phy_myj_a1t = clear_val + Tbd%phy_myj_a1q = clear_val end if -#endif end subroutine tbd_create @@ -5689,13 +5468,13 @@ subroutine cldprop_create (Cldprop, IM, Model) type(GFS_control_type), intent(in) :: Model allocate (Cldprop%cv (IM)) - allocate (Cldprop%cvt (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 @@ -5703,14 +5482,14 @@ 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) + !--- Out (radiation only) allocate (Radtend%sfcfsw (IM)) allocate (Radtend%sfcflw (IM)) @@ -5722,7 +5501,7 @@ subroutine radtend_create (Radtend, IM, Model) 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)) @@ -5736,12 +5515,12 @@ subroutine radtend_create (Radtend, IM, Model) 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)) @@ -5833,9 +5612,7 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%dlwsfci (IM)) allocate (Diag%ulwsfci (IM)) allocate (Diag%dswsfci (IM)) -#ifdef CCPP allocate (Diag%nswsfci (IM)) -#endif allocate (Diag%uswsfci (IM)) allocate (Diag%dusfci (IM)) allocate (Diag%dvsfci (IM)) @@ -5857,28 +5634,23 @@ subroutine diag_create (Diag, IM, Model) 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)) + allocate (Diag%zmtnblck(IM)) allocate (Diag%ca1 (IM)) allocate (Diag%ca2 (IM)) allocate (Diag%ca3 (IM)) ! F-A MP scheme -#ifdef CCPP if (Model%imp_physics == Model%imp_physics_fer_hires) then - allocate (Diag%TRAIN (IM,Model%levs)) + allocate (Diag%train (IM,Model%levs)) end if -#endif - -#ifdef CCPP allocate (Diag%cldfra (IM,Model%levs)) -#endif allocate (Diag%ca_deep (IM)) allocate (Diag%ca_turb (IM)) allocate (Diag%ca_shal (IM)) - allocate (Diag%ca_rad (IM)) - allocate (Diag%ca_micro (IM)) - + allocate (Diag%ca_rad (IM)) + allocate (Diag%ca_micro (IM)) + !--- 3D diagnostics if (Model%ldiag3d) then allocate (Diag%du3dt (IM,Model%levs,8)) @@ -5886,83 +5658,76 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%dt3dt (IM,Model%levs,11)) if (Model%qdiag3d) then allocate (Diag%dq3dt (IM,Model%levs,13)) + else + allocate (Diag%dq3dt (1,1,13)) endif -!--- 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)) + else + allocate (Diag%du3dt (1,1,8)) + allocate (Diag%dv3dt (1,1,8)) + allocate (Diag%dt3dt (1,1,11)) + allocate (Diag%dq3dt (1,1,13)) endif -!vay-2018 +! UGWP + allocate (Diag%zmtb (IM) ) + allocate (Diag%zogw (IM) ) + allocate (Diag%zlwb (IM) ) + allocate (Diag%tau_ogw (IM) ) + allocate (Diag%tau_ngw (IM) ) + allocate (Diag%tau_mtb (IM) ) + allocate (Diag%tau_tofd (IM) ) + allocate (Diag%dudt_gw (IM,Model%levs)) + allocate (Diag%dvdt_gw (IM,Model%levs)) + allocate (Diag%dtdt_gw (IM,Model%levs)) + allocate (Diag%kdis_gw (IM,Model%levs)) + if (Model%ldiag_ugwp) then allocate (Diag%du3dt_dyn (IM,Model%levs) ) - allocate (Diag%du3dt_pbl (IM,Model%levs) ) allocate (Diag%dv3dt_pbl (IM,Model%levs) ) allocate (Diag%dt3dt_pbl (IM,Model%levs) ) - allocate (Diag%du3dt_ogw (IM,Model%levs) ) allocate (Diag%dv3dt_ogw (IM,Model%levs) ) allocate (Diag%dt3dt_ogw (IM,Model%levs) ) - allocate (Diag%du3dt_mtb (IM,Model%levs) ) allocate (Diag%dv3dt_mtb (IM,Model%levs) ) allocate (Diag%dt3dt_mtb (IM,Model%levs) ) - allocate (Diag%du3dt_tms (IM,Model%levs) ) allocate (Diag%dv3dt_tms (IM,Model%levs) ) allocate (Diag%dt3dt_tms (IM,Model%levs) ) - allocate (Diag%du3dt_ngw (IM,Model%levs) ) allocate (Diag%dv3dt_ngw (IM,Model%levs) ) allocate (Diag%dt3dt_ngw (IM,Model%levs) ) - allocate (Diag%du3dt_cgw (IM,Model%levs) ) allocate (Diag%dv3dt_cgw (IM,Model%levs) ) - allocate (Diag%dt3dt_moist (IM,Model%levs) ) - + allocate (Diag%dt3dt_moist (IM,Model%levs)) allocate (Diag%dudt_tot (IM,Model%levs) ) allocate (Diag%dvdt_tot (IM,Model%levs) ) allocate (Diag%dtdt_tot (IM,Model%levs) ) - - allocate (Diag%uav_ugwp (IM,Model%levs) ) - allocate (Diag%tav_ugwp (IM,Model%levs) ) + allocate (Diag%uav_ugwp (IM,Model%levs) ) + allocate (Diag%tav_ugwp (IM,Model%levs) ) endif - allocate (Diag%zmtb (IM) ) - allocate (Diag%zogw (IM) ) - allocate (Diag%zlwb (IM) ) - allocate (Diag%tau_ogw (IM) ) - allocate (Diag%tau_ngw (IM) ) - allocate (Diag%tau_mtb (IM) ) - allocate (Diag%tau_tofd (IM) ) -! endif - -! -!ugwp - instant -! - if (Model%do_ugwp) then - allocate (Diag%gwp_ax (IM,Model%levs) ) - allocate (Diag%gwp_ay (IM,Model%levs) ) - allocate (Diag%gwp_dtdt(IM,Model%levs) ) - allocate (Diag%gwp_kdis(IM,Model%levs) ) - - allocate (Diag%gwp_axo (IM,Model%levs) ) - allocate (Diag%gwp_ayo (IM,Model%levs) ) - allocate (Diag%gwp_axc (IM,Model%levs) ) - allocate (Diag%gwp_ayc (IM,Model%levs) ) - allocate (Diag%gwp_axf (IM,Model%levs) ) - allocate (Diag%gwp_ayf (IM,Model%levs) ) -!GW-sources - allocate (Diag%gwp_dcheat(IM,Model%levs) ) - allocate (Diag%gwp_scheat(IM,Model%levs) ) - allocate (Diag%gwp_fgf (IM ) ) - allocate (Diag%gwp_okw (IM ) ) - - allocate (Diag%gwp_precip(IM) ) - allocate (Diag%gwp_klevs (IM, 3) ) - - endif + if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + allocate (Diag%dudt_ogw (IM,Model%levs)) + allocate (Diag%dvdt_ogw (IM,Model%levs)) + allocate (Diag%dudt_obl (IM,Model%levs)) + allocate (Diag%dvdt_obl (IM,Model%levs)) + allocate (Diag%dudt_oss (IM,Model%levs)) + allocate (Diag%dvdt_oss (IM,Model%levs)) + allocate (Diag%dudt_ofd (IM,Model%levs)) + allocate (Diag%dvdt_ofd (IM,Model%levs)) + allocate (Diag%du_ogwcol (IM) ) + allocate (Diag%dv_ogwcol (IM) ) + allocate (Diag%du_oblcol (IM) ) + allocate (Diag%dv_oblcol (IM) ) + allocate (Diag%du_osscol (IM) ) + allocate (Diag%dv_osscol (IM) ) + allocate (Diag%du_ofdcol (IM) ) + allocate (Diag%dv_ofdcol (IM) ) + else + allocate (Diag%dudt_ogw (IM,Model%levs)) + end if !--- 3D diagnostics for Thompson MP / GFDL MP allocate (Diag%refl_10cm(IM,Model%levs)) @@ -5975,7 +5740,6 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%rh02max(IM)) allocate (Diag%rh02min(IM)) -#ifdef CCPP !--- MYNN variables: if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then @@ -6014,44 +5778,6 @@ subroutine diag_create (Diag, IM, Model) Diag%exch_m = clear_val endif - !--- Drag Suite variables: - if (Model%gwd_opt == 33 .or. Model%gwd_opt == 22) then - !print*,"Allocating all Drag Suite variables:" - allocate (Diag%dtaux2d_ls (IM,Model%levs)) - allocate (Diag%dtauy2d_ls (IM,Model%levs)) - allocate (Diag%dtaux2d_bl (IM,Model%levs)) - allocate (Diag%dtauy2d_bl (IM,Model%levs)) - allocate (Diag%dtaux2d_ss (IM,Model%levs)) - allocate (Diag%dtauy2d_ss (IM,Model%levs)) - allocate (Diag%dtaux2d_fd (IM,Model%levs)) - allocate (Diag%dtauy2d_fd (IM,Model%levs)) - Diag%dtaux2d_ls = clear_val - Diag%dtauy2d_ls = clear_val - Diag%dtaux2d_bl = clear_val - Diag%dtauy2d_bl = clear_val - Diag%dtaux2d_ss = clear_val - Diag%dtauy2d_ss = clear_val - Diag%dtaux2d_fd = clear_val - Diag%dtauy2d_fd = clear_val - allocate (Diag%dusfc_ls (IM)) - allocate (Diag%dvsfc_ls (IM)) - allocate (Diag%dusfc_bl (IM)) - allocate (Diag%dvsfc_bl (IM)) - allocate (Diag%dusfc_ss (IM)) - allocate (Diag%dvsfc_ss (IM)) - allocate (Diag%dusfc_fd (IM)) - allocate (Diag%dvsfc_fd (IM)) - Diag%dusfc_ls = 0 - Diag%dvsfc_ls = 0 - Diag%dusfc_bl = 0 - Diag%dvsfc_bl = 0 - Diag%dusfc_ss = 0 - Diag%dvsfc_ss = 0 - Diag%dusfc_fd = 0 - Diag%dvsfc_fd = 0 - endif -#endif - ! Auxiliary arrays in output for debugging if (Model%naux2d>0) then allocate (Diag%aux2d(IM,Model%naux2d)) @@ -6155,9 +5881,7 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%dlwsfci = zero Diag%ulwsfci = zero Diag%dswsfci = zero -#ifdef CCPP Diag%nswsfci = zero -#endif Diag%uswsfci = zero Diag%dusfci = zero Diag%dvsfci = zero @@ -6181,22 +5905,17 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%shum_wts = zero Diag%zmtnblck = zero -#ifdef CCPP if (Model%imp_physics == Model%imp_physics_fer_hires) then - Diag%TRAIN = zero + Diag%train = zero end if -#endif -#ifdef CCPP Diag%cldfra = zero -#endif Diag%totprcpb = zero Diag%cnvprcpb = zero Diag%toticeb = zero Diag%totsnwb = zero Diag%totgrpb = zero -! -#ifdef CCPP + !--- MYNN variables: if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then @@ -6217,8 +5936,7 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%exch_h = clear_val Diag%exch_m = clear_val endif -#endif -! + if (Model%do_ca) then Diag%ca1 = zero Diag%ca2 = zero @@ -6244,69 +5962,69 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) endif ! -!----------------------------- - if (Model%ldiag_ugwp) then - if(Model%me == Model%master) print *,'VAY in diag_phys_zero at kdt=',Model%kdt, Model%ldiag_ugwp +! UGWP + Diag%zmtb = zero + Diag%zogw = zero + Diag%zlwb = zero + Diag%tau_mtb = zero + Diag%tau_ogw = zero + Diag%tau_ngw = zero + Diag%tau_tofd = zero + Diag%dudt_gw = zero + Diag%dvdt_gw = zero + Diag%dtdt_gw = zero + Diag%kdis_gw = zero + + if (Model%do_ugwp_v1 .or. Model%gwd_opt==33 .or. Model%gwd_opt==22) then + Diag%dudt_ogw = zero + Diag%dvdt_ogw = zero + Diag%dudt_obl = zero + Diag%dvdt_obl = zero + Diag%dudt_oss = zero + Diag%dvdt_oss = zero + Diag%dudt_ofd = zero + Diag%dvdt_ofd = zero + Diag%du_ogwcol = zero + Diag%dv_ogwcol = zero + Diag%du_oblcol = zero + Diag%dv_oblcol = zero + Diag%du_osscol = zero + Diag%dv_osscol = zero + Diag%du_ofdcol = zero + Diag%dv_ofdcol = zero + else + Diag%dudt_ogw = zero + end if + + if (Model%ldiag_ugwp) then Diag%du3dt_pbl = zero Diag%dv3dt_pbl = zero Diag%dt3dt_pbl = zero -! Diag%du3dt_ogw = zero Diag%dv3dt_ogw = zero Diag%dt3dt_ogw = zero - Diag%du3dt_mtb = zero Diag%dv3dt_mtb = zero Diag%dt3dt_mtb = zero - Diag%du3dt_tms = zero Diag%dv3dt_tms = zero Diag%dt3dt_tms = zero - Diag%du3dt_ngw = zero Diag%dv3dt_ngw = zero Diag%dt3dt_ngw = zero - Diag%du3dt_moist = zero Diag%dv3dt_moist = zero Diag%dt3dt_moist = zero - Diag%dudt_tot = zero Diag%dvdt_tot = zero Diag%dtdt_tot = zero - Diag%uav_ugwp = zero Diag%tav_ugwp = zero !COORDE Diag%du3dt_dyn = zero - Diag%zmtb = zero - Diag%zogw = zero - Diag%zlwb = zero - - Diag%tau_mtb = zero - Diag%tau_ogw = zero - Diag%tau_ngw = zero - Diag%tau_tofd = zero endif + ! - if (Model%do_ugwp) then - Diag%gwp_ax = zero - Diag%gwp_ay = zero - Diag%gwp_dtdt = zero - Diag%gwp_kdis = zero - Diag%gwp_axo = zero - Diag%gwp_ayo = zero - Diag%gwp_axc = zero - Diag%gwp_ayc = zero - Diag%gwp_axf = zero - Diag%gwp_ayf = zero - Diag%gwp_dcheat = zero - Diag%gwp_scheat = zero - Diag%gwp_precip = zero - Diag%gwp_klevs = -99 - Diag%gwp_fgf = zero - Diag%gwp_okw = zero - endif !----------------------------- ! max hourly diagnostics @@ -6349,9 +6067,7 @@ subroutine diag_chem_init(Diag, IM, Model) if (Model%ntchm > 0) then ! -- retrieve number of dust bins n = get_number_bins('dust') -#ifdef CCPP Diag%ndust = n -#endif if (n > 0) then allocate (Diag%duem(IM,n)) Diag%duem = zero @@ -6359,9 +6075,7 @@ subroutine diag_chem_init(Diag, IM, Model) ! -- retrieve number of sea salt bins n = get_number_bins('seas') -#ifdef CCPP Diag%nseasalt = n -#endif if (n > 0) then allocate (Diag%ssem(IM,n)) Diag%ssem = zero @@ -6372,9 +6086,8 @@ subroutine diag_chem_init(Diag, IM, Model) if (associated(Model%ntdiag)) then ! -- get number of tracers with enabled diagnostics n = count(Model%ntdiag) -#ifdef CCPP Diag%ntchmdiag = n -#endif + ! -- initialize sedimentation allocate (Diag%sedim(IM,n)) Diag%sedim = zero @@ -6432,7 +6145,6 @@ end function get_number_bins end subroutine diag_chem_init -#ifdef CCPP !------------------------- ! GFS_interstitial_type%create !------------------------- @@ -6564,7 +6276,6 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%gflx_ocean (IM)) allocate (Interstitial%gwdcu (IM,Model%levs)) allocate (Interstitial%gwdcv (IM,Model%levs)) - allocate (Interstitial%h2o_pres (levh2o)) allocate (Interstitial%hefac (IM)) allocate (Interstitial%hffac (IM)) allocate (Interstitial%hflxq (IM)) @@ -6593,7 +6304,6 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%oa4 (IM,4)) allocate (Interstitial%oc (IM)) allocate (Interstitial%olyr (IM,Model%levr+LTP)) - allocate (Interstitial%oz_pres (levozp)) allocate (Interstitial%plvl (IM,Model%levr+1+LTP)) allocate (Interstitial%plyr (IM,Model%levr+LTP)) allocate (Interstitial%prnum (IM,Model%levs)) @@ -6682,10 +6392,6 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%zt1d (IM)) ! RRTMGP - allocate (Interstitial%fluxlwDOWN_jac (IM, Model%levs+1)) - allocate (Interstitial%fluxlwUP_jac (IM, Model%levs+1)) - allocate (Interstitial%sktp1r (IM)) - allocate (Interstitial%fluxlwUP_allsky (IM, Model%levs+1)) if (Model%do_RRTMGP) then allocate (Interstitial%tracer (IM, Model%levs,Model%ntrac)) allocate (Interstitial%tv_lay (IM, Model%levs)) @@ -6701,11 +6407,12 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%precip_overlap_param (IM, Model%levs)) allocate (Interstitial%fluxlwDOWN_allsky (IM, Model%levs+1)) allocate (Interstitial%fluxlwUP_clrsky (IM, Model%levs+1)) + allocate (Interstitial%fluxlwUP_allsky (IM, Model%levs+1)) allocate (Interstitial%fluxlwDOWN_clrsky (IM, Model%levs+1)) allocate (Interstitial%fluxswUP_allsky (IM, Model%levs+1)) allocate (Interstitial%fluxswDOWN_allsky (IM, Model%levs+1)) allocate (Interstitial%fluxswUP_clrsky (IM, Model%levs+1)) - allocate (Interstitial%fluxswDOWN_clrsky (IM, Model%levs+1)) + allocate (Interstitial%fluxswDOWN_clrsky (IM, Model%levs+1)) allocate (Interstitial%aerosolslw (IM, Model%levs, Model%rrtmgp_nBandsLW, NF_AELW)) allocate (Interstitial%aerosolssw (IM, Model%levs, Model%rrtmgp_nBandsSW, NF_AESW)) allocate (Interstitial%cld_frac (IM, Model%levs)) @@ -6719,7 +6426,7 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%cld_rerain (IM, Model%levs)) allocate (Interstitial%precip_frac (IM, Model%levs)) allocate (Interstitial%icseed_lw (IM)) - allocate (Interstitial%icseed_sw (IM)) + allocate (Interstitial%icseed_sw (IM)) allocate (Interstitial%flxprf_lw (IM, Model%levs+1)) allocate (Interstitial%flxprf_sw (IM, Model%levs+1)) allocate (Interstitial%sfc_emiss_byband (Model%rrtmgp_nBandsLW,IM)) @@ -6732,21 +6439,28 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%toa_src_lw (IM,Model%rrtmgp_nGptsLW)) allocate (Interstitial%active_gases_array (Model%nGases)) end if -! CIRES UGWP v0 - allocate (Interstitial%gw_dudt (IM,Model%levs)) - allocate (Interstitial%gw_dvdt (IM,Model%levs)) - allocate (Interstitial%gw_dtdt (IM,Model%levs)) - allocate (Interstitial%gw_kdis (IM,Model%levs)) + +! UGWP common allocate (Interstitial%tau_mtb (IM)) allocate (Interstitial%tau_ogw (IM)) allocate (Interstitial%tau_tofd (IM)) allocate (Interstitial%tau_ngw (IM)) - allocate (Interstitial%zmtb (IM)) - allocate (Interstitial%zlwb (IM)) - allocate (Interstitial%zogw (IM)) + allocate (Interstitial%tau_oss (IM)) allocate (Interstitial%dudt_mtb (IM,Model%levs)) - allocate (Interstitial%dudt_ogw (IM,Model%levs)) allocate (Interstitial%dudt_tms (IM,Model%levs)) + allocate (Interstitial%zmtb (IM) ) + allocate (Interstitial%zlwb (IM) ) + allocate (Interstitial%zogw (IM) ) + allocate (Interstitial%zngw (IM) ) + +! CIRES UGWP v1 + if (Model%do_ugwp_v1) then + allocate (Interstitial%dudt_ngw (IM,Model%levs)) + allocate (Interstitial%dvdt_ngw (IM,Model%levs)) + allocate (Interstitial%dtdt_ngw (IM,Model%levs)) + allocate (Interstitial%kdis_ngw (IM,Model%levs)) + end if + !-- GSL drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then @@ -6842,23 +6556,18 @@ subroutine interstitial_create (Interstitial, IM, Model) Interstitial%ipr = min(IM,10) Interstitial%latidxprnt = 1 Interstitial%levi = Model%levs+1 - Interstitial%levh2o = levh2o - Interstitial%levozp = levozp Interstitial%lmk = Model%levr+LTP Interstitial%lmp = Model%levr+1+LTP - Interstitial%h2o_coeff = h2o_coeff Interstitial%nbdlw = NBDLW Interstitial%nbdsw = NBDSW Interstitial%nf_aelw = NF_AELW Interstitial%nf_aesw = NF_AESW Interstitial%nspc1 = NSPC1 - Interstitial%oz_coeff = oz_coeff - Interstitial%oz_coeffp5 = oz_coeff+5 - ! h2o_pres and oz_pres do not change during the run, but - ! need to be set later in GFS_phys_time_vary_init (after - ! h2o_pres/oz_pres are read in read_h2odata/read_o3data) - Interstitial%h2o_pres = clear_val - Interstitial%oz_pres = clear_val + if (Model%oz_phys .or. Model%oz_phys_2015) then + Interstitial%oz_coeffp5 = oz_coeff+5 + else + Interstitial%oz_coeffp5 = 5 + endif ! Interstitial%skip_macro = .false. ! The value phys_hydrostatic from dynamics does not match the @@ -7092,6 +6801,7 @@ subroutine interstitial_rad_reset (Interstitial, Model) end if if (Model%do_RRTMGP) then + Interstitial%fluxlwUP_allsky = clear_val Interstitial%tracer = clear_val Interstitial%tv_lay = clear_val Interstitial%relhum = clear_val @@ -7106,7 +6816,7 @@ subroutine interstitial_rad_reset (Interstitial, Model) Interstitial%precip_overlap_param = clear_val Interstitial%fluxlwDOWN_allsky = clear_val Interstitial%fluxlwUP_clrsky = clear_val - Interstitial%fluxlwDOWN_clrsky = clear_val + Interstitial%fluxlwDOWN_clrsky = clear_val Interstitial%fluxswUP_allsky = clear_val Interstitial%fluxswDOWN_allsky = clear_val Interstitial%fluxswUP_clrsky = clear_val @@ -7342,21 +7052,26 @@ subroutine interstitial_phys_reset (Interstitial, Model) Interstitial%zorl_land = huge Interstitial%zorl_ocean = huge Interstitial%zt1d = clear_val -! CIRES UGWP v0 - Interstitial%gw_dudt = clear_val - Interstitial%gw_dvdt = clear_val - Interstitial%gw_dtdt = clear_val - Interstitial%gw_kdis = clear_val + +! UGWP common Interstitial%tau_mtb = clear_val Interstitial%tau_ogw = clear_val Interstitial%tau_tofd = clear_val Interstitial%tau_ngw = clear_val + Interstitial%tau_oss = clear_val Interstitial%zmtb = clear_val Interstitial%zlwb = clear_val Interstitial%zogw = clear_val - Interstitial%dudt_mtb = clear_val - Interstitial%dudt_ogw = clear_val - Interstitial%dudt_tms = clear_val + Interstitial%zngw = clear_val + +! CIRES UGWP v1 + if (Model%do_ugwp_v1) then + Interstitial%dudt_ngw = clear_val + Interstitial%dvdt_ngw = clear_val + Interstitial%dtdt_ngw = clear_val + Interstitial%kdis_ngw = clear_val + end if + !-- GSL drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22) then @@ -7463,14 +7178,10 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) ! Print static variables write (0,'(a,3i6)') 'Interstitial_print for mpirank, omprank, blkno: ', mpirank, omprank, blkno write (0,*) 'Interstitial_print: values that do not change' - write (0,*) 'Interstitial%h2o_coeff = ', Interstitial%h2o_coeff - write (0,*) 'sum(Interstitial%h2o_pres) = ', sum(Interstitial%h2o_pres) write (0,*) 'Interstitial%ipr = ', Interstitial%ipr write (0,*) 'Interstitial%itc = ', Interstitial%itc write (0,*) 'Interstitial%latidxprnt = ', Interstitial%latidxprnt write (0,*) 'Interstitial%levi = ', Interstitial%levi - write (0,*) 'Interstitial%levh2o = ', Interstitial%levh2o - write (0,*) 'Interstitial%levozp = ', Interstitial%levozp write (0,*) 'Interstitial%lmk = ', Interstitial%lmk write (0,*) 'Interstitial%lmp = ', Interstitial%lmp write (0,*) 'Interstitial%nbdlw = ', Interstitial%nbdlw @@ -7482,8 +7193,6 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) write (0,*) 'Interstitial%nspc1 = ', Interstitial%nspc1 write (0,*) 'Interstitial%ntiwx = ', Interstitial%ntiwx write (0,*) 'Interstitial%nvdiff = ', Interstitial%nvdiff - write (0,*) 'Interstitial%oz_coeff = ', Interstitial%oz_coeff - write (0,*) 'sum(Interstitial%oz_pres) = ', sum(Interstitial%oz_pres) write (0,*) 'Interstitial%phys_hydrostatic = ', Interstitial%phys_hydrostatic write (0,*) 'Interstitial%skip_macro = ', Interstitial%skip_macro write (0,*) 'Interstitial%trans_aero = ', Interstitial%trans_aero @@ -7730,21 +7439,27 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) write (0,*) 'sum(Interstitial%zorl_land ) = ', sum(Interstitial%zorl_land ) write (0,*) 'sum(Interstitial%zorl_ocean ) = ', sum(Interstitial%zorl_ocean ) write (0,*) 'sum(Interstitial%zt1d ) = ', sum(Interstitial%zt1d ) -! CIRES UGWP v0 - write (0,*) 'sum(Interstitial%gw_dudt ) = ', sum(Interstitial%gw_dudt ) - write (0,*) 'sum(Interstitial%gw_dvdt ) = ', sum(Interstitial%gw_dvdt ) - write (0,*) 'sum(Interstitial%gw_dtdt ) = ', sum(Interstitial%gw_dtdt ) - write (0,*) 'sum(Interstitial%gw_kdis ) = ', sum(Interstitial%gw_kdis ) - write (0,*) 'sum(Interstitial%tau_mtb ) = ', sum(Interstitial%tau_mtb ) - write (0,*) 'sum(Interstitial%tau_ogw ) = ', sum(Interstitial%tau_ogw ) - write (0,*) 'sum(Interstitial%tau_tofd ) = ', sum(Interstitial%tau_tofd ) - write (0,*) 'sum(Interstitial%tau_ngw ) = ', sum(Interstitial%tau_ngw ) - write (0,*) 'sum(Interstitial%zmtb ) = ', sum(Interstitial%zmtb ) - write (0,*) 'sum(Interstitial%zlwb ) = ', sum(Interstitial%zlwb ) - write (0,*) 'sum(Interstitial%zogw ) = ', sum(Interstitial%zogw ) - write (0,*) 'sum(Interstitial%dudt_mtb ) = ', sum(Interstitial%dudt_mtb ) - write (0,*) 'sum(Interstitial%dudt_ogw ) = ', sum(Interstitial%dudt_ogw ) - write (0,*) 'sum(Interstitial%dudt_tms ) = ', sum(Interstitial%dudt_tms ) + +! UGWP common + write (0,*) 'sum(Interstitial%tau_mtb ) = ', sum(Interstitial%tau_mtb ) + write (0,*) 'sum(Interstitial%tau_ogw ) = ', sum(Interstitial%tau_ogw ) + write (0,*) 'sum(Interstitial%tau_tofd ) = ', sum(Interstitial%tau_tofd ) + write (0,*) 'sum(Interstitial%tau_ngw ) = ', sum(Interstitial%tau_ngw ) + write (0,*) 'sum(Interstitial%tau_oss ) = ', sum(Interstitial%tau_oss ) + write (0,*) 'sum(Interstitial%dudt_mtb ) = ', sum(Interstitial%dudt_mtb ) + write (0,*) 'sum(Interstitial%dudt_tms ) = ', sum(Interstitial%dudt_tms ) + write (0,*) 'sum(Interstitial%zmtb ) = ', sum(Interstitial%zmtb ) + write (0,*) 'sum(Interstitial%zlwb ) = ', sum(Interstitial%zlwb ) + write (0,*) 'sum(Interstitial%zogw ) = ', sum(Interstitial%zogw ) + write (0,*) 'sum(Interstitial%zngw ) = ', sum(Interstitial%zngw ) + +! UGWP v1 + if (Model%do_ugwp_v1) then + write (0,*) 'sum(Interstitial%dudt_ngw ) = ', sum(Interstitial%dudt_ngw ) + write (0,*) 'sum(Interstitial%dvdt_ngw ) = ', sum(Interstitial%dvdt_ngw ) + write (0,*) 'sum(Interstitial%dtdt_ngw ) = ', sum(Interstitial%dtdt_ngw ) + write (0,*) 'sum(Interstitial%kdis_ngw ) = ', sum(Interstitial%kdis_ngw ) + end if !-- GSL drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22) then @@ -7865,6 +7580,5 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) write (0,*) 'Interstitial_print: end' ! end subroutine interstitial_print -#endif end module GFS_typedefs diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta similarity index 96% rename from gfsphysics/GFS_layer/GFS_typedefs.meta rename to ccpp/data/GFS_typedefs.meta index dcacc8644..f39248d4c 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_statein_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_statein_type @@ -20,6 +20,13 @@ dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) type = real kind = kind_phys +[prsi(:,1)] + standard_name = air_pressure_at_lowest_model_interface + long_name = air pressure at lowest model interface + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [prsik] standard_name = dimensionless_exner_function_at_model_interfaces long_name = dimensionless Exner function at model layer interfaces @@ -266,7 +273,7 @@ [ccpp-table-properties] name = GFS_stateout_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_stateout_type @@ -447,7 +454,7 @@ [ccpp-table-properties] name = GFS_sfcprop_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_sfcprop_type @@ -962,7 +969,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tvxy] standard_name = vegetation_temperature long_name = vegetation temperature @@ -970,7 +977,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tgxy] standard_name = ground_temperature_for_noahmp long_name = ground temperature for noahmp @@ -978,7 +985,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [canicexy] standard_name = canopy_intercepted_ice_mass long_name = canopy intercepted ice mass @@ -986,7 +993,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [canliqxy] standard_name = canopy_intercepted_liquid_water long_name = canopy intercepted liquid water @@ -994,7 +1001,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [eahxy] standard_name = canopy_air_vapor_pressure long_name = canopy air vapor pressure @@ -1002,7 +1009,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tahxy] standard_name = canopy_air_temperature long_name = canopy air temperature @@ -1010,7 +1017,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [cmxy] standard_name = surface_drag_coefficient_for_momentum_for_noahmp long_name = surface drag coefficient for momentum for noahmp @@ -1018,7 +1025,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [chxy] standard_name = surface_drag_coefficient_for_heat_and_moisture_for_noahmp long_name = surface exchange coeff heat & moisture for noahmp @@ -1026,7 +1033,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [fwetxy] standard_name = area_fraction_of_wet_canopy long_name = area fraction of canopy that is wetted/snowed @@ -1034,7 +1041,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [sneqvoxy] standard_name = snow_mass_at_previous_time_step long_name = snow mass at previous time step @@ -1042,7 +1049,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [alboldxy] standard_name = snow_albedo_at_previous_time_step long_name = snow albedo at previous time step @@ -1050,7 +1057,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [qsnowxy] standard_name = snow_precipitation_rate_at_surface long_name = snow precipitation rate at surface @@ -1058,7 +1065,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [wslakexy] standard_name = lake_water_storage long_name = lake water storage @@ -1066,7 +1073,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [zwtxy] standard_name = water_table_depth long_name = water table depth @@ -1074,7 +1081,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [waxy] standard_name = water_storage_in_aquifer long_name = water storage in aquifer @@ -1082,7 +1089,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [wtxy] standard_name = water_storage_in_aquifer_and_saturated_soil long_name = water storage in aquifer and saturated soil @@ -1090,7 +1097,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tsnoxy] standard_name = snow_temperature long_name = snow_temperature @@ -1098,7 +1105,7 @@ dimensions = (horizontal_loop_extent, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [zsnsoxy] standard_name = layer_bottom_depth_from_snow_surface long_name = depth from the top of the snow surface at the bottom of the layer @@ -1106,7 +1113,7 @@ dimensions = (horizontal_loop_extent, lower_bound_of_snow_vertical_dimension_for_land_surface_model:soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [snicexy] standard_name = snow_layer_ice long_name = snow layer ice @@ -1114,7 +1121,7 @@ dimensions = (horizontal_loop_extent, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [snliqxy] standard_name = snow_layer_liquid_water long_name = snow layer liquid water @@ -1122,7 +1129,7 @@ dimensions = (horizontal_loop_extent, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [lfmassxy] standard_name = leaf_mass long_name = leaf mass @@ -1130,7 +1137,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [rtmassxy] standard_name = fine_root_mass long_name = fine root mass @@ -1138,7 +1145,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [stmassxy] standard_name = stem_mass long_name = stem mass @@ -1146,7 +1153,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [woodxy] standard_name = wood_mass long_name = wood mass including woody roots @@ -1154,7 +1161,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [stblcpxy] standard_name = slow_soil_pool_mass_content_of_carbon long_name = stable carbon in deep soil @@ -1162,7 +1169,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [fastcpxy] standard_name = fast_soil_pool_mass_content_of_carbon long_name = short-lived carbon in shallow soil @@ -1170,10 +1177,10 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [xlaixy] standard_name = leaf_area_index - long_name = leaf area index + long_name = leaf area index units = none dimensions = (horizontal_loop_extent) type = real @@ -1181,12 +1188,12 @@ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme .or. (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .and. flag_for_reading_leaf_area_index_from_input)) [xsaixy] standard_name = stem_area_index - long_name = stem area index + long_name = stem area index units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [taussxy] standard_name = nondimensional_snow_age long_name = non-dimensional snow age @@ -1194,7 +1201,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [smoiseq] standard_name = equilibrium_soil_water_content long_name = equilibrium soil water content @@ -1202,7 +1209,7 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [smcwtdxy] standard_name = soil_water_content_between_soil_bottom_and_water_table long_name = soil water content between the bottom of the soil and the water table @@ -1210,7 +1217,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [deeprechxy] standard_name = water_table_recharge_when_deep long_name = recharge to or from the water table when deep @@ -1218,7 +1225,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [rechxy] standard_name = water_table_recharge_when_shallow long_name = recharge to or from the water table when shallow @@ -1242,7 +1249,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [sh2o] standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model long_name = volume fraction of unfrozen soil moisture for lsm @@ -1250,7 +1257,7 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [keepsmfr] standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model long_name = volume fraction of frozen soil moisture for lsm @@ -1258,7 +1265,7 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [smois] standard_name = volume_fraction_of_soil_moisture_for_land_surface_model long_name = volumetric fraction of soil moisture for lsm @@ -1266,7 +1273,7 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [tslb] standard_name = soil_temperature_for_land_surface_model long_name = soil temperature for land surface model @@ -1290,7 +1297,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [qwv_surf_land] standard_name = water_vapor_mixing_ratio_at_surface_over_land long_name = water vapor mixing ratio at surface over land @@ -1306,7 +1313,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [flag_frsoil] standard_name = flag_for_frozen_soil_physics long_name = flag for frozen soil physics (RUC) @@ -1314,7 +1321,7 @@ dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [rhofr] standard_name = density_of_frozen_precipitation long_name = density of frozen precipitation @@ -1322,7 +1329,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [tsnow_land] standard_name = snow_temperature_bottom_first_layer_over_land long_name = snow temperature at the bottom of the first snow layer over land @@ -1338,7 +1345,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [snowfallac_land] standard_name = total_accumulated_snowfall_over_land long_name = run-total snow accumulation on the ground @@ -1354,7 +1361,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [ustm] standard_name = surface_friction_velocity_drag long_name = friction velocity isolated for momentum only @@ -1495,7 +1502,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [drainncprv] standard_name = explicit_rainfall_rate_from_previous_timestep long_name = explicit rainfall rate previous timestep @@ -1503,7 +1510,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [diceprv] standard_name = ice_precipitation_rate_from_previous_timestep long_name = ice precipitation rate from previous timestep @@ -1511,7 +1518,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [dsnowprv] standard_name = snow_precipitation_rate_from_previous_timestep long_name = snow precipitation rate from previous timestep @@ -1519,7 +1526,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [dgraupelprv] standard_name = graupel_precipitation_rate_from_previous_timestep long_name = graupel precipitation rate from previous timestep @@ -1527,7 +1534,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [alvsf] standard_name = mean_vis_albedo_with_strong_cosz_dependency long_name = mean vis albedo with strong cosz dependency @@ -1561,7 +1568,7 @@ [ccpp-table-properties] name = GFS_coupling_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_coupling_type @@ -1643,6 +1650,20 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[sfculw] + standard_name = surface_upwelling_longwave_flux_on_radiation_time_step + long_name = total sky sfc upward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[sfculw_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_upward_at_surface + long_name = RRTMGP Jacobian upward longwave flux at surface + units = W m-2 K-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [rain_cpl] standard_name = lwe_thickness_of_precipitation_amount_for_coupling long_name = total rain precipitation @@ -1973,7 +1994,7 @@ [ulwsfcin_cpl] standard_name = surface_upwelling_longwave_flux_for_coupling long_name = surface upwelling LW flux for coupling - units = W m-2 + units = W m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -1981,7 +2002,7 @@ [dusfcin_cpl] standard_name = surface_x_momentum_flux_for_coupling long_name = sfc x momentum flux for coupling - units = Pa + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -1989,7 +2010,7 @@ [dvsfcin_cpl] standard_name = surface_y_momentum_flux_for_coupling long_name = sfc y momentum flux for coupling - units = Pa + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -2147,7 +2168,7 @@ [ccpp-table-properties] name = GFS_control_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_control_type @@ -2420,6 +2441,13 @@ units = flag dimensions = () type = logical +[fhcyc] + standard_name = frequency_for_surface_cycling_calls + long_name = frequency for surface cycling calls + units = h + dimensions = () + type = real + kind = kind_phys [nscyc] standard_name = number_of_timesteps_between_surface_cycling_calls long_name = number of timesteps between surface cycling calls @@ -2461,13 +2489,13 @@ [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls - units = + units = dimensions = () type = integer [nslwr] standard_name = number_of_timesteps_between_longwave_radiation_calls long_name = number of timesteps between longwave radiation calls - units = + units = dimensions = () type = integer [fhswr] @@ -2588,7 +2616,7 @@ type = integer [iovr] standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = flag for cloud overlap method + long_name = flag for cloud overlap method units = flag dimensions = () type = integer @@ -2652,7 +2680,7 @@ units = none dimensions = () type = character - kind = len=128 + kind = len=128 [nGases] standard_name = number_of_active_gases_used_by_RRTMGP long_name = number of gases available used by RRTMGP (Model%nGases) @@ -2674,7 +2702,7 @@ type = character kind = len=128 [lw_file_clouds] - standard_name = rrtmgp_coeff_lw_cloud_optics + standard_name = rrtmgp_coeff_lw_cloud_optics long_name = file containing coefficients for RRTMGP LW cloud optics (Model%lw_file_clouds) units = none dimensions = () @@ -2692,7 +2720,7 @@ units = count dimensions = () type = integer -[sw_file_gas] +[sw_file_gas] standard_name = rrtmgp_kdistribution_sw long_name = file containing RRTMGP SW k-distribution (Model%sw_file_gas) units = none @@ -2700,9 +2728,9 @@ type = character kind = len=128 [sw_file_clouds] - standard_name = rrtmgp_coeff_sw_cloud_optics + standard_name = rrtmgp_coeff_sw_cloud_optics long_name = file containing coefficients for RRTMGP SW cloud optics (Model%sw_file_clouds) - units = none + units = none dimensions = () type = character kind = len=128 @@ -2723,7 +2751,7 @@ long_name = logical flag to control cloud optics scheme. units = flag dimensions = () - type = logical + type = logical [doGP_cldoptics_PADE] standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE long_name = logical flag to control cloud optics scheme. @@ -2741,7 +2769,13 @@ long_name = logical flag to control RRTMGP LW calculation units = flag dimensions = () - type = logical + type = logical +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical [rrtmgp_nrghice] standard_name = number_of_rrtmgp_ice_roughness long_name = number of ice-roughness categories in RRTMGP calculation (Model%rrtmgp_nrghice) @@ -2971,7 +3005,7 @@ [mg_qcvar] standard_name = mg_cloud_water_variance long_name = cloud water relative variance for MG microphysics - units = + units = dimensions = () type = real kind = kind_phys @@ -3284,7 +3318,7 @@ dimensions = (soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys - active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [pores] standard_name = maximum_soil_moisture_content_for_land_surface_model long_name = maximum soil moisture for a given soil type for land surface model @@ -3367,9 +3401,9 @@ dimensions = () type = integer [spec_adv] - standard_name = flag_for_individual_cloud_species_advected + standard_name = flag_for_individual_cloud_species_advected long_name = flag for individual cloud species advected - units = flag + units = flag dimensions = () type = logical [flgmin] @@ -3451,6 +3485,12 @@ units = index dimensions = () type = integer +[use_ufo] + standard_name = flag_for_gcycle_surface_option + long_name = flag for gcycle surface option + units = flag + dimensions = () + type = logical [lcurr_sf] standard_name = flag_for_ocean_currents_in_surface_layer_scheme long_name = flag for taking ocean currents into account in surface layer scheme @@ -3600,7 +3640,7 @@ [shcnvcw] standard_name = flag_shallow_convective_cloud long_name = flag for shallow convective cloud - units = + units = dimensions = () type = logical [redrag] @@ -3971,6 +4011,12 @@ dimensions = () type = real kind = kind_phys +[nst_anl] + standard_name = flag_for_nsstm_analysis_in_gcycle + long_name = flag for NSSTM analysis in gcycle/sfcsub + units = flag + dimensions = () + type = logical [nstf_name(1)] standard_name = flag_for_nsstm_run long_name = NSSTM flag: off/uncoupled/coupled=0/1/2 @@ -4203,14 +4249,14 @@ standard_name =magnitude_of_perturbations_for_landperts long_name = magnitude of perturbations for landperts units = variable - dimensions = (number_of_land_surface_variables_perturbed) + dimensions = (number_of_land_surface_variables_perturbed) type = real kind = kind_phys [lndp_var_list] standard_name = variables_to_be_perturbed_for_landperts long_name = variables to be perturbed for landperts units = none - dimensions = (number_of_land_surface_variables_perturbed) + dimensions = (number_of_land_surface_variables_perturbed) type = character kind = len=3 [ntrac] @@ -4463,37 +4509,43 @@ [nT2delt] standard_name = index_for_air_temperature_two_timesteps_back long_name = the index of air temperature two timesteps back in phy f3d - units = + units = dimensions = () type = integer [nTdelt] standard_name = index_for_air_temperature_at_previous_timestep long_name = the index of air temperature at previous timestep in phy f3d - units = + units = dimensions = () type = integer [nqv2delt] standard_name = index_for_specific_humidity_two_timesteps_back long_name = the index of specific humidity two timesteps back in phy f3d - units = + units = dimensions = () type = integer [nqvdelt] standard_name = index_for_specific_humidity_at_previous_timestep long_name = the index of specific humidity at previous timestep in phy f3d - units = + units = dimensions = () type = integer [nps2delt] standard_name = index_for_surface_air_pressure_two_timesteps_back long_name = the index of surface air pressure two timesteps back in phy f2d - units = + units = dimensions = () type = integer [npsdelt] standard_name = index_for_surface_air_pressure_at_previous_timestep long_name = the index of surface air pressure at previous timestep in phy f2d - units = + units = + dimensions = () + type = integer +[ncnvwind] + standard_name = index_for_surface_wind_enhancement_due_to_convection + long_name = the index of surface wind enhancement due to convection in phy f2d + units = dimensions = () type = integer [debug] @@ -4696,7 +4748,7 @@ standard_name = gwd_opt long_name = flag to choose gwd scheme units = flag - dimensions = () + dimensions = () type = integer [do_mynnedmf] standard_name = do_mynnedmf @@ -4864,7 +4916,7 @@ dimensions = () type = logical [do_ugwp_v0] - standard_name = do_ugwp_v0 + standard_name = flag_for_ugwp_version_0 long_name = flag to activate ver 0 CIRES UGWP units = flag dimensions = () @@ -4872,15 +4924,23 @@ intent = in optional = F [do_ugwp_v0_orog_only] - standard_name = do_ugwp_v0_orog_only + standard_name = flag_for_ugwp_version_0_orographic_gwd long_name = flag to activate ver 0 CIRES UGWP - orographic GWD only units = flag dimensions = () type = logical intent = in optional = F +[do_ugwp_v0_nst_only] + standard_name = flag_for_ugwp_version_0_nonorographic_gwd + long_name = flag to activate ver 0 CIRES UGWP - non-stationary GWD only + units = flag + dimensions = () + type = logical + intent = in + optional = F [do_gsl_drag_ls_bl] - standard_name = do_gsl_drag_ls_bl + standard_name = flag_for_gsl_drag_suite_large_scale_orographic_and_blocking_drag long_name = flag to activate GSL drag suite - large-scale GWD and blocking units = flag dimensions = () @@ -4888,7 +4948,7 @@ intent = in optional = F [do_gsl_drag_ss] - standard_name = do_gsl_drag_ss + standard_name = flag_for_gsl_drag_suite_small_scale_orographic_drag long_name = flag to activate GSL drag suite - small-scale GWD units = flag dimensions = () @@ -4896,7 +4956,7 @@ intent = in optional = F [do_gsl_drag_tofd] - standard_name = do_gsl_drag_tofd + standard_name = flag_for_gsl_drag_suite_turbulent_orographic_form_drag long_name = flag to activate GSL drag suite - turb orog form drag units = flag dimensions = () @@ -4904,7 +4964,7 @@ intent = in optional = F [do_ugwp_v1] - standard_name = do_ugwp_v1 + standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP units = flag dimensions = () @@ -4912,25 +4972,33 @@ intent = in optional = F [do_ugwp_v1_orog_only] - standard_name = do_ugwp_v1_orog_only + standard_name = flag_for_ugwp_version_1_orographic_gwd long_name = flag to activate ver 1 CIRES UGWP - orographic GWD only units = flag dimensions = () type = logical intent = in optional = F +[do_ugwp_v1_w_gsldrag] + standard_name = flag_for_ugwp_version_1_nonorographic_gwd + long_name = flag to activate ver 1 CIRES UGWP - with OGWD of GSL + units = flag + dimensions = () + type = logical + intent = in + optional = F [lmfdeep2] standard_name = flag_for_scale_aware_mass_flux_convection long_name = flag for some scale-aware mass-flux convection scheme active units = flag dimensions = () type = logical - + ######################################################################## [ccpp-table-properties] name = GFS_grid_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_grid_type @@ -4997,12 +5065,14 @@ units = index dimensions = (horizontal_loop_extent) type = integer + active = (index_for_ozone>0) [jindx2_o3] standard_name = upper_ozone_interpolation_index long_name = interpolation high index for ozone units = index dimensions = (horizontal_loop_extent) type = integer + active = (index_for_ozone>0) [ddy_o3] standard_name = ozone_interpolation_weight long_name = interpolation high index for ozone @@ -5010,18 +5080,21 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (index_for_ozone>0) [jindx1_h] standard_name = lower_water_vapor_interpolation_index long_name = interpolation low index for stratospheric water vapor units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_stratospheric_water_vapor_physics) [jindx2_h] standard_name = upper_water_vapor_interpolation_index long_name = interpolation high index for stratospheric water vapor units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_stratospheric_water_vapor_physics) [ddy_h] standard_name = water_vapor_interpolation_weight long_name = interpolation high index for stratospheric water vapor @@ -5029,18 +5102,21 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_stratospheric_water_vapor_physics) [jindx1_aer] standard_name = lower_aerosol_y_interpolation_index long_name = interpolation low index for prescribed aerosols in the y direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_aerosol_input_MG_radiation) [jindx2_aer] standard_name = upper_aerosol_y_interpolation_index long_name = interpolation high index for prescribed aerosols in the y direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_aerosol_input_MG_radiation) [ddy_aer] standard_name = aerosol_y_interpolation_weight long_name = interpolation high index for prescribed aerosols in the y direction @@ -5048,18 +5124,21 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_aerosol_input_MG_radiation) [iindx1_aer] standard_name = lower_aerosol_x_interpolation_index long_name = interpolation low index for prescribed aerosols in the x direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_aerosol_input_MG_radiation) [iindx2_aer] standard_name = upper_aerosol_x_interpolation_index long_name = interpolation high index for prescribed aerosols in the x direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_aerosol_input_MG_radiation) [ddx_aer] standard_name = aerosol_x_interpolation_weight long_name = interpolation high index for prescribed aerosols in the x direction @@ -5067,18 +5146,21 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_aerosol_input_MG_radiation) [jindx1_ci] standard_name = lower_cloud_nuclei_y_interpolation_index long_name = interpolation low index for ice and cloud condensation nuclei in the y direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) [jindx2_ci] standard_name = upper_cloud_nuclei_y_interpolation_index long_name = interpolation high index for ice and cloud condensation nuclei in the y direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) [ddy_ci] standard_name = cloud_nuclei_y_interpolation_weight long_name = interpolation high index for ice and cloud condensation nuclei in the y direction @@ -5086,18 +5168,21 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) [iindx1_ci] standard_name = lower_cloud_nuclei_x_interpolation_index long_name = interpolation low index for ice and cloud condensation nuclei in the x direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) [iindx2_ci] standard_name = upper_cloud_nuclei_x_interpolation_index long_name = interpolation high index for ice and cloud condensation nuclei in the x direction units = index dimensions = (horizontal_loop_extent) type = integer + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) [ddx_ci] standard_name = cloud_nuclei_x_interpolation_weight long_name = interpolation high index for ice and cloud condensation nuclei in the x direction @@ -5105,12 +5190,43 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_in_ccn_forcing_for_morrison_gettelman_microphysics==1) +[jindx1_tau] + standard_name = lower_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index1 for weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + active = (flag_for_ugwp_version_1) +[jindx2_tau] + standard_name = upper_latitude_index_of_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag_for_interpolation + long_name = index2 for weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = integer + active = (flag_for_ugwp_version_1) +[ddy_j1tau] + standard_name = latitude_interpolation_weight_complement_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight1 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_ugwp_version_1) +[ddy_j2tau] + standard_name = latitude_interpolation_weight_for_absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = interpolation weight2 for tau NGWs + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_ugwp_version_1) ######################################################################## [ccpp-table-properties] name = GFS_tbd_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_tbd_type @@ -5129,6 +5245,13 @@ dimensions = (horizontal_loop_extent) type = integer active = (flag_for_lw_clouds_sub_grid_approximation == 2 .or. flag_for_sw_clouds_grid_approximation == 2) +[tau_amf] + standard_name = absolute_momentum_flux_due_to_nonorographic_gravity_wave_drag + long_name = ngw_absolute_momentum_flux + units = various + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [ozpl] standard_name = ozone_forcing long_name = ozone forcing data @@ -5250,6 +5373,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (index_for_surface_air_pressure_two_timesteps_back > 0) [phy_f2d(:,index_for_surface_air_pressure_at_previous_timestep)] standard_name = surface_air_pressure_at_previous_timestep long_name = surface air pressure at previous timestep @@ -5257,13 +5381,15 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys -[phy_f2d(:,array_dimension_of_2d_arrays_for_microphysics)] + active = (index_for_surface_air_pressure_at_previous_timestep > 0) +[phy_f2d(:,index_for_surface_wind_enhancement_due_to_convection)] standard_name = surface_wind_enhancement_due_to_convection long_name = surface wind enhancement due to convection units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (index_for_surface_wind_enhancement_due_to_convection > 0) [phy_f3d(:,:,index_for_air_temperature_two_timesteps_back)] standard_name = air_temperature_two_timesteps_back long_name = air temperature two timesteps back @@ -5271,6 +5397,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_air_temperature_two_timesteps_back > 0) [phy_f3d(:,:,index_for_specific_humidity_two_timesteps_back)] standard_name = water_vapor_specific_humidity_two_timesteps_back long_name = water vapor specific humidity two timesteps back @@ -5278,6 +5405,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_specific_humidity_two_timesteps_back > 0) [phy_f3d(:,:,index_for_air_temperature_at_previous_timestep)] standard_name = air_temperature_at_previous_timestep long_name = air temperature at previous timestep @@ -5285,6 +5413,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_air_temperature_at_previous_timestep > 0) [phy_f3d(:,:,index_for_specific_humidity_at_previous_timestep)] standard_name = water_vapor_specific_humidity_at_previous_timestep long_name = water vapor specific humidity at previous timestep @@ -5292,6 +5421,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_specific_humidity_at_previous_timestep > 0) [phy_f3d(:,:,index_for_convective_cloud_water_mixing_ratio_in_phy_f3d)] standard_name = convective_cloud_water_mixing_ratio_in_phy_f3d long_name = convective cloud water mixing ratio in the phy_f3d array @@ -5299,6 +5429,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_convective_cloud_water_mixing_ratio_in_phy_f3d > 0) [phy_f3d(:,:,index_for_convective_cloud_cover_in_phy_f3d)] standard_name = convective_cloud_cover_in_phy_f3d long_name = convective cloud cover in the phy_f3d array @@ -5306,6 +5437,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_convective_cloud_cover_in_phy_f3d > 0) [phy_f3d(:,:,index_of_kinematic_buoyancy_flux_from_shoc_in_phy_f3d)] standard_name = kinematic_buoyancy_flux_from_shoc long_name = upward kinematic buoyancy flux from the SHOC scheme @@ -5313,6 +5445,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_of_kinematic_buoyancy_flux_from_shoc_in_phy_f3d > 0) [phy_f3d(:,:,index_of_atmosphere_heat_diffusivity_from_shoc_in_phy_f3d)] standard_name = atmosphere_heat_diffusivity_from_shoc long_name = diffusivity for heat from the SHOC scheme @@ -5320,6 +5453,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_of_atmosphere_heat_diffusivity_from_shoc_in_phy_f3d > 0) [phy_f3d(:,:,index_of_subgrid_scale_cloud_fraction_from_shoc_in_phy_f3d)] standard_name = subgrid_scale_cloud_fraction_from_shoc long_name = subgrid-scale cloud fraction from the SHOC scheme @@ -5327,6 +5461,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_of_subgrid_scale_cloud_fraction_from_shoc_in_phy_f3d > 0) [phy_f3d(:,:,index_for_cloud_fraction_in_3d_arrays_for_microphysics)] standard_name = cloud_fraction_for_MG long_name = cloud fraction used by Morrison-Gettelman MP @@ -5334,6 +5469,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_cloud_fraction_in_3d_arrays_for_microphysics > 0) [phy_f3d(:,:,index_for_cloud_liquid_water_effective_radius)] standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle_in_um long_name = eff. radius of cloud liquid water particle in micrometer @@ -5341,6 +5477,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_cloud_liquid_water_effective_radius > 0) [phy_f3d(:,:,index_for_ice_effective_radius)] standard_name = effective_radius_of_stratiform_cloud_ice_particle_in_um long_name = eff. radius of cloud ice water particle in micrometer @@ -5348,6 +5485,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_ice_effective_radius > 0) [phy_f3d(:,:,index_for_rain_effective_radius)] standard_name = effective_radius_of_stratiform_cloud_rain_particle_in_um long_name = effective radius of cloud rain particle in micrometers @@ -5355,6 +5493,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_rain_effective_radius > 0) [phy_f3d(:,:,index_for_snow_effective_radius)] standard_name = effective_radius_of_stratiform_cloud_snow_particle_in_um long_name = effective radius of cloud snow particle in micrometers @@ -5362,6 +5501,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_snow_effective_radius > 0) [phy_f3d(:,:,index_for_graupel_effective_radius)] standard_name = effective_radius_of_stratiform_cloud_graupel_particle_in_um long_name = eff. radius of cloud graupel particle in micrometer @@ -5369,6 +5509,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys + active = (index_for_graupel_effective_radius > 0) [forcet] standard_name = temperature_tendency_due_to_dynamics long_name = temperature tendency due to dynamics only @@ -5581,7 +5722,7 @@ [ccpp-table-properties] name = GFS_cldprop_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_cldprop_type @@ -5612,7 +5753,7 @@ [ccpp-table-properties] name = GFS_radtend_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_radtend_type @@ -5704,7 +5845,7 @@ [ccpp-table-properties] name = GFS_diag_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_diag_type @@ -5826,134 +5967,6 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys -[dusfc_ls] - standard_name = integrated_x_momentum_flux_from_large_scale_gwd - long_name = integrated x momentum flux from large scale gwd - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dvsfc_ls] - standard_name = integrated_y_momentum_flux_from_large_scale_gwd - long_name = integrated y momentum flux from large scale gwd - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dusfc_bl] - standard_name = integrated_x_momentum_flux_from_blocking_drag - long_name = integrated x momentum flux from blocking drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dvsfc_bl] - standard_name = integrated_y_momentum_flux_from_blocking_drag - long_name = integrated y momentum flux from blocking drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dusfc_ss] - standard_name = integrated_x_momentum_flux_from_small_scale_gwd - long_name = integrated x momentum flux from small scale gwd - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dvsfc_ss] - standard_name = integrated_y_momentum_flux_from_small_scale_gwd - long_name = integrated y momentum flux from small scale gwd - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dusfc_fd] - standard_name = integrated_x_momentum_flux_from_form_drag - long_name = integrated x momentum flux from form drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dvsfc_fd] - standard_name = integrated_y_momentum_flux_from_form_drag - long_name = integrated y momentum flux from form drag - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtaux2d_ls] - standard_name = x_momentum_tendency_from_large_scale_gwd - long_name = x momentum tendency from large scale gwd - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtauy2d_ls] - standard_name = y_momentum_tendency_from_large_scale_gwd - long_name = y momentum tendency from large scale gwd - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtaux2d_bl] - standard_name = x_momentum_tendency_from_blocking_drag - long_name = x momentum tendency from blocking drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtauy2d_bl] - standard_name = y_momentum_tendency_from_blocking_drag - long_name = y momentum tendency from blocking drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtaux2d_ss] - standard_name = x_momentum_tendency_from_small_scale_gwd - long_name = x momentum tendency from small scale gwd - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtauy2d_ss] - standard_name = y_momentum_tendency_from_small_scale_gwd - long_name = y momentum tendency from small scale gwd - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - active = (gwd_opt == 33) - kind = kind_phys -[dtaux2d_fd] - standard_name = x_momentum_tendency_from_form_drag - long_name = x momentum tendency from form drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) -[dtauy2d_fd] - standard_name = y_momentum_tendency_from_form_drag - long_name = y momentum tendency from form drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (gwd_opt == 33) [totprcp] standard_name = accumulated_lwe_thickness_of_precipitation_amount long_name = accumulated total precipitation @@ -7127,6 +7140,146 @@ type = real kind = kind_phys active = (diag_ugwp_flag) +[dudt_gw] + standard_name = tendency_of_x_wind_due_to_gravity_wave_drag + long_name = zonal wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dvdt_gw] + standard_name = tendency_of_y_wind_due_to_gravity_wave_drag + long_name = meridional wind tendency due to all GWs + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dtdt_gw] + standard_name = tendency_of_air_temperature_due_to_gravity_wave_drag + long_name = air temperature tendency due to all GWs + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[kdis_gw] + standard_name = atmosphere_momentum_diffusivity_due_to_gravity_wave_drag + long_name = eddy mixing due to all GWs + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dudt_ogw] + standard_name = tendency_of_x_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = x momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dvdt_ogw] + standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag + long_name = y momentum tendency from meso scale ogw + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[du_ogwcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag + long_name = integrated x momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dv_ogwcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag + long_name = integrated y momentum flux from meso scale ogw + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dudt_obl] + standard_name = tendency_of_x_momentum_due_to_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dvdt_obl] + standard_name = tendency_of_y_momentum_due_to_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[du_oblcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dv_oblcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dudt_oss] + standard_name = tendency_of_x_momentum_due_to_small_scale_gravity_wave_drag + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dvdt_oss] + standard_name = tendency_of_y_momentum_due_to_small_scale_gravity_wave_drag + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[du_osscol] + standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag + long_name = integrated x momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dv_osscol] + standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag + long_name = integrated y momentum flux from small scale gwd + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dudt_ofd] + standard_name = tendency_of_x_momentum_due_to_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[dvdt_ofd] + standard_name = tendency_of_y_momentum_due_to_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[du_ofdcol] + standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag + long_name = integrated x momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dv_ofdcol] + standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag + long_name = integrated y momentum flux from form drag + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [dv3dt_ngw] standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave long_name = time integral of change in y wind due to NGW @@ -7152,12 +7305,11 @@ kind = kind_phys active = (number_of_2d_auxiliary_arrays > 0) - ######################################################################## [ccpp-table-properties] name = GFS_interstitial_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_interstitial_type @@ -8446,19 +8598,6 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[h2o_coeff] - standard_name = number_of_coefficients_in_h2o_forcing_data - long_name = number of coefficients in h2o forcing data - units = index - dimensions = () - type = integer -[h2o_pres] - standard_name = natural_log_of_h2o_forcing_data_pressure_levels - long_name = natural log of h2o forcing data pressure levels - units = log(Pa) - dimensions = (vertical_dimension_of_h2o_forcing_data) - type = real - kind = kind_phys [hefac] standard_name = surface_upward_latent_heat_flux_reduction_factor long_name = surface upward latent heat flux reduction factor from canopy heat storage @@ -8657,18 +8796,6 @@ units = count dimensions = () type = integer -[levh2o] - standard_name = vertical_dimension_of_h2o_forcing_data - long_name = number of vertical layers in h2o forcing data - units = count - dimensions = () - type = integer -[levozp] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer [lmk] standard_name = adjusted_vertical_layer_dimension_for_radiation long_name = adjusted number of vertical layers for radiation @@ -8880,25 +9007,12 @@ units = flag dimensions = (number_of_tracers_plus_one,2) type = logical -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer [oz_coeffp5] standard_name = number_of_coefficients_in_ozone_forcing_data_plus_five long_name = number of coefficients in ozone forcing data plus five units = index dimensions = () type = integer -[oz_pres] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels - units = log(Pa) - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys [phys_hydrostatic] standard_name = flag_for_hydrostatic_heating_from_physics long_name = flag for use of hydrostatic heating in physics @@ -9818,44 +9932,44 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys -[gw_dudt] - standard_name = tendency_of_x_wind_due_to_ugwp - long_name = zonal wind tendency due to UGWP +[zmtb] + standard_name = height_of_mountain_blocking + long_name = height of mountain blocking drag + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[dudt_ngw] + standard_name = tendency_of_x_wind_due_to_nonorographic_gravity_wave_drag + long_name = zonal wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[gw_dvdt] - standard_name = tendency_of_y_wind_due_to_ugwp - long_name = meridional wind tendency due to UGWP +[dvdt_ngw] + standard_name = tendency_of_y_wind_due_to_nonorographic_gravity_wave_drag + long_name = meridional wind tendency due to non-stationary GWs units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[gw_dtdt] - standard_name = tendency_of_air_temperature_due_to_ugwp - long_name = air temperature tendency due to UGWP +[dtdt_ngw] + standard_name = tendency_of_air_temperature_due_to_nonorographic_gravity_wave_drag + long_name = air temperature tendency due to non-stationary GWs units = K s-1 dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[gw_kdis] - standard_name = eddy_mixing_due_to_ugwp - long_name = eddy mixing due to UGWP +[kdis_ngw] + standard_name = atmosphere_momentum_diffusivity_due_to_nonorographic_gravity_wave_drag + long_name = eddy mixing due to non-stationary GWs units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[zmtb] - standard_name = height_of_mountain_blocking - long_name = height of mountain blocking drag - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys [zlwb] standard_name = height_of_low_level_wave_breaking - long_name = height of drag due to low level wave breaking + long_name = height of low level wave breaking units = m dimensions = (horizontal_loop_extent) type = real @@ -9867,6 +9981,13 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[zngw] + standard_name = height_of_launch_level_of_nonorographic_gravity_waves + long_name = height of launch level of non-stationary GWs + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [tau_tofd] standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag long_name = instantaneous momentum flux due to TOFD @@ -9888,6 +10009,13 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[tau_oss] + standard_name = momentum_flux_due_to_subgrid_scale_orographic_gravity_wave_drag + long_name = momentum flux or stress due to SSO including OBL-OSS-OFD + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [tau_ngw] standard_name = instantaneous_momentum_flux_due_to_nonstationary_gravity_wave long_name = instantaneous momentum flux due to nonstationary gravity waves @@ -9902,20 +10030,31 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys -[dudt_ogw] - standard_name = instantaneous_change_in_x_wind_due_to_orographic_gravity_wave_drag - long_name = instantaneous change in x wind due to orographic gw drag - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys [dudt_tms] - standard_name = instantaneous_change_in_x_wind_due_to_turbulent_orographic_form_drag + standard_name = tendency_of_x_wind_due_to_turbulent_orographic_form_drag long_name = instantaneous change in x wind due to TOFD units = m s-2 dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys +[qs_lay] + standard_name = saturation_vapor_pressure + long_name = saturation vapor pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + optional = F + active = (flag_for_rrtmgp_radiation_scheme) +[q_lay] + standard_name = water_vapor_mixing_ratio + long_name = water vaport mixing ratio + units = kg/kg + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + optional = F + active = (flag_for_rrtmgp_radiation_scheme) [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa long_name = air pressure layer @@ -9998,13 +10137,13 @@ active = (flag_for_rrtmgp_radiation_scheme) [ipsdsw0] standard_name = initial_permutation_seed_sw - long_name = initial seed for McICA SW + long_name = initial seed for McICA SW units = none dimensions = () type = integer [ipsdlw0] standard_name = initial_permutation_seed_lw - long_name = initial seed for McICA LW + long_name = initial seed for McICA LW units = none dimensions = () type = integer @@ -10054,27 +10193,6 @@ type = real kind = kind_phys active = (flag_for_rrtmgp_radiation_scheme) -[sktp1r] - standard_name = surface_skin_temperature_at_previous_time_step - long_name = surface skin temperature at previous time step - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_upward - long_name = RRTMGP Jacobian upward longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys -[fluxlwDOWN_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_profile_downward - long_name = RRTMGP Jacobian downward of longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys [fluxswUP_allsky] standard_name = RRTMGP_sw_flux_profile_upward_allsky long_name = RRTMGP upward shortwave all-sky flux profile @@ -10230,13 +10348,13 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_2str + type = ty_optical_props_2str [sw_optical_props_precip] standard_name = shortwave_optical_properties_for_precipitation long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_2str + type = ty_optical_props_2str [sw_optical_props_clouds] standard_name = shortwave_optical_properties_for_cloudy_atmosphere long_name = Fortran DDT containing RRTMGP optical properties @@ -10284,25 +10402,25 @@ long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str [lw_optical_props_precip] standard_name = longwave_optical_properties_for_precipitation long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str [lw_optical_props_cloudsByBand] standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str [lw_optical_props_precipByBand] standard_name = longwave_optical_properties_for_precipitation_by_band long_name = Fortran DDT containing RRTMGP optical properties units = DDT dimensions = () - type = ty_optical_props_1scl + type = ty_optical_props_2str [lw_optical_props_aerosol] standard_name = longwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties @@ -10386,7 +10504,7 @@ [ccpp-table-properties] name = GFS_data_type type = ddt - dependencies = + dependencies = [ccpp-arg-table] name = GFS_data_type @@ -10450,7 +10568,7 @@ [ccpp-table-properties] name = GFS_typedefs type = module - relative_path = ../../ccpp/physics/physics + relative_path = ../physics/physics dependencies = machine.F,physcons.F90,radlw_param.f,radsw_param.f,GFDL_parse_tracers.F90 dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_optical_props.F90,rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 dependencies = rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_rte_config.F90,rte-rrtmgp/rte/mo_source_functions.F90 @@ -10584,7 +10702,7 @@ units = kg kg-1 dimensions = () type = real - kind = kind_phys + kind = kind_phys [con_omega] standard_name = angular_velocity_of_earth long_name = angular velocity of earth @@ -10744,5 +10862,5 @@ long_name = specific heat of ice at constant pressure units = J kg-1 K-1 dimensions = () - type = real + type = real kind = kind_phys diff --git a/ccpp/driver/CCPP_driver.F90 b/ccpp/driver/CCPP_driver.F90 index 06e6dc63f..392b37151 100644 --- a/ccpp/driver/CCPP_driver.F90 +++ b/ccpp/driver/CCPP_driver.F90 @@ -3,14 +3,17 @@ module CCPP_driver use ccpp_api, only: ccpp_t use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & ccpp_physics_run, & + ccpp_physics_timestep_finalize, & ccpp_physics_finalize use CCPP_data, only: cdata_tile, & cdata_domain, & cdata_block, & ccpp_suite, & - GFS_control + GFS_control, & + GFS_data implicit none @@ -55,6 +58,8 @@ subroutine CCPP_step (step, nblks, ierr) ! Local variables integer :: nb, nt, ntX integer :: ierr2 + ! DH* 20210104 - remove kdt_rad when code to clear diagnostic buckets is removed + integer :: kdt_rad ierr = 0 @@ -95,9 +100,9 @@ subroutine CCPP_step (step, nblks, ierr) else if (trim(step)=="physics_init") then - ! Since the physics init steps are independent of the blocking structure, + ! Since the physics init step is independent of the blocking structure, ! we can use cdata_domain here. Since we don't use threading on the outside, - ! we can allow threading inside the time_vary routines. + ! we can allow threading inside the physics init routines. GFS_control%nthreads = nthrds call ccpp_physics_init(cdata_domain, suite_name=trim(ccpp_suite), ierr=ierr) @@ -107,22 +112,53 @@ subroutine CCPP_step (step, nblks, ierr) return end if - else if (trim(step)=="time_vary") then + ! Timestep init = time_vary + else if (trim(step)=="timestep_init") then - ! Since the time_vary steps only use data structures for all blocks (except the - ! CCPP-internal variables ccpp_error_flag and ccpp_error_message, which are defined - ! for all cdata structures independently), we can use cdata_domain here. - ! Since we don't use threading on the outside, we can allow threading - ! inside the time_vary routines. + ! Since the physics timestep init step is independent of the blocking structure, + ! we can use cdata_domain here. Since we don't use threading on the outside, + ! we can allow threading inside the timestep init (time_vary) routines. GFS_control%nthreads = nthrds - call ccpp_physics_run(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_run for group time_vary" + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group time_vary" write(0,'(a)') trim(cdata_domain%errmsg) return end if + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! DH* 20210104 - this block of code will be removed once the CCPP framework ! + ! fully supports handling diagnostics through its metadata, work in progress ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !--- determine if radiation diagnostics buckets need to be cleared + if (nint(GFS_control%fhzero*3600) >= nint(max(GFS_control%fhswr,GFS_control%fhlwr))) then + if (mod(GFS_control%kdt,GFS_control%nszero) == 1) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%rad_zero(GFS_control) + end do + endif + else + kdt_rad = nint(min(GFS_control%fhswr,GFS_control%fhlwr)/GFS_control%dtp) + if (mod(GFS_control%kdt,kdt_rad) == 1) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%rad_zero(GFS_control) + enddo + endif + endif + + !--- determine if physics diagnostics buckets need to be cleared + if (mod(GFS_control%kdt,GFS_control%nszero) == 1) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%phys_zero(GFS_control) + end do + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! *DH 20210104 ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Radiation and stochastic physics else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then @@ -162,6 +198,21 @@ subroutine CCPP_step (step, nblks, ierr) !$OMP end parallel if (ierr/=0) return + ! Timestep finalize = time_vary + else if (trim(step)=="timestep_finalize") then + + ! Since the physics timestep finalize step is independent of the blocking structure, + ! we can use cdata_domain here. Since we don't use threading on the outside, + ! we can allow threading inside the timestep finalize (time_vary) routines. + GFS_control%nthreads = nthrds + + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group time_vary" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + ! Finalize else if (trim(step)=="finalize") then diff --git a/ccpp/driver/CMakeLists.txt b/ccpp/driver/CMakeLists.txt index 5960d92da..41bad2626 100644 --- a/ccpp/driver/CMakeLists.txt +++ b/ccpp/driver/CMakeLists.txt @@ -1,27 +1,51 @@ if(NOT DYN32) -remove_definitions(-DOVERLOAD_R8) -remove_definitions(-DOVERLOAD_R4) + remove_definitions(-DOVERLOAD_R8) + remove_definitions(-DOVERLOAD_R4) endif() -message ("Force 64 bits in CCPP_layer") +message ("Force 64 bits in ccpp/driver") if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") + if(REPRO) + string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") + else() string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64 -no-prec-div -no-prec-sqrt" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") + endif() elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") +endif() + +list(APPEND _ccppdriver_defs_private NEMS_GSM + MOIST_CAPPA + USE_COND + INTERNAL_FILE_NML) + +if(MULTI_GASES) + list(APPEND _ccppdriver_defs_private MULTI_GASES) endif() add_library( ccppdriver + GFS_diagnostics.F90 + GFS_restart.F90 + GFS_init.F90 + + ${CMAKE_BINARY_DIR}/FV3/ccpp/physics/ccpp_static_api.F90 CCPP_driver.F90 ) +# Compile GFS_diagnostics.F90 without optimization, this leads to out of memory errors on wcoss_dell_p3 +set_property(SOURCE GFS_diagnostics.F90 APPEND_STRING PROPERTY COMPILE_FLAGS "-O0") + target_link_libraries(ccppdriver gfsphysics) target_link_libraries(ccppdriver ccpp) target_link_libraries(ccppdriver ccppphys) +target_link_libraries(ccppdriver ccppdata) -target_include_directories(ccppdriver PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src) +target_include_directories(ccppdriver PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src + ${CMAKE_BINARY_DIR}/FV3/ccpp/physics) set_target_properties(ccppdriver PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod) +target_compile_definitions(ccppdata PRIVATE "${_ccppdata_defs_private}") target_include_directories(ccppdriver PUBLIC $) diff --git a/gfsphysics/GFS_layer/GFS_diagnostics.F90 b/ccpp/driver/GFS_diagnostics.F90 similarity index 97% rename from gfsphysics/GFS_layer/GFS_diagnostics.F90 rename to ccpp/driver/GFS_diagnostics.F90 index cf19c7cd3..3f9bafde7 100644 --- a/gfsphysics/GFS_layer/GFS_diagnostics.F90 +++ b/ccpp/driver/GFS_diagnostics.F90 @@ -1844,19 +1844,15 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%unit = 'XXX' ExtDiag(idx)%mod_name = 'gfs_phys' allocate (ExtDiag(idx)%data(nblks)) -#ifdef CCPP if (Model%lsm==Model%lsm_ruc) then do nb = 1,nblks ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%wetness(:) enddo else -#endif do nb = 1,nblks ExtDiag(idx)%data(nb)%var2 => IntDiag(nb)%wet1(:) enddo -#ifdef CCPP endif -#endif idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -2645,7 +2641,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,8) enddo -#ifdef CCPP if_qdiag3d: if(Model%qdiag3d) then idx = idx + 1 ExtDiag(idx)%axes = 3 @@ -2804,7 +2799,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,13) enddo -#endif end if if_ldiag3d !rab @@ -3026,7 +3020,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%snowd(:) enddo -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -3050,7 +3043,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var2 => Sfcprop(nb)%snowfallac_ice(:) enddo endif -#endif idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -3228,7 +3220,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%vfrac(:) enddo -#ifdef CCPP if (Model%rdlai) then idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -3279,23 +3270,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo enddo endif -#else - do num = 1,4 - write (xtra,'(i1)') num - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'slc_'//trim(xtra) - ExtDiag(idx)%desc = 'liquid soil mositure at layer-'//trim(xtra) - ExtDiag(idx)%unit = 'xxx' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%slc(:,num) - enddo - enddo -#endif -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then do num = 1,Model%lsoil_lsm write (xtra,'(i1)') num @@ -3325,53 +3300,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo enddo endif -#else - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilw1' - ExtDiag(idx)%desc = 'volumetric soil moisture 0-10cm' - ExtDiag(idx)%unit = 'fraction' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%smc(:,1) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilw2' - ExtDiag(idx)%desc = 'volumetric soil moisture 10-40cm' - ExtDiag(idx)%unit = 'fraction' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%smc(:,2) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilw3' - ExtDiag(idx)%desc = 'volumetric soil moisture 40-100cm' - ExtDiag(idx)%unit = 'fraction' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%smc(:,3) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilw4' - ExtDiag(idx)%desc = 'volumetric soil moisture 100-200cm' - ExtDiag(idx)%unit = 'fraction' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%smc(:,4) - enddo -#endif -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then do num = 1,Model%lsoil_lsm write (xtra,'(i1)') num @@ -3401,51 +3330,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo enddo endif -#else - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilt1' - ExtDiag(idx)%desc = 'soil temperature 0-10cm' - ExtDiag(idx)%unit = 'K' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%stc(:,1) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilt2' - ExtDiag(idx)%desc = 'soil temperature 10-40cm' - ExtDiag(idx)%unit = 'K' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%stc(:,2) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilt3' - ExtDiag(idx)%desc = 'soil temperature 40-100cm' - ExtDiag(idx)%unit = 'K' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%stc(:,3) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 2 - ExtDiag(idx)%name = 'soilt4' - ExtDiag(idx)%desc = 'soil temperature 100-200cm' - ExtDiag(idx)%unit = 'K' - ExtDiag(idx)%mod_name = 'gfs_sfc' - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var2 => sfcprop(nb)%stc(:,4) - enddo -#endif !--------------------------nsst variables if (model%nstf_name(1) > 0) then @@ -3652,7 +3536,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop endif !--------------------------aerosols -#ifdef CCPP if (Model%ntwa>0) then idx = idx + 1 ExtDiag(idx)%axes = 3 @@ -3966,7 +3849,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop endif endif -#endif ! print *,'in gfdl_diag_register,af all extdiag, idx=',idx @@ -4204,7 +4086,6 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop end subroutine GFS_externaldiag_populate -#ifdef CCPP function soil_layer_depth(lsm, lsm_ruc, lsm_noah, layer) result(layer_depth) character(len=30) :: layer_depth integer, intent(in) :: lsm, lsm_ruc, lsm_noah, layer @@ -4254,7 +4135,6 @@ function soil_layer_depth(lsm, lsm_ruc, lsm_noah, layer) result(layer_depth) return ! end function soil_layer_depth -#endif !------------------------------------------------------------------------- diff --git a/ccpp/driver/GFS_init.F90 b/ccpp/driver/GFS_init.F90 new file mode 100644 index 000000000..7b210db79 --- /dev/null +++ b/ccpp/driver/GFS_init.F90 @@ -0,0 +1,173 @@ +module GFS_init + + 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, & + GFS_interstitial_type + + implicit none + + private + +!---------------- +! Public entities +!---------------- + public GFS_initialize !< GFS initialization routine + + CONTAINS +!******************************************************************************************* + + +!-------------- +! GFS initialze +!-------------- + subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & + Coupling, Grid, Tbd, Cldprop, Radtend, & + Diag, Interstitial, communicator, & + ntasks, Init_parm) + +#ifdef _OPENMP + use omp_lib +#endif + + !--- 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_interstitial_type), intent(inout) :: Interstitial(:) + integer, intent(in) :: communicator + integer, intent(in) :: ntasks + type(GFS_init_type), intent(in) :: Init_parm + + !--- local variables + integer :: nb + integer :: nblks + integer :: nt + integer :: nthrds + logical :: non_uniform_blocks + integer :: ix + + nblks = size(Init_parm%blksz) + +#ifdef _OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + + !--- 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%iau_offset, Init_parm%bdat, & + Init_parm%cdat, Init_parm%tracer_names, & + Init_parm%input_nml_file, Init_parm%tile_num, & + Init_parm%blksz, Init_parm%ak, Init_parm%bk, & + Init_parm%restart, Init_parm%hydrostatic, & + communicator, ntasks, nthrds) + + do nb = 1,nblks + ix = Init_parm%blksz(nb) + call Statein (nb)%create (ix, Model) + call Stateout (nb)%create (ix, Model) + call Sfcprop (nb)%create (ix, Model) + call Coupling (nb)%create (ix, Model) + call Grid (nb)%create (ix, Model) + call Tbd (nb)%create (ix, Model) + call Cldprop (nb)%create (ix, Model) + call Radtend (nb)%create (ix, Model) +!--- internal representation of diagnostics + call Diag (nb)%create (ix, Model) + enddo + +! This logic deals with non-uniform block sizes for CCPP. When non-uniform block sizes +! are used, it is required that only the last block has a different (smaller) size than +! all other blocks. This is the standard in FV3. If this is the case, set non_uniform_blocks +! to .true. and initialize nthreads+1 elements of the interstitial array. The extra element +! will be used by the thread that runs over the last, smaller block. + if (minval(Init_parm%blksz)==maxval(Init_parm%blksz)) then + non_uniform_blocks = .false. + elseif (all(minloc(Init_parm%blksz)==(/size(Init_parm%blksz)/))) then + non_uniform_blocks = .true. + else + write(0,'(2a)') 'For non-uniform blocksizes, only the last element ', & + 'in Init_parm%blksz can be different from the others' + stop + endif + +! Initialize the Interstitial data type in parallel so that +! each thread creates (touches) its Interstitial(nt) first. +!$OMP parallel do default (shared) & +!$OMP schedule (static,1) & +!$OMP private (nt) + do nt=1,nthrds + call Interstitial (nt)%create (maxval(Init_parm%blksz), Model) + enddo +!$OMP end parallel do + + if (non_uniform_blocks) then + call Interstitial (nthrds+1)%create (Init_parm%blksz(nblks), Model) + end if + + !--- populate the grid components + call GFS_grid_populate (Grid, Init_parm%xlon, Init_parm%xlat, Init_parm%area) + + end subroutine GFS_initialize + +!------------------ +! 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(:,:) + real(kind=kind_phys), parameter :: rad2deg = 180.0_kind_phys/pi + + !--- 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 > 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) * rad2deg + Grid(nb)%xlon_d(ix) = xlon(i,j) * rad2deg + 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_init diff --git a/gfsphysics/GFS_layer/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 similarity index 98% rename from gfsphysics/GFS_layer/GFS_restart.F90 rename to ccpp/driver/GFS_restart.F90 index eada1fc3d..dcd78eb75 100644 --- a/gfsphysics/GFS_layer/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -6,7 +6,7 @@ module GFS_restart GFS_coupling_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type, & - GFS_init_type + GFS_init_type use GFS_diagnostics, only: GFS_externaldiag_type type var_subtype @@ -97,7 +97,6 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%ldiag = 3 + Model%ntot2d + Model%nctp + ndiag_rst Restart%num2d = 3 + Model%ntot2d + Model%nctp + ndiag_rst -#ifdef CCPP ! GF if (Model%imfdeepcnv == 3) then Restart%num2d = Restart%num2d + 1 @@ -114,13 +113,11 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & if (Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then Restart%num2d = Restart%num2d + 2 endif -#endif Restart%num3d = Model%ntot3d if(Model%lrefres) then Restart%num3d = Model%ntot3d+1 endif -#ifdef CCPP ! GF if (Model%imfdeepcnv == 3) then Restart%num3d = Restart%num3d + 3 @@ -129,7 +126,6 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & if (Model%do_mynnedmf) then Restart%num3d = Restart%num3d + 9 endif -#endif allocate (Restart%name2d(Restart%num2d)) allocate (Restart%name3d(Restart%num3d)) @@ -184,7 +180,6 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & ! print *,'in restart 2d field, Restart%name2d(',offset+idx,')=',trim(Restart%name2d(offset+idx)) enddo -#ifdef CCPP !--- RAP/HRRR-specific variables, 2D num = offset + ndiag_rst ! GF @@ -244,7 +239,6 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%data(nb,num)%var2p => Coupling(nb)%nifa2d(:) enddo endif -#endif !--- phy_f3d variables do num = 1,Model%ntot3d @@ -262,7 +256,7 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%data(nb,num)%var3p => IntDiag(nb)%refl_10cm(:,:) enddo endif -#ifdef CCPP + if (Model%lrefres) then num = Model%ntot3d+1 else @@ -335,7 +329,6 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%data(nb,num)%var3p => Tbd(nb)%cov(:,:) enddo endif -#endif end subroutine GFS_restart_populate diff --git a/ccpp/driver/makefile b/ccpp/driver/makefile deleted file mode 100644 index c64441135..000000000 --- a/ccpp/driver/makefile +++ /dev/null @@ -1,71 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../../conf/configure.fv3 - else - $(error "../../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build CCPP layer ...) - $(info ) -endif - -CCPP_DRIVER = CCPP_driver.F90 - -LIBRARY = libccppdriver.a - -# Needed for ccpp_data.mod, fv_arrays_mod.mod, ... -FFLAGS += -I$(FMS_DIR) -I../../gfsphysics -I../../atmos_cubed_sphere - -#CPPDEFS += -DNEW_TAUCTMAX -DSMALL_PE -DNEMS_GSM -DINTERNAL_FILE_NML - -# Set flags for 32-bit dynamics build -ifeq ($(DYN32),Y) -CPPDEFS += -DOVERLOAD_R4 -endif - -SRCS_F90 = \ - CCPP_driver.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -# Do preprocessing of the CCPP driver in two steps to be -# able to look at the actual .f90 file that gets compiled -./CCPP_driver.o: ./CCPP_driver.F90 - $(CPP) $(CPPDEFS) $(CPPFLAGS) $< > $*.tmp.f90 - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $*.tmp.f90 -o $@ - -.PHONY: clean -clean: - @echo "Cleaning CCPP_layer ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.tmp.f90 *.o */*.o *.mod *.i90 *.lst *.i depend - -MKDEPENDS = ../../mkDepends.pl -include ../../conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/ccpp/framework b/ccpp/framework index 16271557a..a29c343ef 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 16271557a692b2c6871bf4e2209b8035a9addc52 +Subproject commit a29c343ef1d5eed98b138fa30bc83a5ec0497f09 diff --git a/ccpp/physics b/ccpp/physics index 1fd346fc6..b2c7bd5ef 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 1fd346fc6eabc6d26f6dfca6056323baf478a082 +Subproject commit b2c7bd5ef36141ff4888f93b84c4216e9ee2b9fb diff --git a/ccpp/set_compilers.sh b/ccpp/set_compilers.sh deleted file mode 100755 index 894017cb0..000000000 --- a/ccpp/set_compilers.sh +++ /dev/null @@ -1,101 +0,0 @@ -#!/bin/bash - -# The list of compilers here must cover all system listed in build_ccpp.sh -> VALID_MACHINES -case "$MACHINE_ID" in - wcoss_cray) - export LD=ftn - export CC=cc - export CXX=CC - export FC=ftn - export F77=ftn - export F90=ftn - ;; - wcoss_dell_p3) - export CC=mpiicc - export CXX=mpiicpc - export FC=mpiifort - export F77=mpiifort - export F90=mpiifort - ;; - gaea.intel) - export LD=ftn - export CC=cc - export CXX=CC - export FC=ftn - export F77=ftn - export F90=ftn - ;; - jet.intel) - export CC=mpiicc - export CXX=mpiicpc - export FC=mpiifort - export F77=mpiifort - export F90=mpiifort - ;; - hera.intel) - export CC=mpiicc - export CXX=mpiicpc - export FC=mpiifort - export F77=mpiifort - export F90=mpiifort - ;; - hera.gnu) - export CC=mpicc - export CXX=mpicxx - export FC=mpif90 - export F77=mpif77 - export F90=mpif90 - ;; - orion.intel) - export CC=mpiicc - export CXX=mpiicpc - export FC=mpiifort - export F77=mpiifort - export F90=mpiifort - ;; - cheyenne.intel) - export CC=mpicc - export CXX=mpicxx - export FC=mpif90 - export F77=mpif77 - export F90=mpif90 - ;; - cheyenne.gnu) - export CC=mpicc - export CXX=mpicxx - export FC=mpif90 - export F77=mpif77 - export F90=mpif90 - ;; - endeavor.intel) - export CC=mpiicc - export CXX=mpiicpc - export FC=mpiifort - export F77=mpiifort - export F90=mpiifort - ;; - stampede.intel) - export CC=mpicc - export CXX=mpicxx - export FC=mpif90 - export F77=mpif77 - export F90=mpif90 - ;; - macosx.gnu) - # set in generic modulefile - ;; - linux.intel) - # set in generic modulefile - ;; - linux.gnu) - # set in generic modulefile - ;; - linux.pgi) - # set in generic modulefile - ;; - *) - echo "ERROR: MACHINE_ID ${MACHINE_ID} not configured in set_compilers.sh" - exit 1 -esac - -echo "Compilers set for ${MACHINE_ID}." diff --git a/ccpp/suites/suite_FV3_GFS_v15p2_RRTMGP.xml b/ccpp/suites/suite_FV3_GFS_v15p2_RRTMGP.xml index 244345a95..983b7b2e7 100644 --- a/ccpp/suites/suite_FV3_GFS_v15p2_RRTMGP.xml +++ b/ccpp/suites/suite_FV3_GFS_v15p2_RRTMGP.xml @@ -20,6 +20,7 @@ GFS_suite_interstitial_rad_reset GFS_rrtmgp_pre GFS_rrtmgp_gfdlmp_pre + GFS_rrtmgp_cloud_overlap_pre GFS_cloud_diagnostics GFS_rrtmgp_sw_pre rrtmgp_sw_gas_optics diff --git a/ccpp/suites/suite_FV3_GFS_v16beta.xml b/ccpp/suites/suite_FV3_GFS_v16.xml similarity index 98% rename from ccpp/suites/suite_FV3_GFS_v16beta.xml rename to ccpp/suites/suite_FV3_GFS_v16.xml index 2ae5743fb..a7aab3689 100644 --- a/ccpp/suites/suite_FV3_GFS_v16beta.xml +++ b/ccpp/suites/suite_FV3_GFS_v16.xml @@ -1,6 +1,6 @@ - + diff --git a/ccpp/suites/suite_FV3_GFS_v16beta_RRTMGP.xml b/ccpp/suites/suite_FV3_GFS_v16_RRTMGP.xml similarity index 97% rename from ccpp/suites/suite_FV3_GFS_v16beta_RRTMGP.xml rename to ccpp/suites/suite_FV3_GFS_v16_RRTMGP.xml index d27a3f7d3..92d040f6b 100644 --- a/ccpp/suites/suite_FV3_GFS_v16beta_RRTMGP.xml +++ b/ccpp/suites/suite_FV3_GFS_v16_RRTMGP.xml @@ -1,6 +1,6 @@ - + @@ -20,6 +20,7 @@ GFS_suite_interstitial_rad_reset GFS_rrtmgp_pre GFS_rrtmgp_gfdlmp_pre + GFS_rrtmgp_cloud_overlap_pre GFS_cloud_diagnostics GFS_rrtmgp_sw_pre rrtmgp_sw_gas_optics diff --git a/ccpp/suites/suite_FV3_GFS_v16beta_coupled.xml b/ccpp/suites/suite_FV3_GFS_v16_coupled.xml similarity index 98% rename from ccpp/suites/suite_FV3_GFS_v16beta_coupled.xml rename to ccpp/suites/suite_FV3_GFS_v16_coupled.xml index a131fb380..bb0fb859b 100644 --- a/ccpp/suites/suite_FV3_GFS_v16beta_coupled.xml +++ b/ccpp/suites/suite_FV3_GFS_v16_coupled.xml @@ -1,6 +1,6 @@ - + diff --git a/ccpp/suites/suite_FV3_GFS_v16beta_flake.xml b/ccpp/suites/suite_FV3_GFS_v16_flake.xml similarity index 98% rename from ccpp/suites/suite_FV3_GFS_v16beta_flake.xml rename to ccpp/suites/suite_FV3_GFS_v16_flake.xml index b7ac405ee..faf1a3f26 100644 --- a/ccpp/suites/suite_FV3_GFS_v16beta_flake.xml +++ b/ccpp/suites/suite_FV3_GFS_v16_flake.xml @@ -1,6 +1,6 @@ - + diff --git a/ccpp/suites/suite_FV3_GFS_v16beta_no_nsst.xml b/ccpp/suites/suite_FV3_GFS_v16_no_nsst.xml similarity index 98% rename from ccpp/suites/suite_FV3_GFS_v16beta_no_nsst.xml rename to ccpp/suites/suite_FV3_GFS_v16_no_nsst.xml index a73d1b561..52ff83969 100644 --- a/ccpp/suites/suite_FV3_GFS_v16beta_no_nsst.xml +++ b/ccpp/suites/suite_FV3_GFS_v16_no_nsst.xml @@ -1,6 +1,6 @@ - + diff --git a/ccpp/suites/suite_FV3_GFS_v16_thompson.xml b/ccpp/suites/suite_FV3_GFS_v16_thompson.xml new file mode 100644 index 000000000..67e552d46 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v16_thompson.xml @@ -0,0 +1,91 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + phys_tend + + + + diff --git a/ccpp/suites/suite_FV3_GFS_v16b_ugwpv1.xml b/ccpp/suites/suite_FV3_GFS_v16b_ugwpv1.xml new file mode 100644 index 000000000..7a2f7b38d --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v16b_ugwpv1.xml @@ -0,0 +1,94 @@ + + + + + + + fv_sat_adj + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + ugwpv1_gsldrag + ugwpv1_gsldrag_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + gfdl_cloud_microphys + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + phys_tend + + + + diff --git a/ccpp/suites/suite_FV3_GSD_v0_RRTMGP.xml b/ccpp/suites/suite_FV3_GSD_v0_RRTMGP.xml new file mode 100644 index 000000000..76f22cfed --- /dev/null +++ b/ccpp/suites/suite_FV3_GSD_v0_RRTMGP.xml @@ -0,0 +1,101 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmgp_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmgp_pre + GFS_rrtmgp_thompsonmp_pre + GFS_rrtmgp_cloud_overlap_pre + GFS_cloud_diagnostics + GFS_rrtmgp_sw_pre + rrtmgp_sw_gas_optics + rrtmgp_sw_aerosol_optics + rrtmgp_sw_cloud_optics + rrtmgp_sw_cloud_sampling + rrtmgp_sw_rte + GFS_rrtmgp_sw_post + rrtmgp_lw_pre + rrtmgp_lw_gas_optics + rrtmgp_lw_aerosol_optics + rrtmgp_lw_cloud_optics + rrtmgp_lw_cloud_sampling + rrtmgp_lw_rte + sgscloud_radpost + GFS_rrtmgp_lw_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_ruc + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + cu_gf_driver_pre + cu_gf_driver + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + cu_gf_driver_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + phys_tend + + + + diff --git a/conf/make.rules b/conf/make.rules deleted file mode 100644 index d01397bf4..000000000 --- a/conf/make.rules +++ /dev/null @@ -1,30 +0,0 @@ -.SUFFIXES: -.SUFFIXES: .F90 .f90 .F .f .o .c - -.F90.f90: - $(CPP) $(CPPFLAGS) $< > $*.f90 - -.F.f: - $(CPP) $(CPPFLAGS) $< > $*.f - -.f.o: - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $< -o $@ - -.f90.o: - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $< -o $@ - -.F.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) $(OTHER_FFLAGS) -c $< -o $@ - -.F90.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) $(OTHER_FFLAGS) -c $< -o $@ - -.c.o: - $(CC) $(CPPDEFS) $(CPPFLAGS) $(CFLAGS) $(OTHERFLAGS) $(OTHER_CFLAGS) -c $< -o $@ - -depend: $(DEPEND_FILES) makefile - @echo "Building dependencies ..." - @ls -1 $(DEPEND_FILES) > Srcfiles - @echo "." > Filepath - @$(MKDEPENDS) -m Filepath Srcfiles > depend - @$(RM) -f Filepath Srcfiles diff --git a/cpl/makefile b/cpl/makefile deleted file mode 100644 index f3aa91562..000000000 --- a/cpl/makefile +++ /dev/null @@ -1,66 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 io ...) - $(info ) -endif - -LIBRARY = libfv3cpl.a - -#FFLAGS += -I$(FMS_DIR) - -SRCS_f = - -SRCS_f90 = - -SRCS_F = - -SRCS_F90 = ./module_cplfields.F90 \ - ./module_cap_cpl.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -module_cplfields.o: module_cplfields.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_cplfields.F90 -module_cap_cpl.o: module_cap_cpl.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_cap_cpl.F90 - -.PHONY: clean -clean: - @echo "Cleaning io ... " - @echo - $(RM) -f $(LIBRARY) *.o *.mod *.lst *.i90 depend - -MKDEPENDS = ../mkDepends.pl -include ../conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/gfsphysics/CMakeLists.txt b/gfsphysics/CMakeLists.txt index 819c5b4c0..f516e4709 100644 --- a/gfsphysics/CMakeLists.txt +++ b/gfsphysics/CMakeLists.txt @@ -12,182 +12,7 @@ if(32BIT) endif() set(CCPP_SOURCES - physics/mersenne_twister.f - physics/namelist_soilveg.f - physics/set_soilveg.f - - physics/noahmp_tables.f90 - - physics/GFDL_parse_tracers.F90 - physics/physcons.F90 - - CCPP_layer/CCPP_data.F90 - ${CMAKE_BINARY_DIR}/FV3/ccpp/physics/ccpp_static_api.F90 - - GFS_layer/GFS_abstraction_layer.F90 - GFS_layer/GFS_diagnostics.F90 - GFS_layer/GFS_driver.F90 - GFS_layer/GFS_restart.F90 -) - -set(IPD_SOURCES - - physics/cnvc90.f - physics/co2hc.f - physics/date_def.f - physics/dcyc2.f - physics/dcyc2.pre.rad.f - physics/efield.f - physics/get_prs.f - physics/gocart_tracer_config_stub.f - physics/gscond.f - physics/gscondp.f - physics/gwdc.f - physics/gwdps.f - physics/ugwp_driver_v0.f - physics/cires_orowam2017.f - physics/h2o_def.f - physics/h2oc.f - physics/h2ohdc.f - physics/h2ophys.f - physics/ideaca.f - physics/idea_co2.f - physics/idea_composition.f - physics/idea_dissipation.f - physics/idea_h2o.f - physics/idea_ion.f - physics/idea_o2_o3.f - physics/idea_phys.f - physics/idea_solar_heating.f - physics/idea_tracer.f - physics/iounitdef.f - physics/lrgsclr.f - physics/mersenne_twister.f - physics/mfpbl.f - physics/mfpblt.f - physics/mfpbltq.f - physics/mfscu.f - physics/mfscuq.f - physics/module_bfmicrophysics.f - physics/moninedmf.f - physics/moninedmf_hafs.f - physics/moninp.f - physics/moninp1.f - physics/moninq.f - physics/moninq1.f - physics/moninshoc.f - physics/mstadb.f - physics/mstadbtn.f - physics/mstadbtn2.f - physics/mstcnv.f - physics/namelist_soilveg.f - physics/ozne_def.f - physics/iccn_def.f - physics/aerclm_def.f - physics/ozphys.f - physics/ozphys_2015.f - physics/physparam.f - physics/precpd.f - physics/precpd_shoc.f - physics/precpdp.f - physics/precpd_shoc.f - physics/progt2.f - physics/progtm_module.f - physics/rad_initialize.f - physics/radiation_aerosols.f - physics/radiation_astronomy.f - physics/radiation_clouds.f - physics/radiation_gases.f - physics/radiation_surface.f - physics/radlw_datatb.f - physics/radlw_main.f - physics/radlw_param.f - physics/radsw_datatb.f - physics/radsw_main.f - physics/radsw_param.f - physics/rascnvv2.f - physics/rayleigh_damp.f - physics/rayleigh_damp_mesopause.f - physics/samfaerosols.f - physics/samfdeepcnv.f - physics/samfshalcnv.f - physics/sascnv.f - physics/sascnvn.f - physics/satmedmfvdif.f - physics/satmedmfvdifq.f - physics/set_soilveg.f - physics/sfc_cice.f - physics/sfc_diag.f - physics/sfc_diff.f - physics/sfc_drv.f - physics/sfc_noahmp_drv.f - physics/sfc_nst.f - physics/sfc_ocean.f - physics/sfc_sice.f - physics/sflx.f - physics/shalcnv.f - physics/shalcv.f - physics/shalcv_1lyr.f - physics/shalcv_fixdp.f - physics/shalcv_opr.f - physics/tracer_const_h.f - physics/tridi2t3.f - - physics/calpreciptype.f90 - physics/funcphys.f90 - physics/gcm_shoc.f90 - physics/get_prs_fv3.f90 - physics/h2ointerp.f90 - physics/module_nst_model.f90 - physics/module_nst_parameters.f90 - physics/module_nst_water_prop.f90 - physics/ozinterp.f90 - physics/module_wrf_utl.f90 physics/noahmp_tables.f90 - physics/module_sf_noahmplsm.f90 - physics/module_sf_noahmp_glacier.f90 - physics/iccninterp.f90 - physics/aerinterp.f90 - physics/wam_f107_kp_mod.f90 - - physics/aer_cloud.F - physics/cldmacro.F - physics/cldwat2m_micro.F - physics/gfs_phy_tracer_config.F - physics/machine.F - physics/num_parthds.F - physics/sfcsub.F - physics/wv_saturation.F - - physics/GFDL_parse_tracers.F90 - physics/gcycle.F90 - physics/cires_ugwp_initialize.F90 - physics/cires_ugwp_module.F90 - physics/cires_ugwp_utils.F90 - physics/cires_ugwp_triggers.F90 - physics/cires_ugwp_solvers.F90 - physics/cires_vert_lsatdis.F90 - physics/cires_vert_orodis.F90 - physics/cires_vert_wmsdis.F90 - physics/gfdl_cloud_microphys.F90 - physics/micro_mg_utils.F90 - physics/micro_mg2_0.F90 - physics/micro_mg3_0.F90 - physics/m_micro_driver.F90 - physics/cs_conv.F90 - physics/module_mp_radar.F90 - physics/module_mp_thompson_gfs.F90 - physics/module_mp_wsm6_fv3.F90 - physics/physcons.F90 - physics/surface_perturbation.F90 - - GFS_layer/GFS_abstraction_layer.F90 - GFS_layer/GFS_diagnostics.F90 - GFS_layer/GFS_driver.F90 - GFS_layer/GFS_physics_driver.F90 - GFS_layer/GFS_radiation_driver.F90 - GFS_layer/GFS_restart.F90 - GFS_layer/GFS_typedefs.F90 ) list(APPEND _gfsphysics_defs_private NEMS_GSM @@ -199,31 +24,18 @@ if(MULTI_GASES) list(APPEND _gfsphysics_defs_private MULTI_GASES) endif() -if(CCPP) - list(APPEND _gfsphysics_srcs ${CCPP_SOURCES}) - list(APPEND _gfsphysics_defs_private CCPP) - if(DYN32) - list(APPEND _gfsphysics_defs_private OVERLOAD_R4) - endif() -else() - list(APPEND _gfsphysics_srcs ${IPD_SOURCES}) +list(APPEND _gfsphysics_srcs ${CCPP_SOURCES}) +list(APPEND _gfsphysics_defs_private CCPP) +if(DYN32) + list(APPEND _gfsphysics_defs_private OVERLOAD_R4) endif() add_library(gfsphysics ${_gfsphysics_srcs}) -if(CCPP) - target_include_directories(gfsphysics PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src - ${CMAKE_BINARY_DIR}/FV3/ccpp/physics) - target_link_libraries(gfsphysics PRIVATE ccppphys ccpp) -endif() +target_include_directories(gfsphysics PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src + ${CMAKE_BINARY_DIR}/FV3/ccpp/physics) +target_link_libraries(gfsphysics PRIVATE ccppphys ccpp) -if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") - if(CMAKE_Platform MATCHES "jet") - set_property(SOURCE physics/radiation_aerosols.f APPEND_STRING PROPERTY COMPILE_FLAGS "-axSSE4.2,AVX,CORE-AVX-I") - else() - set_property(SOURCE physics/radiation_aerosols.f APPEND_STRING PROPERTY COMPILE_FLAGS "-xCORE-AVX-I") - endif() -endif() set_property(SOURCE GFS_layer/GFS_diagnostics.F90 APPEND_STRING PROPERTY COMPILE_FLAGS "-O0") set_target_properties(gfsphysics PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod) diff --git a/gfsphysics/GFS_layer/GFS_abstraction_layer.F90 b/gfsphysics/GFS_layer/GFS_abstraction_layer.F90 deleted file mode 100644 index 1a63a8d8a..000000000 --- a/gfsphysics/GFS_layer/GFS_abstraction_layer.F90 +++ /dev/null @@ -1,94 +0,0 @@ -module physics_abstraction_layer - - use machine, only: kind_phys - 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 -#ifdef CCPP - use GFS_typedefs, only: interstitial_type => GFS_interstitial_type, & - data_type => GFS_data_type -#endif - - - use GFS_restart, only: restart_type => GFS_restart_type, & - restart_populate => GFS_restart_populate - - use GFS_diagnostics, only: diagnostic_type => GFS_externaldiag_type, & - diagnostic_populate => GFS_externaldiag_populate - -#ifdef CCPP - use GFS_driver, only: initialize => GFS_initialize -#else - 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 -#endif - -#ifndef CCPP - ! DH* even in the non-CCPP build, these don't get used (same for NAM physics) - integer :: num_time_vary_steps = 1 - integer :: num_rad_steps = 1 - integer :: num_phys_steps = 2 - ! *DH -#endif - -!------------------------- -! public physics dataspec -!------------------------- - public kind_phys - -!---------------------- -! 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 restart_type - public diagnostic_type -#ifdef CCPP - public interstitial_type -#endif - -!------------------ -! public variables -!------------------ -#ifndef CCPP - ! DH* even in the non-CCPP build, these don't get used (same for NAM physics) - public num_time_vary_steps - public num_rad_steps - public num_phys_steps - ! *DH -#endif - -!-------------------------- -! public physics functions -!-------------------------- - public initialize -#ifndef CCPP - public time_vary_step - public radiation_step1 - public physics_step1 - public physics_step2 -#endif - -CONTAINS - -end module physics_abstraction_layer diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 deleted file mode 100644 index 2d676d8d4..000000000 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ /dev/null @@ -1,1114 +0,0 @@ -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 -#ifdef CCPP - use GFS_typedefs, only: GFS_interstitial_type -#else - use module_radiation_driver, only: GFS_radiation_driver, radupdate - use module_physics_driver, only: GFS_physics_driver - use funcphys, only: gfuncphys - use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_init -#endif - use physcons, only: gravit => con_g, rair => con_rd, & - rh2o => con_rv, & - tmelt => con_ttp, cpair => con_cp, & - latvap => con_hvap, latice => con_hfus - - 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 -#ifndef CCPP - 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 -#endif - - CONTAINS -!******************************************************************************************* - - -!-------------- -! GFS initialze -!-------------- -!## CCPP ## For the CCPP, much (*but not all*) of the code in this routine has been -! put into CCPP interstitial schemes, especially their init stages. Where this has been -! done, the code is wrapped in both preprocessor directives and comments describing the -! location of the code for CCPP execution. Lines in this routine that are not wrapped in -! a CCPP comment are still executed through this subroutine. - subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & - Coupling, Grid, Tbd, Cldprop, Radtend, & -#ifdef CCPP - Diag, Interstitial, communicator, & - ntasks, Init_parm) -#else - Diag, Init_parm) -#endif - -#ifdef _OPENMP - use omp_lib -#endif - -#ifndef CCPP -! use module_microphysics, only: gsmconst - use cldwat2m_micro, only: ini_micro - use micro_mg2_0, only: micro_mg_init2_0 => micro_mg_init - use micro_mg3_0, only: micro_mg_init3_0 => micro_mg_init - use aer_cloud, only: aer_cloud_init - use module_ras, only: ras_init - use module_mp_thompson, only: thompson_init - use module_mp_wsm6, only: wsm6init - use cires_ugwp_module, only: cires_ugwp_init -#endif - - !--- 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(:) -#ifdef CCPP - type(GFS_interstitial_type), intent(inout) :: Interstitial(:) - integer, intent(in) :: communicator - integer, intent(in) :: ntasks -#endif - type(GFS_init_type), intent(in) :: Init_parm - - - !--- local variables - integer :: nb - integer :: nblks -#ifdef CCPP - integer :: nt - integer :: nthrds - logical :: non_uniform_blocks -#endif - integer :: ntrac - integer :: ix -#ifndef CCPP - integer :: blocksize,k - real(kind=kind_phys), allocatable :: si(:) - real(kind=kind_phys), parameter :: p_ref = 101325.0d0 -#endif - - nblks = size(Init_parm%blksz) - ntrac = size(Init_parm%tracer_names) - allocate (blksz(nblks)) - blksz(:) = Init_parm%blksz(:) - -#ifdef CCPP -#ifdef _OPENMP - nthrds = omp_get_max_threads() -#else - nthrds = 1 -#endif -#endif - - !--- 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%iau_offset, Init_parm%bdat, & - Init_parm%cdat, Init_parm%tracer_names, & - Init_parm%input_nml_file, Init_parm%tile_num, & - Init_parm%blksz,Init_parm%ak, Init_parm%bk & -#ifdef CCPP - ,Init_parm%restart, Init_parm%hydrostatic, & - communicator, ntasks, nthrds & -#endif - ) - -!## CCPP ##* These are called automatically in GFS_phys_time_vary.fv3.F90/GFS_phys_time_vary_init -! as part of CCPP physics init stage. The reason why these are in GFS_phys_time_vary_init and not -! in ozphys/h2ophys is that the ozone and h2o interpolation of the data read here is done in -! GFS_phys_time_vary_run, i.e. all work related to the ozone/h2o input data is in GFS_phys_time_vary, -! while ozphys/h2ophys are applying ozone/h2o forcing to the model state. -#ifndef CCPP - call read_o3data (Model%ntoz, Model%me, Model%master) - call read_h2odata (Model%h2o_phys, Model%me, Model%master) - if (Model%iaerclm) then - call read_aerdata (Model%me,Model%master,Model%iflip,Model%idate) - endif - if (Model%iccn == 1) then - call read_cidata ( Model%me, Model%master) - endif -#endif -!*## CCPP ## - - do nb = 1,nblks - ix = Init_parm%blksz(nb) -! write(0,*)' ix in gfs_driver=',ix,' nb=',nb - call Statein (nb)%create (ix, Model) - call Stateout (nb)%create (ix, Model) - call Sfcprop (nb)%create (ix, Model) - call Coupling (nb)%create (ix, Model) - call Grid (nb)%create (ix, Model) -#ifndef CCPP - call Tbd (nb)%create (ix, nb, Model) -#else - call Tbd (nb)%create (ix, Model) -#endif - call Cldprop (nb)%create (ix, Model) - call Radtend (nb)%create (ix, Model) -!--- internal representation of diagnostics - call Diag (nb)%create (ix, Model) - enddo - -!## CCPP ##* This logic deals with non-uniform block sizes for CCPP. When non-uniform block sizes -! are used, it is required that only the last block has a different (smaller) size than -! all other blocks. This is the standard in FV3. If this is the case, set non_uniform_blocks -! to .true. and initialize nthreads+1 elements of the interstitial array. The extra element -! will be used by the thread that runs over the last, smaller block. -#ifdef CCPP - - if (minval(Init_parm%blksz)==maxval(Init_parm%blksz)) then - non_uniform_blocks = .false. - elseif (all(minloc(Init_parm%blksz)==(/size(Init_parm%blksz)/))) then - non_uniform_blocks = .true. - else - write(0,'(2a)') 'For non-uniform blocksizes, only the last element ', & - 'in Init_parm%blksz can be different from the others' - stop - endif - -! Initialize the Interstitial data type in parallel so that -! each thread creates (touches) its Interstitial(nt) first. -!$OMP parallel do default (shared) & -!$OMP schedule (static,1) & -!$OMP private (nt) - do nt=1,nthrds - call Interstitial (nt)%create (maxval(Init_parm%blksz), Model) - enddo -!$OMP end parallel do - - if (non_uniform_blocks) then - call Interstitial (nthrds+1)%create (Init_parm%blksz(nblks), Model) - end if -#endif -!*## CCPP ## - - !--- populate the grid components - call GFS_grid_populate (Grid, Init_parm%xlon, Init_parm%xlat, Init_parm%area) - -!## CCPP ##* GFS_phys_time_vary.fv3.F90/GFS_phys_time_vary_init; Note: this is run -! automatically during the CCPP physics initialization stage. -#ifndef CCPP - !--- 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 - - !--- read in and initialize IN and CCN - if (Model%iccn == 1) then - do nb = 1, nblks - call setindxci (Init_parm%blksz(nb), Grid(nb)%xlat_d, Grid(nb)%jindx1_ci, & - Grid(nb)%jindx2_ci, Grid(nb)%ddy_ci, Grid(nb)%xlon_d, & - Grid(nb)%iindx1_ci,Grid(nb)%iindx2_ci,Grid(nb)%ddx_ci) - enddo - endif - - !--- read in and initialize aerosols - if (Model%iaerclm) then - do nb = 1, nblks - call setindxaer (Init_parm%blksz(nb),Grid(nb)%xlat_d,Grid(nb)%jindx1_aer, & - Grid(nb)%jindx2_aer, Grid(nb)%ddy_aer, Grid(nb)%xlon_d, & - Grid(nb)%iindx1_aer,Grid(nb)%iindx2_aer,Grid(nb)%ddx_aer, & - Init_parm%me, Init_parm%master ) - 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 -#endif -!*## CCPP ## - -!## CCPP ##* GFS_time_vary_pre.fv3.F90/GFS_time_vary_pre_init; Note: This is called -! during the CCPP physics initialization stage. -#ifndef CCPP - !--- Call gfuncphys (funcphys.f) to compute all physics function tables. - call gfuncphys () -#endif -!*## CCPP ## - -! call gsmconst (Model%dtp, Model%me, .TRUE.) ! This is for Ferrier microphysics - notused - moorthi - -#ifndef CCPP -!## CCPP ##* GFS_typedefs.F90/control_initialize - !--- 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)) -!*## CCPP ## - -!## CCPP ##* This functionality is now in GFS_rrtmg_setup.F90/GFS_rrtmg_setup_init; Note: it is automatically -! called during the CCPP physics initialization stage. - 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%icliq_sw, Model%crick_proof, Model%ccnorm,& - Model%imp_physics, Model%norad_precip, Model%idate, Model%iflip, Model%me) -!*## CCPP ## - deallocate (si) -#endif - -! microphysics initialization calls -! --------------------------------- - - if (Model%imp_physics == Model%imp_physics_mg) then !--- initialize Morrison-Gettelman microphysics -#ifndef CCPP -!## CCPP ##* m_micro.F90/m_micro_init; Note: This is automatically called during the -! CCPP physics initialization stage. - if (Model%fprcp <= 0) then - call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice(1)) - elseif (Model%fprcp == 1) then - call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, Model%mg_rhmini, & - Model%mg_dcs, Model%mg_ts_auto_ice, & - Model%mg_qcvar, & - Model%microp_uniform, Model%do_cldice, & - Model%hetfrz_classnuc, & - Model%mg_precip_frac_method, & - Model%mg_berg_eff_factor, & - Model%sed_supersat, Model%do_sb_physics, & - Model%mg_do_ice_gmao, Model%mg_do_liq_liu, & - Model%mg_nccons, Model%mg_nicons, & - Model%mg_ncnst, Model%mg_ninst) - elseif (Model%fprcp == 2) then - call micro_mg_init3_0(kind_phys, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, Model%mg_rhmini, & - Model%mg_dcs, Model%mg_ts_auto_ice, & - Model%mg_qcvar, & - Model%mg_do_hail, Model%mg_do_graupel, & - Model%microp_uniform, Model%do_cldice, & - Model%hetfrz_classnuc, & - Model%mg_precip_frac_method, & - Model%mg_berg_eff_factor, & - Model%sed_supersat, Model%do_sb_physics, & - Model%mg_do_ice_gmao, Model%mg_do_liq_liu, & - Model%mg_nccons, Model%mg_nicons, & - Model%mg_ncnst, Model%mg_ninst, & - Model%mg_ngcons, Model%mg_ngnst) - else - write(0,*)' Model%fprcp = ',Model%fprcp,' is not a valid option - aborting' - stop - - endif - call aer_cloud_init () -!*## CCPP ## -#endif -! - elseif (Model%imp_physics == Model%imp_physics_thompson) then !--- initialize Thompson Cloud microphysics - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with Thompson MP -- shutting down' - stop - endif -!## CCPP ##* mp_thompson.F90/mp_thompson_init; Note: This is automatically called during the -! CCPP physics initialization stage. The check for SHOC is not included in the initialization -! (it is only performed above as part of the current routine). -#ifndef CCPP - call thompson_init() !--- add aerosol version later - if(Model%ltaerosol) then - print *,'Aerosol awareness is not included in this version of Thompson MP -- shutting down' - stop - endif -!*## CCPP ## - elseif(Model%imp_physics == Model%imp_physics_wsm6) then !--- initialize WSM6 Cloud microphysics - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with WSM6 -- shutting down' - stop - endif - call wsm6init() -#endif -! - else if(Model%imp_physics == Model%imp_physics_gfdl) then !--- initialize GFDL Cloud microphysics -!## CCPP ##* gfdl_cloud_microphys.F90/gfdl_cloud_microphys_init; Note: This is automatically called during the -! CCPP physics initialization stage. The check for SHOC is included in the GFDL microphysics initialization routine. -#ifndef CCPP - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with GFDL MP -- shutting down' - stop - endif - call gfdl_cloud_microphys_init (Model%me, Model%master, Model%nlunit, Model%input_nml_file, & - Init_parm%logunit, Model%fn_nml) -#endif -!*## CCPP ## - endif - -#ifndef CCPP - !--- initialize ras - if (Model%ras) call ras_init (Model%levs, Model%me) -#endif - -!## CCPP ##* sfc_drv.f/lsm_noah_init and sfc_noahmp_drv.f/noahmpdrv_init; Note: This is -! automatically called during the CCPP physics initialization stage. -#if 1 -!ifndef CCPP - !--- initialize soil vegetation - call set_soilveg(Model%me, Model%isot, Model%ivegsrc, Model%nlunit) -#endif -!*## CCPP ## - - !--- 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 - -#ifndef CCPP -!---- initialization of cires_ugwp . -! if ( Model%me == Model%master) print *, ' VAY-nml ', Model%fn_nml -! if ( Model%me == Model%master) print *, ' VAY-nml2 ', Model%input_nml_file - if (Model%do_ugwp .or. Model%cdmbgwd(3) > 0.0) then -! if ( Model%me == Model%master) print *, ' VAY-nml ', Model%fn_nml, -! Model%input_nml_file - call cires_ugwp_init(Model%me, Model%master, Model%nlunit, Init_parm%logunit, & - Model%fn_nml, Model%lonr, Model%latr, Model%levs, & - Init_parm%ak, Init_parm%bk, p_ref, Model%dtp, & - Model%cdmbgwd(1:2), Model%cgwf, Model%prslrd0, Model%ral_ts) - endif -#endif - - !--- sncovr may not exist in ICs from chgres. - !--- FV3GFS handles this as part of the IC ingest - !--- this note is placed here to alert users to study - !--- the FV3GFS_io.F90 module - -#ifndef CCPP - if(Model%do_ca .and. Model%ca_global)then - - do nb = 1,nblks - do k=1,Model%levs - if (Model%si(k) .lt. 0.1 .and. Model%si(k) .gt. 0.025) then - Coupling(nb)%vfact_ca(k) = (Model%si(k)-0.025)/(0.1-0.025) - else if (Model%si(k) .lt. 0.025) then - Coupling(nb)%vfact_ca(k) = 0.0 - else - Coupling(nb)%vfact_ca(k) = 1.0 - endif - enddo - enddo - - do nb = 1,nblks - Coupling(nb)%vfact_ca(2)=Coupling(nb)%vfact_ca(3)*0.5 - Coupling(nb)%vfact_ca(1)=0.0 - enddo - - endif -#endif - - end subroutine GFS_initialize - - -#ifndef CCPP -!------------------------------------------------------------------------- -! 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_rad, kdt_iau, blocksize - 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 - real(kind=kind_phys), parameter :: cn_hr = 3600._kind_phys - -!## CCPP ##* GFS_time_vary_pre.fv3.F90/GFS_time_vary_pre_run - 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) - !--- allow for radiation to be called on every physics time step, if needed - if (Model%nsswr == 1) Model%lsswr = .true. - if (Model%nslwr == 1) Model%lslwr = .true. - - !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) -! - 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 -!*## CCPP ## - -!## CCPP ##* All functionality except for the call to radupdate is now in -! GFS_rad_time_vary.fv3.F90/GFS_rad_time_vary_run. The call to radupdate is now -! in GFS_rrtmg_setup.F90/GFS_rrtmg_setup_run. - !--- radiation time varying routine - if (Model%lsswr .or. Model%lslwr) then - call GFS_rad_time_vary (Model, Statein, Tbd, sec) - endif -!*## CCPP ## - -!## CCPP ##* All functionality is now in GFS_phys_time_vary.fv3.F90/GFS_phys_time_vary_run - !--- physics time varying routine - call GFS_phys_time_vary (Model, Grid, Tbd, Statein) - - !--- repopulate specific time-varying sfc properties for AMIP/forecast runs - if (Model%nscyc > 0) then - if (mod(Model%kdt,Model%nscyc) == 1) THEN - call gcycle (nblks, Model, Grid(:), Sfcprop(:), Cldprop(:)) - endif - ! if not updating surface params through fcast, perturb params once at start of fcast - endif - - !--- determine if diagnostics buckets need to be cleared - sec_zero = nint(Model%fhzero*con_hr) - if (sec_zero >= nint(max(Model%fhswr,Model%fhlwr))) then - if (mod(Model%kdt,Model%nszero) == 1) then - do nb = 1,nblks - call Diag(nb)%rad_zero (Model) - call Diag(nb)%phys_zero (Model) - !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED - enddo - endif - else - if (mod(Model%kdt,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 - kdt_rad = nint(min(Model%fhswr,Model%fhlwr)/Model%dtp) - if (mod(Model%kdt, kdt_rad) == 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 - endif -!*## CCPP ## -!## CCPP ## This is not yet in the CCPP - 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 -!*## CCPP ## - -! 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) - 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 -!*## CCPP ## - end subroutine GFS_time_vary_step - -!## CCPP ##* GFS_stochastics.F90/GFS_stochastics_run -!------------------------------------------------------------------------- -! 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(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 :: k, i - real(kind=kind_phys) :: upert, vpert, tpert, qpert, qnew,sppt_vwt - real(kind=kind_phys),dimension(size(Statein%tgrs,1),size(Statein%tgrs,2)) :: ca1 - - 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_ca .and. Model%ca_global) 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 - - ca1(i,k)=((Coupling%ca1(i)-1.)*sppt_vwt*Coupling%vfact_ca(k))+1.0 - - upert = (Stateout%gu0(i,k) - Statein%ugrs(i,k)) * ca1(i,k) - vpert = (Stateout%gv0(i,k) - Statein%vgrs(i,k)) * ca1(i,k) - tpert = (Stateout%gt0(i,k) - Statein%tgrs(i,k) - Tbd%dtdtr(i,k)) * ca1(i,k) - qpert = (Stateout%gq0(i,k,1) - Statein%qgrs(i,k,1)) * ca1(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(:) = ca1(:,15)*Sfcprop%tprcp(:) - Diag%totprcp(:) = Diag%totprcp(:) + (ca1(:,15) - 1 )*Diag%rain(:) - ! acccumulated total and convective preciptiation - Diag%cnvprcp(:) = Diag%cnvprcp(:) + (ca1(:,15) - 1 )*Diag%rainc(:) - ! bucket precipitation adjustment due to sppt - Diag%totprcpb(:) = Diag%totprcpb(:) + (ca1(:,15) - 1 )*Diag%rain(:) - Diag%cnvprcpb(:) = Diag%cnvprcpb(:) + (ca1(:,15) - 1 )*Diag%rainc(:) - - if (Model%cplflx) then - Coupling%rain_cpl(:) = Coupling%rain_cpl(:) + (ca1(:,15) - 1.0)*Tbd%drain_cpl(:) - Coupling%snow_cpl(:) = Coupling%snow_cpl(:) + (ca1(:,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)) - ! print*,'in do skeb',Coupling%skebu_wts(1,k),Statein%diss_est(1,k) - enddo - endif - - end subroutine GFS_stochastic_driver -!*## CCPP ## - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -! -! PRIVATE SUBROUTINES -! -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -!## CCPP ##* GFS_rad_time_vary.fv3.F90/GFS_rad_time_vary_run except for the call to -! radupdate, which is in GFS_rrtmg_setup.F90/GFS_rrtmg_setup_run -!----------------------------------------------------------------------- -! 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) - - !--- 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 > 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%imp_physics == 99) 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 -!*## CCPP ## - -!## CCPP ## GFS_phys_time_vary.fv3.F90/GFS_phys_time_vary_run -!----------------------------------------------------------------------- -! GFS_phys_time_vary -!----------------------------------------------------------------------- -! -! Routine containing all of the setup logic originally in phys/gloopb.f -! -!----------------------------------------------------------------------- - subroutine GFS_phys_time_vary (Model, Grid, Tbd, Statein) - 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(:) - type(GFS_statein_type), intent(in) :: Statein(:) - !--- 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. - ! Model%imfdeepcnv < 0 when Model%ras = .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)*1000.0) * 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 > 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 - - !--- ICCN interpolation - if (Model%ICCN == 1) then - do nb = 1, nblks - call ciinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & - Grid(nb)%jindx1_ci, Grid(nb)%jindx2_ci, & - Grid(nb)%ddy_ci,Grid(nb)%iindx1_ci, & - Grid(nb)%iindx2_ci,Grid(nb)%ddx_ci, & - Model%levs,Statein(nb)%prsl, & - Tbd(nb)%in_nm, Tbd(nb)%ccn_nm) - enddo - endif - - !--- aerosol interpolation - if (Model%iaerclm ) then - do nb = 1, nblks - call aerinterpol (Model%me, Model%master, blksz(nb), & - Model%idate, Model%fhour, & - Grid(nb)%jindx1_aer, Grid(nb)%jindx2_aer, & - Grid(nb)%ddy_aer,Grid(nb)%iindx1_aer, & - Grid(nb)%iindx2_aer,Grid(nb)%ddx_aer, & - Model%levs,Statein(nb)%prsl, & - Tbd(nb)%aer_nm) - enddo - endif - - end subroutine GFS_phys_time_vary -#endif -!*## CCPP ## - -!## CCPP ##* This is not in the CCPP -!------------------ -! 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(:,:) - real(kind=kind_phys), parameter :: rad2deg = 180.0_kind_phys/pi - - !--- 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 > 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) * rad2deg - Grid(nb)%xlon_d(ix) = xlon(i,j) * rad2deg - 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 -!*## CCPP ## - -end module GFS_driver - diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 deleted file mode 100644 index 899955f03..000000000 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ /dev/null @@ -1,6010 +0,0 @@ -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, PQ0, A2A, A3, A4, RHmin, & - tgice => con_tice - - 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 - GFS_radtend_type, GFS_diag_type, huge - use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_driver, & - cloud_diagnosis - use module_mp_thompson, only: mp_gt_driver - use module_mp_wsm6, only: wsm6 - use funcphys, only: ftdp - use surface_perturbation, only: cdfnor - - use module_sfc_diff, only: sfc_diff - use module_sfc_ocean, only: sfc_ocean - use module_sfc_drv, only: sfc_drv - use module_sfc_sice, only: sfc_sice - use module_sfc_cice, only: sfc_cice - use module_sfc_nst, only: sfc_nst - use module_sfc_diag, only: sfc_diag -! -!vay-2018 -! - use cires_ugwp_module, only: cires_ugwp_driver, knob_ugwp_version -! - - implicit none - - - !--- CONSTANT PARAMETERS - real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: epsln = 1.0e-10_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys - real(kind=kind_phys), parameter :: qsmall = 1.0e-20_kind_phys - real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys - real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys - real(kind=kind_phys), parameter :: epsq = 1.0e-20_kind_phys - real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus - real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, & - half = 0.5_kind_phys, onebg = one/con_g - real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys - real(kind=kind_phys), parameter :: tf=258.16_kind_phys, tcr=273.16_kind_phys, tcrf=one/(tcr-tf) - real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys - real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys - real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/con_pi - real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys -! real(kind=kind_phys), parameter :: huge = 0.0_kind_phys - -!> GFS Physics Implementation Layer -!> @brief Layer that invokes individual GFS physics routines -!> @{ -!at tune step===========================================================! -! description: ! -! ! -! usage: ! -! ! -! call GFS_physics_driver ! -! ! -! --- 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_sice, sfc_cice, sfc_diag, moninp1, ! -! moninp, moninq1, moninq, satmedmfvdif, ! -! gwdps, ozphys, get_phi, ! -! sascnv, sascnvn, samfdeepcnv, rascnv, cs_convr, gwdc, ! -! shalcvt3, shalcv, samfshalcnv, ! -! 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 ! -! 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 ! -! Oct 2017 S. Moorthi fix tracers to account for ice, snow etc! -! with this RAS and CSAW advect condensates! -! Mar 2017 Ruiyu S. Add Thompson's 2M aerosol MP ! -! May 2017 Ruiyu S. Add WSM6 MP ! -! Dec 2017 S. Moorthi Merge/update Ruiyu's update on vertical ! -! diffusion of tracers for all monins ! -! Jan 04 2018 S. Moorthi fix a bug in rhc for use in MG ! -! macrophysics and replace ntrac by nvdiff! -! in call to moninshoc ! -! Jun 2018 J. Han Add scal-aware TKE-based moist EDMF ! -! vertical turbulent mixng scheme ! -! Nov 2018 J. Han Add canopy heat storage parameterization! -! Feb 2019 Ruiyu S. Add an alternate method to use ! -! hydrometeors from GFDL MP in radiation ! -! Mar 2019 Rongqian &Helin Add Noah MP LSM ! -! Mar 2019 S. Moorthi update slflag for MG3 and update ! -! rain/snow over sea-ice. Update sfc_sice! -! sfc_cice calls ! -! -! Apr 22 2019 S. Moorthi Porting Unified Gravitiy Wave drag ! -! parameterrizaion package from V. Yudin, ! -! J. Alpert, T. Fuller-Rowll and R. Akmaev! -! May 2019 J. Han Add updated scal-aware TKE-based moist ! -! EDMF vertical turbulent mixng scheme ! -! july 2019 S. Moorthi Move original GWD to inside of UGW such ! -! that it can be called along with non- ! -! stationary GWD and make this part a ! -! function of precip or TKE. ! -! Jul 2019 Weiguo Wang Update PBL scheme for HAFS ! -! -! ==================== 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 for the RAS and Chikira-Sugiyama, and SAMF 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, satmedmf, 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 'h2ophys' if necessary ("adaptation of NRL H2O 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', and revap before the call to 'rascnv' -!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) -!! - 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 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 (imfshalcnv == 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' -!! - 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 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 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(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 -! -!## CCPP ## Note: Variables defined locally in this file for temporary calculations -! or transfer of data between schemes are defined in gfsphysics/GFS_layer/GFS_typedefs.F90 -! in the GFS_interstitial_type datatype. Type-bound procedures create, rad_reset, -! phys_reset, and mprint exist to allocate memory, to reset variables used in GFS_radiation_driver.F90, -! to reset variables used in GFS_physics_driver.F90, and to print the contents of the -! data type to the console - -! --- local variables - -!--- INTEGER VARIABLES - integer :: me, ipr, ix, im, levs, ntrac, nvdiff, kdt, & - ntoz, ntcw, ntiw, ncld,ntke,ntkev, ntlnc, ntinc, lsoil,& - ntrw, ntsw, ntrnc, ntsnc, ntot3d, ntgl, ntgnc, ntclamt,& - ims, ime, kms, kme, its, ite, kts, kte, imp_physics, & - ntwa, ntia, nmtvr - - integer :: i, kk, ic, itc, k, n, k1, iter, levshcm, tracers, & - tottracer, nsamftrac, num2, num3, nshocm, nshoc, ntk, & - nn, nncl, ntiwx, seconds - - integer, dimension(size(Grid%xlon,1)) :: & - kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & - levshc, islmsk, & -!--- coupling inputs for physics - islmsk_cice - -!--- LOGICAL VARIABLES - logical :: lprnt, revap, mg3_as_mg2, skip_macro, trans_aero - - logical, dimension(size(Grid%xlon,1)) :: & - flag_iter, flag_guess, invrsn, & -!--- coupling inputs for physics - flag_cice - - logical, dimension(Model%ntrac+1,2) :: otspt - - real(kind=kind_phys), dimension(Model%ntrac+2) :: trcmin - -!--- REAL VARIABLES - real(kind=kind_phys) :: & - dtf, dtp, frain, tem, tem1, tem2, & - xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & - txl, txi, txo, dt_warm, & -!--- experimental for shoc sub-stepping - dtshoc, & -!--- GFDL Cloud microphysics - crain, csnow, total_precip - - real(kind=kind_phys) :: rho - - - 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, fice, zice, tice, gflx,& - rain1, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & - stress, t850, ep1d, gamt, gamq, sigmaf, & - wind, work1, work2, work3, work4, runof, xmu, fm10, fh2, & - tx1, tx2, tx3, tx4, ctei_r, evbs, evcw, trans, sbsno,& - snowc, frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & - adjnirdfd, adjvisbmd, adjvisdfd, xcosz, tseal, & -! adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & - snohf, dlqfac, ctei_rml, cldf, domr, domzr, domip, & - doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & - ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, t2mmp, q2mp, & - psaur_l, praur_l, & -!--- for CS-convection - wcbmax - -! 1 - land, 2 - ice, 3 - ocean - real(kind=kind_phys), dimension(size(Grid%xlon,1),3) :: & - zorl3, cd3, cdq3, rb3, stress3, ffmm3, ffhh3, uustar3, & - fm103, fh23, qss3, cmm3, chh3, gflx3, evap3, hflx3, ep1d3, & - weasd3, snowd3, tprcp3, tsfc3, tsurf3, adjsfculw3, semis3, & - gabsbdlw3 - - logical, dimension(size(Grid%xlon,1)) :: & - wet, dry, icy - - real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & - area, land, rain0, snow0, ice0, graupel0 - - 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, dtdtc, & - ud_mf, dd_mf, dt_mf, prnum, dkt -! ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac, txa - real(kind=kind_phys), allocatable, dimension(:,:) :: sigmatot, & - gwdcu, gwdcv, rainp, sigmafrac, tke - - -!--- GFDL modification for FV3 - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& - del_gz - real(kind=kind_phys), allocatable, dimension(:,:,:) :: & - 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, p123, refl -! - 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,oz_coeff+5) :: & - dq3dt_loc - -! mg, sfc perts - real (kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - z01d, zt1d, bexp1d, xlai1d, alb1d, vegf1d - real(kind=kind_phys) :: cdfz -!--- 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 with ras, csaw, or samf) - !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, - !--- rain, and their numbers - real(kind=kind_phys), allocatable :: & - clw(:,:,:), qrn(:,:), qsnw(:,:), ncpl(:,:), ncpi(:,:), & - ncpr(:,:), ncps(:,:), cnvc(:,:), cnvw(:,:), & - qgl(:,:), ncgl(:,:) -!--- 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, & - qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE -! real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.02, & -! real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & -! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 -! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys),parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys -! - !--- for 2 M Thompson MP - real(kind=kind_phys), allocatable, dimension(:,:,:) :: & - vdftra, dvdftra - real(kind=kind_phys), allocatable, dimension(:,:) :: & - ice00, liq0 -! real(kind=kind_phys), allocatable, dimension(:) :: nwfa2d - real(kind=kind_phys), parameter :: liqm = 4./3.*con_pi*1.e-12, & - icem = 4./3.*con_pi*3.2768*1.e-14*890. -!=============================================================================== -! -! vay --- local variables Local PdXdt after each Physics chain -! TdXdt total Tendency for X due to ALL GFS_physics except -! radiance -! vay-2018 PROCESS-oriented diagnostics for 3D-fields in UGWP for COORDE -! -! New 2D-process oriented arrays for Daily mean (6-hr aver) diagnostics -! Diag%dXdT_pbl Diag%dXdT_ogw Diag%dXdT_congw Diag%dXdT_moist -! Diag%dXdT_total -! Additional 2D/3D diagnostic containers and arrays -! - logical :: ldiag_ugwp - -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & - real(kind=kind_phys) & - Pdtdt, Pdudt, Pdvdt -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & -! Tdtdt, Tdudt, Tdvdt -!----------------------------------------- -! ugwp: oro-stationary + non-stationary -!----------------------------------------- - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: hprime, & - sigma, elvmax, oc, theta, gamma - real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: oa4, clx - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: sgh30 !proxy for small-scale turb oro -! - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & - gw_dudt, gw_dvdt, gw_dtdt, gw_kdis -! - real(kind=kind_phys) :: ftausec, fdaily, fwindow - integer :: master - -! COODRE-averaged diagnostics -! - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: ax_mtb, & - ax_ogw, ax_tms, ax_ngw - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - tau_tms, tau_mtb, tau_ogw, tau_ngw - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - zm_mtb, zm_ogw, zm_ngw, zm_lwb -!------------------------------------------------------ -! parameters for canopy heat storage parametrization -!------------------------------------------------------ - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - hflxq, evapq, hffac, hefac - real (kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 - real (kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 - real (kind=kind_phys), parameter :: z0ice=1.1 -! -!=============================================================================== - - real, allocatable, dimension(:) :: refd, REFD263K - integer :: kdtminus1 - logical :: reset -! For computing saturation vapor pressure and rh at 2m - real :: pshltr,QCQ,rh02 - real(kind=kind_phys), allocatable, dimension(:,:) :: den - - real(kind=kind_phys) :: lndp_vgf - !! Initialize local variables (for debugging purposes only, - !! because the corresponding variables Interstitial(nt)%... - !! are reset to zero every time). - !snowmt = 0. - !gamq = 0. - !gamt = 0. - !gflx = 0. - !hflx = 0. - - !! Strictly speaking, this is not required. But when - !! hunting for bit-for-bit differences, doing the same as - !! in GFS_suite_stateout_reset makes life a lot easier. - !Stateout%gt0(:,:) = Statein%tgrs(:,:) - !Stateout%gu0(:,:) = Statein%ugrs(:,:) - !Stateout%gv0(:,:) = Statein%vgrs(:,:) - !Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) - -!## CCPP ## Note: Setting local variables from the Model DDT (without additional -! logic attached) is not necessary with the CCPP interstitial schemes with exceptions -! noted below. - -!===> ... begin here - ldiag_ugwp = Model%ldiag_ugwp -! -!===> - master = Model%master - - me = Model%me - ix = size(Grid%xlon,1) !## CCPP ## set in GFS_typedefs.F90/interstitial_create - im = size(Grid%xlon,1) !## CCPP ## set in GFS_typedefs.F90/interstitial_create - ipr = min(im,10) !## CCPP ## set in GFS_typedefs.F90/interstitial_create - levs = Model%levs - lsoil = Model%lsoil - ntrac = Model%ntrac - dtf = Model%dtf - dtp = Model%dtp - -!## CCPP ##* this block not yet in CCPP -!------- -! For COORDE-2019 averaging with fwindow, it was done before -! 3Diag fixes and averaging ingested using "fdaily"-factor -! - ftausec = 86400.0 - fdaily = dtp / ftausec - if (Model%fhzero /= 0) then - ftausec = Model%fhzero*3600 - fwindow = dtp/ftausec - fdaily = fwindow - else - print *, 'VAY Model%fhzero = 0., Bad Averaged-diagnostics ' - endif -!------- -!*## CCPP ## - - kdt = Model%kdt - lprnt = Model%lprnt -!## CCPP ## see GFS_typedefs.F90/interstitial_setup_tracers for logic for setting nvdiff - nvdiff = ntrac ! vertical diffusion of all tracers! - ntcw = Model%ntcw - ntoz = Model%ntoz - ntiw = Model%ntiw - ncld = Model%ncld - ntke = Model%ntke -! - ntlnc = Model%ntlnc - ntinc = Model%ntinc - ntrw = Model%ntrw - ntsw = Model%ntsw - ntrnc = Model%ntrnc - ntsnc = Model%ntsnc - ntgl = Model%ntgl - ntgnc = Model%ntgnc - ntclamt = Model%ntclamt - ntot3d = Model%ntot3d - ntwa = Model%ntwa - ntia = Model%ntia - nmtvr = Model%nmtvr - - imp_physics = Model%imp_physics - -!## CCPP ##* GFS_typedefs.F90/interstitial_setup_tracers - nncl = ncld - - ! perform aerosol convective transport and PBL diffusion - trans_aero = Model%cplchm .and. Model%trans_trac - - if (imp_physics == Model%imp_physics_thompson) then - if (Model%ltaerosol) then - nvdiff = 8 - else - nvdiff = 5 - endif - if (Model%satmedmf) nvdiff = nvdiff + 1 - nncl = 5 - elseif (imp_physics == Model%imp_physics_wsm6) then - nvdiff = ntrac -3 - if (Model%satmedmf) nvdiff = nvdiff + 1 - nncl = 5 - elseif (ntclamt > 0) then ! for GFDL MP don't diffuse cloud amount - nvdiff = ntrac - 1 - endif - - if (imp_physics == Model%imp_physics_gfdl) then - nncl = 5 - endif - - if (imp_physics == Model%imp_physics_mg) then - if (abs(Model%fprcp) == 1) then - nncl = 4 ! MG2 with rain and snow - mg3_as_mg2 = .false. - elseif (Model%fprcp >= 2) then - if (ntgl > 0 .and. (Model%mg_do_graupel .or. Model%mg_do_hail)) then - nncl = 5 ! MG3 with rain and snow and grapuel/hail - mg3_as_mg2 = .false. - else ! MG3 code run without graupel/hail i.e. as MG2 - nncl = 4 - mg3_as_mg2 = .true. - endif - endif - endif -! - if (Model%cplchm) then - ! Only Zhao/Carr/Sundqvist and GFDL microphysics schemes are supported - ! when coupling with chemistry. PBL diffusion of aerosols is only supported - ! Adding MG microphysics - Moorthi - if (imp_physics == Model%imp_physics_zhao_carr) then - nvdiff = 3 - elseif (imp_physics == Model%imp_physics_mg) then - if (ntgl > 0) then - nvdiff = 12 - else - nvdiff = 10 - endif - elseif (imp_physics == Model%imp_physics_gfdl) then - nvdiff = 7 - endif - if (trans_aero) nvdiff = nvdiff + Model%ntchm - if (ntke > 0) nvdiff = nvdiff + 1 ! adding tke to the list - endif -!*## CCPP ## -! -!## CCPP ##* GFS_typedefs.F90/interstitial_phys_reset - kdtminus1 = kdt - 1 - reset = mod(kdtminus1, nint(Model%avg_max_length/dtp)) == 0 -!*## CCPP ## - -! -!------------------------------------------------------------------------------------------- -! lprnt = .false. - -! do i=1,im -! lprnt = Model%me == 23 .and. i == 25 -! lprnt = Model%me == 127 .and. i == 11 -! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 -! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & -! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 -! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-216.20) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-81.23) < 0.101 -! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-28.800) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg+2.45) < 0.101 -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-293.91) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg+72.02) < 0.101 -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-113.48) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-21.07) < 0.101 -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-169.453) < 0.501 & -! .and. abs(grid%xlat(i)*rad2dg-72.96) < 0.501 -! if (kdt == 1) & -! write(2000+me,*)' i=',i,' xlon=',grid%xlon(i)*rad2dg, & -! ' xlat=',grid%xlat(i)*rad2dg,' me=',me -! if (lprnt) then -! ipr = i -! write(0,*)' ipr=',ipr,'xlon=',grid%xlon(i)*rad2dg,' xlat=',grid%xlat(i)*rad2dg,' me=',me -! exit -! endif -! enddo -! if (lprnt) then -! if (Model%cplflx) then -! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & -! ' fice=',Sfcprop%fice(ipr),' ulw=',Coupling%ulwsfcin_cpl(ipr), & -! ' tsfc=',Sfcprop%tsfc(ipr) -! else -! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & -! ' fice=',Sfcprop%fice(ipr), ' tsfc=',Sfcprop%tsfc(ipr), & -! 'tsfcl=',Sfcprop%tsfcl(ipr),' tsfco=',Sfcprop%tsfco(ipr) -! endif -! if (Model%nstf_name(1) > 0) then -! write(0,*)' begin sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt, & -! ' landfrac=',Sfcprop%landfrac(ipr) -! endif -! endif -!------------------------------------------------------------------------------------------- -! -! if (lprnt) then -! write(0,*)' in phydrv tgrs=',Statein%tgrs(ipr,:) -! write(0,*)' in phydrv ugrs=',Statein%ugrs(ipr,:) -! write(0,*)' in phydrv vgrs=',Statein%vgrs(ipr,:) -! write(0,*)' in phydrv qgrs=',Statein%qgrs(ipr,:,1)*1000.0 -! write(0,*)' in phydrv tke=',Statein%qgrs(ipr,:,ntke) -! write(0,*)' in phydrv phii=',Statein%phii(ipr,:) -! endif -! -! --- ... frain=factor for centered difference scheme correction of rain amount. - - frain = dtf / dtp - -!## CCPP ##* GFS_typedefs.F90/interstitial_create - skip_macro = .false. -!*## CCPP ## -!## CCPP ##* GFS_typedefs.F90/interstitial_setup_tracers - if (ntiw > 0) then - if (ntclamt > 0) then - nn = ntrac - 2 - else - nn = ntrac - 1 - endif - elseif (ntcw > 0) then - nn = ntrac - else - nn = ntrac + 1 - endif -!*## CCPP ## -!## CCPP ##* GFS_typedefs.F90/interstitial_create - allocate (clw(ix,levs,nn)) -!*## CCPP ## -!## CCPP ##* GFS_typedefs.F90/interstitial_create Note: cnvc and cnvw are always allocated and initialized regardless of test condition - 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) = zero - cnvw(i,k) = zero - enddo - enddo -!*## CCPP ## -!## CCPP ##* GFS_typedefs.F90/control_initialize Note: these are calculated regardless of test condition - 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 -!*## CCPP ## - -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run -! --- set initial quantities for stochastic physics deltas - if (Model%do_sppt .or. Model%ca_global)then - Tbd%dtdtr = zero - endif - -! mg, sfc-perts -! --- scale random patterns for surface perturbations with perturbation size -! --- turn vegetation fraction pattern into percentile pattern -!## CCPP ##* Note: initialzations to zero are not needed in GFS_surface_generic.F90/GFS_surface_generic_pre_run -! since this function occurs in GFS_typedefs.F90/interstitial_phys_reset - do i=1,im - z01d(i) = zero - zt1d(i) = zero - bexp1d(i) = zero - xlai1d(i) = zero -! alb1d(i) = zero - vegf1d(i) = zero - enddo - lndp_vgf=-999. - - if (Model%lndp_type==1) then - do k =1,Model%n_var_lndp - select case(Model%lndp_var_list(k)) - case ('rz0') - z01d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k) - case ('rzt') - zt1d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k) - case ('shc') - bexp1d(:) = Model%lndp_prt_list(k) * Coupling%sfc_wts(:,k) - case ('lai') - xlai1d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k) - case ('vgf') -! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff - do i=1,im - call cdfnor(Coupling%sfc_wts(i,k),cdfz) - vegf1d(i) = cdfz - enddo - lndp_vgf = Model%lndp_prt_list(k) - end select - enddo - endif -!*## CCPP ## -! -!## CCPP ##* GFS_typedefs.F90/interstitial_create - if (Model%do_shoc) then - allocate (qrn(im,levs), qsnw(im,levs), & - ncpl(im,levs), ncpi(im,levs)) - do k=1,levs - do i=1,im - ncpl(i,k) = zero - ncpi(i,k) = zero - qrn(i,k) = zero - qsnw(i,k) = zero - enddo - enddo - endif -!## CCPP ##* GFS_typedefs.F90/coupling_create ## - if (imp_physics == Model%imp_physics_thompson) then - if(Model%ltaerosol) then - allocate(ice00(im,levs)) - allocate(liq0(im,levs)) -! allocate(nwfa2d(im)) - else - allocate(ice00(im,levs)) - endif - endif -!*## CCPP ## -!## CCPP ##* allocated in GFS_typedefs.F90/interstitial_create; initialized in GFS_typedefs.F90/interstitial_phys_reset - if (imp_physics == Model%imp_physics_mg) 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), & -! 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 (ncpr(im,levs), ncps(im,levs), ncgl(im,levs)) - if (.not. allocated(qrn)) allocate (qrn(im,levs)) - if (.not. allocated(qsnw)) allocate (qsnw(im,levs)) - if (.not. allocated(qgl)) allocate (qgl(im,levs)) - do k=1,levs - do i=1,im - qrn(i,k) = zero - qsnw(i,k) = zero - qgl(i,k) = zero - ncpr(i,k) = zero - ncps(i,k) = zero - ncgl(i,k) = zero - enddo - enddo -!*## CCPP ## -!## CCPP ##* These variables are currently being allocated fully (im,levs) in GFS_typedefs.F90/interstitial_create - else - allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & - CNV_MFD(1,1), CNV_DQLDT(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)) -!## CCPP ##* The following variables are local to gfdl_cloud_microphys.F90/gfdl_cloud_microphys_run - if (imp_physics == Model%imp_physics_gfdl) then ! GFDL MP - allocate (delp(im,1,levs), dz(im,1,levs), uin(im,1,levs), & - vin(im,1,levs), pt(im,1,levs), qv1(im,1,levs), ql1(im,1,levs), & - qr1(im,1,levs), qg1(im,1,levs), qa1(im,1,levs), qn1(im,1,levs), & - qi1(im,1,levs), qs1(im,1,levs), pt_dt(im,1,levs), qa_dt(im,1,levs),& - udt(im,1,levs), vdt(im,1,levs), w(im,1,levs), qv_dt(im,1,levs),& - ql_dt(im,1,levs), qr_dt(im,1,levs), qi_dt(im,1,levs), qs_dt(im,1,levs),& - qg_dt(im,1,levs), p123(im,1,levs), refl(im,1,levs), den(im,levs)) - endif - endif -!*## CCPP ## - -!## CCPP ## Only get_prs_fv3.F90/get_prs_fv3_run is a scheme (GFS_HYDRO is assumed to be undefined) -#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 -! if (lprnt) write(0,*)'bef get_prs_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt - - call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & - Statein%tgrs, Statein%qgrs, del, del_gz) -#endif -! if (lprnt) write(0,*)'aft get_prs_fv3 phii=',Statein%phii(ipr,:) -! if (lprnt) write(0,*)'aft get_prs_fv3 del_gz=',del_gz(ipr,:) -!*## CCPP ## - -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run - do i = 1, IM - sigmaf(i) = max( Sfcprop%vfrac(i),0.01_kind_phys ) - islmsk(i) = nint(Sfcprop%slmsk(i)) - islmsk_cice(i) = islmsk(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)+half ) - vegtype(i) = int( Sfcprop%vtype(i)+half ) - slopetyp(i) = int( Sfcprop%slope(i)+half ) !! clu: slope -> slopetyp - if (soiltyp(i) < 1) soiltyp(i) = 14 - if (vegtype(i) < 1) vegtype(i) = 17 - if (slopetyp(i) < 1) slopetyp(i) = 1 - endif -!*## CCPP ## -! --- ... xw: transfer ice thickness & concentration from global to local variables -!## CCPP ## global to local variable transfer not necessary for these two - zice(i) = Sfcprop%hice(i) - fice(i) = Sfcprop%fice(i) -!*## CCPP ##* -!## CCPP ##* GFS_surface_composites.F90/GFS_surface_composites_pre_run - 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(zero, min(one, work1(i))) - work2(i) = one - work1(i) - Diag%psurf(i) = Statein%pgr(i) -!*## CCPP ## -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run - work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) -!*## CCPP ## -!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) -!GFDL tem2 = con_rerth * con_pi / latr -!GFDL garea(i) = tem1 * tem2 -!## CCPP ## global to local variable transfer not necessary for these variables - tem1 = Grid%dx(i) - tem2 = Grid%dx(i) - garea(i) = Grid%area(i) -!*## CCPP ## -!## CCPP ##* gwdc.f/gwdc_pre_run - dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = Model%cgwf(1) * work1(i) + Model%cgwf(2) * work2(i) -!*## CCPP ## -!## CCPP ##* cs_conv.F90/cs_conv_pre_run - wcbmax(i) = Model%cs_parm(1) * work1(i) + Model%cs_parm(2) * work2(i) -!*## CCPP ## -!## CCPP ##* GFS_typedefs.F90/interstitial_phys_reset - dry(i) = .false. - icy(i) = .false. - wet(i) = .false. - flag_cice(i) = .false. -!*## CCPP ## - enddo -! -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run - if (Model%cplflx) then - do i=1,im - islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - enddo - endif -!*## CCPP ## - -!## CCPP ##* GFS_surface_composites.F90/GFS_surface_composites_pre - if (Model%frac_grid) then - do i = 1, IM - frland(i) = Sfcprop%landfrac(i) - if (frland(i) > zero) dry(i) = .true. - if (frland(i) < one) then - if (flag_cice(i)) then - if (fice(i) >= Model%min_seaice) then - icy(i) = .true. - if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists - else - fice(i) = zero - flag_cice(i) = .false. - islmsk_cice(i) = 0 -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists - endif - else - if (fice(i) >= Model%min_lakeice) then - icy(i) = .true. - if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists - islmsk(i) = 2 - else - fice(i) = zero -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists - endif - endif - if (wet(i) .and. .not. Model%cplflx) then - if (Sfcprop%oceanfrac(i) > zero) then - Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) - elseif (icy(i)) then - Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) - endif - endif - else - fice(i) = zero - endif - enddo - else - do i = 1, IM - if (islmsk(i) == 1) then -! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) - dry(i) = .true. - frland(i) = one - fice(i) = zero - else - frland(i) = zero - if (flag_cice(i)) then - if (fice(i) > Model%min_seaice) then - icy(i) = .true. - else - fice(i) = zero - flag_cice(i) = .false. - islmsk_cice(i) = 0 - islmsk(i) = 0 - endif - else - if (fice(i) > Model%min_lakeice) then - icy(i) = .true. - else - fice(i) = zero - islmsk(i) = 0 - endif - endif - if (fice(i) < one) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. Model%cplflx .and. icy(i)) & - Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) - endif - endif - enddo - endif -! - do k=1,3 - do i=1,im - cd3(i,k) = huge - cdq3(i,k) = huge - rb3(i,k) = huge - stress3(i,k) = huge - ffmm3(i,k) = huge - ffhh3(i,k) = huge - fm103(i,k) = huge - fh23(i,k) = huge - qss3(i,k) = huge - cmm3(i,k) = huge - chh3(i,k) = huge - gflx3(i,k) = zero -! gflx3(i,k) = huge - evap3(i,k) = huge - hflx3(i,k) = huge - ep1d3(i,k) = huge - uustar3(i,k) = huge - weasd3(i,k) = huge - snowd3(i,k) = huge - tprcp3(i,k) = Sfcprop%tprcp(i) - tsfc3(i,k) = huge - tsurf3(i,k) = huge - zorl3(i,k) = huge -! oro3(i,k) = Sfcprop%oro(i) -! oro_uf3(i,k) = Sfcprop%oro_uf(i) - adjsfculw3(i,k) = zero - gabsbdlw3(i,k) = zero - enddo - enddo - zorl3(:,2) = z0ice - -! if (.not. Model%cplflx .or. .not. Model%frac_grid) then -! if (Model%cplwav2atm) then -! do i=1,im -! Sfcprop%zorll(i) = Sfcprop%zorl(i) -! enddo -! else -! do i=1,im -! Sfcprop%zorll(i) = Sfcprop%zorl(i) -! Sfcprop%zorlo(i) = Sfcprop%zorl(i) -! enddo -! endif -! endif -! if (lprnt) write(0,*)' dry=',dry(ipr),' wet=',wet(ipr),' icy=',icy(ipr) ,& -! ' tsfco=',Sfcprop%tsfco(ipr) - do i=1,im - if(wet(i)) then ! Water - zorl3(i,3) = Sfcprop%zorlo(i) - tsfc3(i,3) = Sfcprop%tsfco(i) - tsurf3(i,3) = Sfcprop%tsfco(i) -! weasd3(i,3) = Sfcprop%weasd(i) -! snowd3(i,3) = Sfcprop%snowd(i) - snowd3(i,3) = zero - weasd3(i,3) = zero - semis3(i,3) = 0.984_kind_phys - endif -! - if (dry(i)) then ! Land - uustar3(i,1) = Sfcprop%uustar(i) - weasd3(i,1) = Sfcprop%weasd(i) - zorl3(i,1) = Sfcprop%zorll(i) - tsfc3(i,1) = Sfcprop%tsfcl(i) - tsurf3(i,1) = Sfcprop%tsfcl(i) - snowd3(i,1) = Sfcprop%snowd(i) - semis3(i,1) = Radtend%semis(i) - endif -! - if (icy(i)) then ! Ice - uustar3(i,2) = Sfcprop%uustar(i) - weasd3(i,2) = Sfcprop%weasd(i) - zorl3(i,2) = Sfcprop%zorli(i) - tsfc3(i,2) = Sfcprop%tisfc(i) - tsurf3(i,2) = Sfcprop%tisfc(i) - snowd3(i,2) = Sfcprop%snowd(i) - ep1d3(i,2) = zero - gflx3(i,2) = zero - semis3(i,2) = 0.95_kind_phys - endif - enddo -!*## CCPP ## - -!## CCPP ## global to local variable transfer not necessary for these variables -! --- ... transfer soil moisture and temperature from global to local variables - do k=1,lsoil - do i=1,im - smsoil(i,k) = Sfcprop%smc(i,k) - stsoil(i,k) = Sfcprop%stc(i,k) - slsoil(i,k) = Sfcprop%slc(i,k) !! clu: slc -> slsoil - enddo - enddo -!*## CCPP ## - - do k=1,levs - do i=1,im - dudt(i,k) = zero - dvdt(i,k) = zero - dtdt(i,k) = zero - dtdtc(i,k) = zero - -!## CCPP ##* GFS_typedefs.F90/interstitial_phys_reset -!vay-2018 -! Pure tendency arrays w/o accumulation of Phys-tendencies from each -! chain of GFS-physics (later add container for species) -! -! Pdudt(i,k) = zero -! Pdvdt(i,k) = zero -! Pdtdt(i,k) = zero - -! -!ugwp-marked can be later accumulated as Pdudt Pdvdt Pdtdt -! - gw_dudt(i,k) = zero - gw_dvdt(i,k) = zero - gw_dtdt(i,k) = zero - gw_kdis(i,k) = zero -!*## CCPP ## - enddo - enddo -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_1_run - do n=1,ntrac - do k=1,levs - do i=1,im - dqdt(i,k,n) = zero - enddo - enddo - enddo -!*## CCPP ## - -!## CCPP ##* This block is not yet in CCPP. -!----------------------------------------------- -!vay-2018-19 ORO/UGWP process-oriented diagnostics -! - if (ldiag_ugwp) then - do i=1,im - tau_tms(i) = zero ; tau_mtb(i) = zero - tau_ogw(i) = zero ; tau_ngw(i) = zero - zm_mtb(i) = zero ; zm_lwb(i) = zero - zm_ogw(i) = zero ; zm_ngw(i) = zero - enddo - do k=1,levs - do i=1,im - ax_mtb(i,k) = zero ; ax_ogw(i,k) = zero - ax_tms(i,k) = zero ; ax_ngw(i,k) = zero - enddo - enddo - endif - - if (mod((kdt-1)*dtp, ftausec) == zero) then - do i=1,im - Diag%tau_tofd(i) = zero - Diag%tau_mtb(i) = zero - Diag%tau_ogw(i) = zero - Diag%tau_ngw(i) = zero - Diag%zmtb(i) = zero - Diag%zlwb(i) = zero - Diag%zogw(i) = zero -! Diag%dugwd(i) = zero -! Diag%dvgwd(i) = zero - enddo - endif -!=========================== -! can be taken out by "call Diag%zero" => call Diag(nb)%phys_zero (Model) -! in GFS_driver.F90 -! It can be also done by hands w/o -! relying on FV3GFS_io_mod -!================================= - if (ldiag_ugwp) then -! do k=1,levs -! do i=1,im -! Diag%du3dt_pbl(i,k) = zero -! Diag%dv3dt_pbl(i,k) = zero -! Diag%dt3dt_pbl(i,k) = zero -! -! Diag%du3dt_ogw(i,k) = zero -! Diag%dv3dt_ogw(i,k) = zero -! Diag%dt3dt_ogw(i,k) = zero - -! Diag%du3dt_mtb(i,k) = zero -! Diag%dv3dt_mtb(i,k) = zero -! Diag%dt3dt_mtb(i,k) = zero - -! Diag%du3dt_tms(i,k) = zero -! Diag%dv3dt_tms(i,k) = zero -! Diag%dt3dt_tms(i,k) = zero - -! Diag%du3dt_ngw(i,k) = zero -! Diag%dv3dt_ngw(i,k) = zero -! Diag%dt3dt_ngw(i,k) = zero -! -! employed for "storage" of State%out to compute DyCore_Tendencies -!! Diag%du3dt_cgw(i,k) = zero -!! Diag%dv3dt_cgw(i,k) = zero -!! Diag%dt3dt_cgw(i,k) = zero - -! Diag%du3dt_moist(i,k) = zero -! Diag%dv3dt_moist(i,k) = zero -! Diag%dt3dt_moist(i,k) = zero - -! Diag%dudt_tot(i,k) = zero -! Diag%dvdt_tot(i,k) = zero -! Diag%dtdt_tot(i,k) = zero - -! Diag%uav_ugwp(i,k) = zero -! Diag%tav_ugwp(i,k) = zero - -! -! Tdudt(i,k) = zero -! Tdvdt(i,k) = zero -! Tdtdt(i,k) = zero -! enddo -! enddo -! - if (kdt > 1) then - do k=1,levs - do i=1,im -! -!---- dycore_tend = Statein - Stateout , assuming that Statein-after Dycore and out-after Physics -! Statein%ugrs-- "Stateout%gu0 = Diag%du3dt_cgw" -! - Diag%dudt_tot(i,k) = (Statein%ugrs(i,k) - Diag%du3dt_cgw(i,k))*fdaily & - + Diag%dudt_tot(i,k) ! - Diag%dtdt_tot(i,k) = (Statein%tgrs(i,k) - Diag%dt3dt_cgw(i,k))*fdaily & - + Diag%dtdt_tot(i,k) - enddo - enddo - if (kdt == -2) then - print *, maxval(Statein%ugrs), maxval(Diag%du3dt_cgw), ' max Uin-out' - print *, minval(Statein%ugrs), minval(Diag%du3dt_cgw), ' min Uin-out' - print *, maxval(Statein%tgrs), maxval(Diag%dt3dt_cgw), ' max Tin-out' - print *, minval(Statein%tgrs), minval(Diag%dt3dt_cgw), ' min Tin-out' - endif - endif - endif -!===========================Above Phys-tend Diag for COORDE ====================== -!*## CCPP ## - -! --- ... 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 -!## CCPP ##* This is not in the CCPP yet. - 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 -!*## CCPP ## -!** CCPP ## dcyc2.f/dcyc2t3_run Note: Check for Model%pre_rad was omitted, so this option is broken in CCPP - call dcyc2t3 & -! --- inputs: - ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & - Grid%coslat, Grid%xlon, Radtend%coszen, tsfc3, & -! Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & - Statein%tgrs(1,1), Radtend%tsflw, semis3, & - 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, dtf, & - Model%fhswr, dry, icy, wet, & -! lprnt, ipr, & -! --- input/output: - dtdt, dtdtc, & -! --- outputs: - adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw3, xmu, xcosz, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & - ) -!*## CCPP ## -! -! save temp change due to radiation - need for sttp stochastic physics -!--------------------------------------------------------------------- - endif -! -!## CCPP ##* This is not in the CCPP yet. - if (Model%lsidea) then !idea jw - dtdt(:,:) = zero - endif -!*## CCPP ## - -! --- 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 - -!## CCPP ##* GFS_surface_composites.F90/GFS_surface_composites_pre_run - do i=1,im - if (dry(i)) gabsbdlw3(i,1) = semis3(i,1) * adjsfcdlw(i) - if (icy(i)) gabsbdlw3(i,2) = semis3(i,2) * adjsfcdlw(i) - if (wet(i)) gabsbdlw3(i,3) = semis3(i,3) * adjsfcdlw(i) - enddo -!*## CCPP ## - -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_2_run - 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_kind_phys) then - Diag%suntim(i) = Diag%suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - - if (Model%frac_grid) then - do i=1,im - tem = (one - frland(i)) * fice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw3(i,1) * frland(i) & - + Coupling%ulwsfcin_cpl(i) * tem & - + adjsfculw3(i,3) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw3(i,1) * frland(i) & - + adjsfculw3(i,2) * tem & - + adjsfculw3(i,3) * (one - frland(i) - tem) - endif - enddo - else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw3(i,1) - elseif (icy(i)) then ! ice (and water) - tem = one - fice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw3(i,3) /= huge) then - adjsfculw(i) = Coupling%ulwsfcin_cpl(i)*fice(i) + adjsfculw3(i,3)*tem - else - adjsfculw(i) = Coupling%ulwsfcin_cpl(i) - endif - else - if (wet(i) .and. adjsfculw3(i,3) /= huge) then - adjsfculw(i) = adjsfculw3(i,2)*fice(i) + adjsfculw3(i,3)*tem - else - adjsfculw(i) = adjsfculw3(i,2) - endif - endif - else ! all water - adjsfculw(i) = adjsfculw3(i,3) - endif - enddo - endif -! if (lprnt) write(0,*)' kdt=',kdt,' tsfc=',Sfcprop%tsfc(ipr),' adjsfculw=',adjsfculw(ipr),& -! ' adjsfculw3=',adjsfculw3(ipr,:),' icefr=',fice(ipr),' tsfc3=',tsfc3(ipr,:) -! - do i=1,im - Diag%dlwsfc(i) = Diag%dlwsfc(i) + adjsfcdlw(i)*dtf - Diag%ulwsfc(i) = Diag%ulwsfc(i) + adjsfculw(i)*dtf - Diag%psmean(i) = Diag%psmean(i) + Statein%pgr(i)*dtf ! mean surface pressure - enddo - - if (Model%ldiag3d) then - if (Model%lsidea) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,1) = Diag%dt3dt(i,k,1) + Radtend%lwhd(i,k,1)*dtf - Diag%dt3dt(i,k,2) = Diag%dt3dt(i,k,2) + Radtend%lwhd(i,k,2)*dtf - Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + Radtend%lwhd(i,k,3)*dtf - Diag%dt3dt(i,k,4) = Diag%dt3dt(i,k,4) + Radtend%lwhd(i,k,4)*dtf - Diag%dt3dt(i,k,5) = Diag%dt3dt(i,k,5) + Radtend%lwhd(i,k,5)*dtf - Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + Radtend%lwhd(i,k,6)*dtf - enddo - enddo - else - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,1) = Diag%dt3dt(i,k,1) + Radtend%htrlw(i,k)*dtf - Diag%dt3dt(i,k,2) = Diag%dt3dt(i,k,2) + Radtend%htrsw(i,k)*dtf*xmu(i) - enddo - enddo - endif - endif - endif ! end if_lssav_block - - do i=1,im - kcnv(i) = 0 !## CCPP ## GFS_typedefs.F90/interstitial_phys_reset - kinver(i) = levs !## CCPP ## GFS_typedefs.F90/interstitial_phys_reset - invrsn(i) = .false. - tx1(i) = zero - tx2(i) = 10.0_kind_phys - ctei_r(i) = 10.0_kind_phys - enddo - -! Only used for old shallow convection with mstrat=.true. - - if ((((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & - .and. Model%mstrat) .or. Model%do_shoc) 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_kind_phys*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_kind_phys) .and. (tx1(i) < zero)) .or. & - ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) 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) = (one/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & - + Statein%qgrs(i,k+1,ntcw)-Statein%qgrs(i,k,ntcw)) - else - ctei_r(i) = 10.0_kind_phys - 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 -!*## CCPP ## - -! --- ... lu: initialize flag_guess, flag_iter, tsurf - -!## CCPP ##* These initializations are done in GFS_typedefs.F90/interstitial_phys_reset except for as noted below - do i=1,im -! tsurf(i) = Sfcprop%tsfc(i) - flag_guess(i) = .false. - flag_iter(i) = .true. - drain(i) = zero - ep1d(i) = zero - gflx(i) = zero - runof(i) = zero - hflx(i) = zero - evap(i) = zero - evbs(i) = zero - evcw(i) = zero - trans(i) = zero - sbsno(i) = zero - snowc(i) = zero - snohf(i) = zero - !## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run - Diag%zlvl(i) = Statein%phil(i,1) * onebg - Diag%smcwlt2(i) = zero - Diag%smcref2(i) = zero - wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0_kind_phys)), one) - !*## CCPP ## - enddo -!*## CCPP ## - -! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) -!## CCPP ##* This loop is implemented using the subcycle/iteration capability in the CCPP SDF - do iter=1,2 -!*## CCPP ## - -! --- ... surface exchange coefficients -! -! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),'iter=', & -! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& -! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) - -!## CCPP ##* sfc_diff.f/sfc_diff_run - call sfc_diff & -! --- inputs: - (im, Statein%pgr, & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), Diag%zlvl, wind, & - Statein%prsl(:,1), work3, & - sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & - z01d, zt1d, & ! mg, sfc-perts - flag_iter, Model%redrag, & - Diag%u10m, Diag%v10m, Model%sfc_z0_type, & - wet, dry, icy, tsfc3, tsurf3, snowd3, & -! --- input/output: - zorl3, Sfcprop%zorlw, uustar3, & -! --- outputs: - cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23) -! cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23, wind, lprnt, ipr) -! -! if (lprnt) write(0,*)' aft sfc_diff cd3=',cd3(ipr,:),' cdq3=',cdq3(ipr,:),'iter=', iter, & -! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) -! --- ... lu: update flag_guess -!*## CCPP ## -!## CCPP ##* GFS_surface_loop_control/GFS_surface_loop_control_part1_run - do i=1,im - if (iter == 1 .and. wind(i) < 2.0_kind_phys) then - flag_guess(i) = .true. - endif - enddo -!*## CCPP ## -!## CCPP ##* sfc_nst.f/sfc_nst_pre_run Note: the conditional is not included in the CCPP scheme, so calling -! this code is controlled by its presence in the active CCPP SDF - if (Model%nstf_name(1) > 0) then - do i=1,im - if (wet(i)) then -! tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - tem = zero - tseal(i) = tsfc3(i,3) + tem - tsurf3(i,3) = tsurf3(i,3) + tem - endif - enddo - if (Model%cplflx) then ! apply only at ocean points - call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & - Sfcprop%z_c, wet, zero, omz1, im, 1, dtzm) - do i=1,im - if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then - Sfcprop%tref(i) = Sfcprop%tsfco(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile - if (abs(Sfcprop%xz(i)) > zero) then - tem2 = one / Sfcprop%xz(i) - else - tem2 = zero - endif - tseal(i) = Sfcprop%tref(i) + (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 & - - Sfcprop%dt_cool(i) - tsurf3(i,3) = tseal(i) - endif - enddo - endif - -! if (lprnt) write(0,*)' bef nst tseal=',tseal(ipr) & -! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3), & -! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& -! ' tref=',Sfcprop%tref(ipr),' tgrs=',Statein%tgrs(ipr,1),' qgrs=',Statein%qgrs(ipr,1,1), & -! ' prsl=',Statein%prsl(ipr,1),' cd3=',cd3(ipr,3),' cdq3=',cdq3(ipr,3),' work3=', & -! work3(ipr),' semis3=',semis3(ipr,3),' gabsbdlw3=',gabsbdlw3(ipr,3),' adjsfcnsw=', & -! adjsfcnsw(ipr),' wind=',wind(ipr),' tseal=',tseal(ipr),' xcosz=',xcosz(ipr) -!*## CCPP ## -!## CCPP ##* sfc_nst.f/sfc_nst_run - call sfc_nst & -! --- inputs: - (im, Statein%pgr, Statein%ugrs(:,1), Statein%vgrs(:,1), & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), & - Sfcprop%tref, cd3(:,3), cdq3(:,3), Statein%prsl(:,1), & - work3, wet, Grid%xlon, Grid%sinlat, stress3(:,3), & - semis3(:,3), gabsbdlw3(:,3), adjsfcnsw, tprcp3(:,3), & - dtf, kdt, Model%solhr, xcosz, & - wind, flag_iter, & - flag_guess, Model%nstf_name, lprnt, ipr, & -! --- input/output - tseal, tsurf3(:,3), 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: - qss3(:,3), gflx3(:,3), cmm3(:,3), chh3(:,3), evap3(:,3), & - hflx3(:,3), ep1d3(:,3)) -!*## CCPP ## -!## CCPP ##* sfc_nst.f/sfc_nst_post_run - -! do i=1,im -!! if (wet(i) .and. .not.icy(i)) then -!! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then -! if (wet(i)) then -! tsurf3(i,3) = tsurf3(i,3) & -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse -! endif -! enddo - -! --- ... run nsst model ... --- - - if (Model%nstf_name(1) > 1) then - zsea1 = 0.001_kind_phys*real(Model%nstf_name(4)) - zsea2 = 0.001_kind_phys*real(Model%nstf_name(5)) - call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & - Sfcprop%z_c, wet, zsea1, zsea2, im, 1, dtzm) - do i=1,im -! if (wet(i) .and. .not.icy(i)) then -! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then - if (wet(i)) then - tsfc3(i,3) = max(tgice,Sfcprop%tref(i) + dtzm(i)) -! tsfc3(i,3) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & -! (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) write(0,*)' aft nst tref=',Sfcprop%tref(ipr) & -! ,' tsfc3=',tsfc3(ipr,3),' dtzm=',dtzm(ipr),' hflx33=',hflx3(ipr,3) -!*## CCPP ## -! if (lprnt) print *,' tseaz2=',Sfcprop%tsfc(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - -!## CCPP ## Note: This conditional is replaced by whether the sfc_ocean scheme is in the CCPP SDF - else - -! --- ... surface energy balance over ocean -!## CCPP ##* sfc_ocean.F/sfc_ocean_run - call sfc_ocean & -! --- inputs: - (im, Statein%pgr, & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), tsfc3(:,3), & - cd3(:,3), cdq3(:,3), Statein%prsl(:,1), work3, wet, & - wind, flag_iter, & -! --- outputs: - qss3(:,3), cmm3(:,3), chh3(:,3), gflx3(:,3), evap3(:,3), & - hflx3(:,3), ep1d3(:,3)) -!*## CCPP ## - - endif ! if nstf_name(1) > 0 - -! if (lprnt) write(0,*)' sfalb=',Radtend%sfalb(ipr),' ipr=',ipr & -! , ' weasd=',Sfcprop%weasd(ipr) & -! , ' tprcp=',Sfcprop%tprcp(ipr),' kdt=',kdt,' iter=',iter & -! ,' tseabefland=',Sfcprop%tsfc(ipr) - -! --- ... surface energy balance over land -! -!## CCPP ##* Note: the conditional is not included in the CCPP, so calling -! the LSM scheme is controlled by its presence in the active CCPP SDF - if (Model%lsm == Model%lsm_noah) then ! noah lsm call -!*## CCPP ## - -! if (lprnt) write(0,*)' tseal=',tseal(ipr),' tsurf=',tsurf(ipr),iter & -! ,' stsoil0=',stsoil(ipr,:) -! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) - -!## CCPP ##* sfc_drv.f/lsm_noah_run - - call sfc_drv & -! --- inputs: - (im, lsoil, Statein%pgr, & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), soiltyp, vegtype, & - sigmaf, semis3(:,1), gabsbdlw3(:,1), adjsfcdsw, adjsfcnsw, dtf,& -! sigmaf, Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & - Sfcprop%tg3, cd3(:,1), cdq3(:,1), 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,lndp_vgf, & - -! --- input/output: - weasd3(:,1), snowd3(:,1), tsfc3(:,1), tprcp3(:,1), & - Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & - trans, tsurf3(:,1), zorl3(:,1), & -! --- outputs: - Sfcprop%sncovr, qss3(:,1), gflx3(:,1), drain, evap3(:,1), & - hflx3(:,1), ep1d3(:,1), runof, & - cmm3(:,1), chh3(:,1), evbs, evcw, sbsno, snowc, Diag%soilm, & - snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) -!*## CCPP ## - -! if (lprnt) write(0,*)' tseae=',tseal(ipr),' tsurf=',tsurf(ipr),iter -! ,' phy_f2d=',phy_f2d(ipr,num_p2d) - -! if (lprnt) write(0,*)' hflx3=',hflx3(ipr,:),' evap3=',evap3(ipr,:) - -!## CCPP ##* sfc_noahmp_drv.f/noahmpdrv_run -! Noah MP call -! - elseif (Model%lsm == Model%lsm_noahmp) then - call noahmpdrv & -! --- inputs: - (im, lsoil,kdt, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & - semis3(:,1), gabsbdlw3(:,1), adjsfcdsw, adjsfcnsw, dtf, & -! Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & - Sfcprop%tg3, cd3(:,1), cdq3(:,1), 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: - weasd3(:,1), snowd3(:,1), tsfc3(:,1), tprcp3(:,1), & - Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & - trans, tsurf3(:,1), zorl3(:,1), & -! - 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, qss3(:,1), gflx3(:,1), drain, evap3(:,1), & - hflx3(:,1), ep1d3(:,1), runof, & - cmm3(:,1), chh3(:,1), evbs, evcw, sbsno, snowc, Diag%soilm, & - snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1, t2mmp, q2mp) - -! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter & -! &,' phy_f2d=',phy_f2d(ipr,num_p2d) -!*## CCPP ## - - elseif (Model%lsm == Model%lsm_ruc) then - write (0,*) 'RUC LSM is available only in CCPP' - stop - - endif !lsm - - !! Strictly speaking, this is not required. But when - !! hunting for bit-for-bit differences, updating the - !! subsurface variables in the Sfcprop DDT makes - !! life a lot easier - !if (Model%frac_grid) then - ! do k=1,lsoil - ! do i=1,im - ! if (dry(i)) then - ! Sfcprop%smc(i,k) = smsoil(i,k) - ! Sfcprop%stc(i,k) = stsoil(i,k) - ! Sfcprop%slc(i,k) = slsoil(i,k) - ! endif - ! enddo - ! enddo - !else - ! do k=1,lsoil - ! do i=1,im - ! Sfcprop%smc(i,k) = smsoil(i,k) - ! Sfcprop%stc(i,k) = stsoil(i,k) - ! Sfcprop%slc(i,k) = slsoil(i,k) - ! enddo - ! enddo - !endif - -! if (lprnt) write(0,*)' tseabeficemodel =',Sfcprop%tsfc(ipr),' me=',me & -! &, ' kdt=',kdt,' tsfc32=',tsfc3(ipr,2),' fice=',fice(ipr) & -! &,' stsoil=',stsoil(ipr,:),' tsfc33=',tsfc3(ipr,3),' islmsk=',islmsk(ipr) - -! --- ... surface energy balance over seaice -!## CCPP ##* sfc_sice.f/sfc_sice_run (local adjustment to avoid resetting islmsk after call to sfc_sice_run) - if (Model%cplflx) then - do i=1,im - if (flag_cice(i)) then - islmsk(i) = islmsk_cice(i) - endif - enddo -!*## CCPP ## - -!## CCPP ##* sfc_cice.f/sfc_cice_run -! call sfc_cice for sea ice points in the coupled model (i.e. islmsk=4) -! - call sfc_cice & -! --- inputs: - (im, Statein%tgrs(:,1), & - Statein%qgrs(:,1,1), cd3(:,2), cdq3(:,2), & - Statein%prsl(:,1), wind, & - flag_cice, flag_iter, & - Coupling%dqsfcin_cpl, Coupling%dtsfcin_cpl, & - Coupling%dusfcin_cpl, Coupling%dvsfcin_cpl, & - Coupling%hsnoin_cpl, & -! --- outputs: - qss3(:,2), cmm3(:,2), chh3(:,2), evap3(:,2), hflx3(:,2), & - stress3(:,2), weasd3(:,2), snowd3(:,2), ep1d3(:,2)) - endif -!*## CCPP ## - -! -! call sfc_sice for lake ice and for the uncoupled case, sea ice (i.e. islmsk=2) -! - if (Model%frac_grid) then - do i=1,im - if (icy(i) .and. islmsk(i) < 2) then - if (Sfcprop%oceanfrac(i) > zero) then - tem = Model%min_seaice - else - tem = Model%min_lakeice - endif - if (fice(i) > tem) then - islmsk(i) = 2 - tsfc3(i,2) = Sfcprop%tisfc(i) - endif - endif - enddo - endif -!## CCPP ##* sfc_sice.f/sfc_sice_run - call sfc_sice & -! --- inputs: - (im, lsoil, Statein%pgr, & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, semis3(:,2), & -! Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, Radtend%semis, & - gabsbdlw3(:,2), adjsfcnsw, adjsfcdsw, Sfcprop%srflag, & - cd3(:,2), cdq3(:,2), & - Statein%prsl(:,1), work3, islmsk, wind, & - flag_iter, lprnt, ipr, Model%min_lakeice, & -! --- input/output: - zice, fice, tice, weasd3(:,2), tsfc3(:,2), tprcp3(:,2), & - stsoil, ep1d3(:,2), & -! --- outputs: - snowd3(:,2), qss3(:,2), snowmt, gflx3(:,2), cmm3(:,2), chh3(:,2), & - evap3(:,2), hflx3(:,2)) -!*## CCPP ## -!## CCPP ##* This section is not needed for CCPP. - if (Model%frac_grid) then - do i = 1, im - if (islmsk(i) == 2 .and. fice(i) < one) then - wet(i) = .true. - tsfc3(i,3) = max(Sfcprop%tisfc(i), tgice) - endif - enddo - endif - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - islmsk(i) = nint(Sfcprop%slmsk(i)) - endif - enddo - endif -!*## CCPP ## - -! if (lprnt) write(0,*)' tseaafticemodel =',tsfc3(ipr,:),' me=',me & -! &, ' kdt=',kdt,' iter=',iter,' fice=',fice(ipr),' wet=',wet(ipr),' icy=',icy(ipr)& -! &,' dry=',dry(ipr) - -! --- ... lu: update flag_iter and flag_guess -!## CCPP ##* GFS_surface_loop_control.F90/GFS_surface_loop_control_part_2 - do i=1,im - flag_iter(i) = .false. - flag_guess(i) = .false. - - if (iter == 1 .and. wind(i) < 2.0_kind_phys) then -! if (dry(i) .or. (wet(i) .and. .not.icy(i) & - if (dry(i) .or. (wet(i) .and. Model%nstf_name(1) > 0)) then - flag_iter(i) = .true. - endif - endif - - enddo -!*## CCPP ## - - enddo ! end iter_loop - - -! --- generate ocean/land/ice composites - -!## CCPP ##* GFS_surface_compoistes.F90/GFS_surface_composites_post_run - if (Model%frac_grid) then - do i=1, im -! -! Three-way composites (fields from sfc_diff) - txl = frland(i) - txi = fice(i)*(one - frland(i)) ! txi = ice fraction wrt whole cell - txo = max(zero, one - txl - txi) - -! if (i == ipr .and. lprnt) write(0,*)' txl=',txl,' fice=',fice(i),' txi=',txi,& -! ' txo=',txo,' dry=',dry(i),' wet=',wet(i),' icy=',icy(i),' oceanfrac=',& -! Sfcprop%oceanfrac(i),' frland=',frland(i) - - Sfcprop%zorl(i) = txl*zorl3(i,1) + txi*zorl3(i,2) + txo*zorl3(i,3) - cd(i) = txl*cd3(i,1) + txi*cd3(i,2) + txo*cd3(i,3) - cdq(i) = txl*cdq3(i,1) + txi*cdq3(i,2) + txo*cdq3(i,3) - rb(i) = txl*rb3(i,1) + txi*rb3(i,2) + txo*rb3(i,3) - stress(i) = txl*stress3(i,1) + txi*stress3(i,2) + txo*stress3(i,3) - Sfcprop%ffmm(i) = txl*ffmm3(i,1) + txi*ffmm3(i,2) + txo*ffmm3(i,3) - Sfcprop%ffhh(i) = txl*ffhh3(i,1) + txi*ffhh3(i,2) + txo*ffhh3(i,3) - Sfcprop%uustar(i) = txl*uustar3(i,1) + txi*uustar3(i,2) + txo*uustar3(i,3) - fm10(i) = txl*fm103(i,1) + txi*fm103(i,2) + txo*fm103(i,3) - fh2(i) = txl*fh23(i,1) + txi*fh23(i,2) + txo*fh23(i,3) -! tsurf(i) = txl*tsurf3(i,1) + txi*tice(i) + txo*tsurf3(i,3) -! tsurf(i) = txl*tsurf3(i,1) + txi*tsurf3(i,2) + txo*tsurf3(i,3) ! not used again! Moorthi - Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) - Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) -! gflx(i) = txl*gflx3(i,1) + txi*gflx3(i,2) + txo*gflx3(i,3) - ep1d(i) = txl*ep1d3(i,1) + txi*ep1d3(i,2) + txo*ep1d3(i,3) -! Sfcprop%weasd(i) = txl*weasd3(i,1) + txi*weasd3(i,2) + txo*weasd3(i,3) -! Sfcprop%snowd(i) = txl*snowd3(i,1) + txi*snowd3(i,2) + txo*snowd3(i,3) - Sfcprop%weasd(i) = txl*weasd3(i,1) + txi*weasd3(i,2) - Sfcprop%snowd(i) = txl*snowd3(i,1) + txi*snowd3(i,2) -! Sfcprop%tprcp(i) = txl*tprcp3(i,1) + txi*tprcp3(i,2) + txo*tprcp3(i,3) - - if (.not. flag_cice(i) .and. islmsk(i) == 2) then - tem = one - txl - evap(i) = txl*evap3(i,1) + tem*evap3(i,2) - hflx(i) = txl*hflx3(i,1) + tem*hflx3(i,2) - qss(i) = txl*qss3(i,1) + tem*qss3(i,2) - gflx(i) = txl*gflx3(i,1) + tem*gflx3(i,2) - else - evap(i) = txl*evap3(i,1) + txi*evap3(i,2) + txo*evap3(i,3) - hflx(i) = txl*hflx3(i,1) + txi*hflx3(i,2) + txo*hflx3(i,3) - qss(i) = txl*qss3(i,1) + txi*qss3(i,2) + txo*qss3(i,3) - gflx(i) = txl*gflx3(i,1) + txi*gflx3(i,2) + txo*gflx3(i,3) - endif - Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tice(i) + txo*tsfc3(i,3) -! Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tsfc3(i,2) + txo*tsfc3(i,3) - -! if (i == ipr .and. lprnt) then -! write(0,*)' tsfc=',Sfcprop%tsfc(i),' txl=',txl,' txi=',txi,' txo=',txo, & -! ' tsfc3=',tsfc3(i,:),' evap3=',evap3(i,:),' evap=',evap(i),' tice=',tice(i),& -! 'Sfcprop%zorl=',Sfcprop%zorl(ipr) -! endif - -! Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) -! Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) - - Sfcprop%zorll(i) = zorl3(i,1) - Sfcprop%zorli(i) = zorl3(i,2) - Sfcprop%zorlo(i) = zorl3(i,3) - - if (dry(i)) then - Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land - elseif (wet(i)) then - Sfcprop%tsfcl(i) = tsfc3(i,3) ! over land - else - Sfcprop%tsfcl(i) = tice(i) ! over land - endif - if (wet(i)) then - Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled - elseif (icy(i)) then - Sfcprop%tsfco(i) = tice(i) ! over lake or ocean when uncoupled - else - Sfcprop%tsfco(i) = tsfc3(i,1) ! over lake or ocean when uncoupled - endif - if (icy(i)) then - Sfcprop%tisfc(i) = tice(i) ! over lake or ocean when uncoupled -! if (Sfcprop%zorll(i) > 1000.0) Sfcprop%zorll(i) = zorl3(i,2) - elseif (wet(i)) then - Sfcprop%tisfc(i) = tsfc3(i,3) ! over lake or ocean when uncoupled - else - Sfcprop%tisfc(i) = tsfc3(i,1) ! over lake or ocean when uncoupled - endif - ! for coupled model ocean will replace this -! if (icy(i)) Sfcprop%tisfc(i) = tsfc3(i,2) ! over ice when uncoupled -! if (icy(i)) Sfcprop%tisfc(i) = tice(i) ! over ice when uncoupled - -! if (wet(i) .and. .not. Model%cplflx) then -! Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled -! Sfcprop%tisfc(i) = tsfc3(i,2) ! over ice when uncoupled -! endif - - if (.not. flag_cice(i)) then -! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - if (icy(i)) then ! return updated lake ice thickness & concentration to global array - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = fice(i) - Sfcprop%tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) - Sfcprop%hice(i) = zero - Sfcprop%fice(i) = zero - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - endif - endif - enddo - else - do i=1,im - if (flag_cice(i) .and. wet(i) .and. fice(i) < Model%min_seaice) then - islmsk(i) = 0 - fice(i) = zero - endif - if (islmsk(i) == 1) then - k = 1 - Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land - stress(i) = stress3(i,1) -! Sfcprop%tprcp(i) = tprcp3(i,1) - Sfcprop%tsfco(i) = tsfc3(i,1) - Sfcprop%tisfc(i) = tsfc3(i,1) - elseif (islmsk(i) == 0) then - k = 3 - Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) - stress(i) = stress3(i,3) -! Sfcprop%tprcp(i) = tprcp3(i,3) - Sfcprop%tisfc(i) = tsfc3(i,3) - Sfcprop%tsfcl(i) = tsfc3(i,3) - else - k = 2 - stress(i) = stress3(i,2) -! Sfcprop%tprcp(i) = fice(i)*tprcp3(i,2) + (one-fice(i))*tprcp3(i,3) - endif - Sfcprop%zorl(i) = zorl3(i,k) - cd(i) = cd3(i,k) - cdq(i) = cdq3(i,k) - rb(i) = rb3(i,k) - Sfcprop%ffmm(i) = ffmm3(i,k) - Sfcprop%ffhh(i) = ffhh3(i,k) - Sfcprop%uustar(i) = uustar3(i,k) - fm10(i) = fm103(i,k) - fh2(i) = fh23(i,k) -! tsurf(i) = tsurf3(i,k) - Diag%cmm(i) = cmm3(i,k) - Diag%chh(i) = chh3(i,k) - gflx(i) = gflx3(i,k) - ep1d(i) = ep1d3(i,k) - Sfcprop%weasd(i) = weasd3(i,k) - Sfcprop%snowd(i) = snowd3(i,k) - evap(i) = evap3(i,k) - hflx(i) = hflx3(i,k) - qss(i) = qss3(i,k) - Sfcprop%tsfc(i) = tsfc3(i,k) - - Sfcprop%zorll(i) = zorl3(i,1) - Sfcprop%zorli(i) = zorl3(i,2) - Sfcprop%zorlo(i) = zorl3(i,3) - - if (flag_cice(i)) then - if (wet(i) .and. fice(i) > Model%min_seaice) then ! this was already done for lake ice in sfc_sice - txi = fice(i) - txo = one - txi - evap(i) = txi * evap3(i,2) + txo * evap3(i,3) - hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) - Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) - stress(i) = txi *stress3(i,2) + txo * stress3(i,3) - qss(i) = txi * qss3(i,2) + txo * qss3(i,3) - ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) - Sfcprop%zorl(i) = txi*zorl3(i,2) + txo*zorl3(i,3) - endif - elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen - Sfcprop%zorl(i) = fice(i)*zorl3(i,2) + (one-fice(i))*zorl3(i,3) - else ! this would be over open ocean or land (no ice fraction) - Sfcprop%hice(i) = zero - Sfcprop%fice(i) = zero - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - icy(i) = .false. - endif - Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) - if (wet(i)) then - Sfcprop%tsfco(i) = tsfc3(i,3) - else - Sfcprop%tsfco(i) =Sfcprop%tsfc(i) - endif - do k=1,Model%kice ! store tiice in stc to reduce output in the nonfrac grid case - Sfcprop%stc(i,k) = Sfcprop%tiice(i,k) - enddo - enddo - endif ! if (Model%frac_grid) -!*## CCPP ## - -! --- compositing done - -! if (lprnt) write(0,*) 'tisfc=',Sfcprop%tisfc(ipr),'tice=',tice(ipr),' kdt=',kdt - - do i=1,im -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_post_run - Diag%epi(i) = ep1d(i) -!*## CCPP ## - Diag%dlwsfci(i) = adjsfcdlw(i) - Diag%ulwsfci(i) = adjsfculw(i) -!## CCPP ##* GFS_surface_composites.F90/GFS_surface_composites_inter_run - Diag%uswsfci(i) = adjsfcdsw(i) - adjsfcnsw(i) -!*## CCPP ## - Diag%dswsfci(i) = adjsfcdsw(i) -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_post_run - Diag%gfluxi(i) = gflx(i) - Diag%t1(i) = Statein%tgrs(i,1) - Diag%q1(i) = Statein%qgrs(i,1,1) - Diag%u1(i) = Statein%ugrs(i,1) - Diag%v1(i) = Statein%vgrs(i,1) -!*## CCPP ## - enddo - -! --- ... update near surface fields - -!## CCPP ##* sfc_diag.f/sfc_diag_run - call sfc_diag (im, Statein%pgr, Statein%ugrs(:,1), Statein%vgrs(:,1), & - Statein%tgrs(:,1), Statein%qgrs(:,1,1), work3, evap, & - Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, Sfcprop%q2m) -!*## CCPP ## - -!## CCPP ##* This block is not in the CCPP - Tbd%phy_f2d(:,Model%num_p2d) = zero -!*## CCPP ## - - 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%lsm == Model%lsm_noahmp) -! *DH - - if (Model%cplflx .or. Model%cplwav) then - do i=1,im - Coupling%u10mi_cpl (i) = Diag%u10m(i) - Coupling%v10mi_cpl (i) = Diag%v10m(i) - enddo - endif - - if (Model%cplflx) then - do i=1,im - Coupling%dlwsfci_cpl (i) = adjsfcdlw(i) - Coupling%dswsfci_cpl (i) = adjsfcdsw(i) - Coupling%dlwsfc_cpl (i) = Coupling%dlwsfc_cpl(i) + adjsfcdlw(i)*dtf - Coupling%dswsfc_cpl (i) = Coupling%dswsfc_cpl(i) + adjsfcdsw(i)*dtf - Coupling%dnirbmi_cpl (i) = adjnirbmd(i) - Coupling%dnirdfi_cpl (i) = adjnirdfd(i) - Coupling%dvisbmi_cpl (i) = adjvisbmd(i) - Coupling%dvisdfi_cpl (i) = adjvisdfd(i) - Coupling%dnirbm_cpl (i) = Coupling%dnirbm_cpl(i) + adjnirbmd(i)*dtf - Coupling%dnirdf_cpl (i) = Coupling%dnirdf_cpl(i) + adjnirdfd(i)*dtf - Coupling%dvisbm_cpl (i) = Coupling%dvisbm_cpl(i) + adjvisbmd(i)*dtf - Coupling%dvisdf_cpl (i) = Coupling%dvisdf_cpl(i) + adjvisdfd(i)*dtf - Coupling%nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) - if (wet(i)) then - Coupling%nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw3(i,3) - endif - Coupling%nlwsfc_cpl (i) = Coupling%nlwsfc_cpl(i) + Coupling%nlwsfci_cpl(i)*dtf - Coupling%t2mi_cpl (i) = Sfcprop%t2m(i) - Coupling%q2mi_cpl (i) = Sfcprop%q2m(i) - Coupling%tsfci_cpl (i) = Sfcprop%tsfc(i) -! Coupling%tsfci_cpl (i) = tsfc3(i,3) - Coupling%psurfi_cpl (i) = Statein%pgr(i) - enddo - -! --- estimate mean albedo for ocean point without ice cover and apply -! them to net SW heat fluxes - - do i=1,im -! if (Sfcprop%landfrac(i) < one) then ! Not 100% land - if (wet(i)) then ! some open water -! --- compute open water albedo - xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06_kind_phys - ocalnirbm_cpl(i) = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & - & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & - & * (xcosz_loc-one)) - ocalvisdf_cpl(i) = 0.06 - ocalvisbm_cpl(i) = ocalnirbm_cpl(i) - - Coupling%nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl(i)) - Coupling%nnirdfi_cpl(i) = adjnirdfd(i) * (one-ocalnirdf_cpl(i)) - Coupling%nvisbmi_cpl(i) = adjvisbmd(i) * (one-ocalvisbm_cpl(i)) - Coupling%nvisdfi_cpl(i) = adjvisdfd(i) * (one-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 - do i=1,im - Diag%gflux(i) = Diag%gflux(i) + gflx(i) * dtf - Diag%evbsa(i) = Diag%evbsa(i) + evbs(i) * dtf - Diag%evcwa(i) = Diag%evcwa(i) + evcw(i) * dtf - Diag%transa(i) = Diag%transa(i) + trans(i) * dtf - Diag%sbsnoa(i) = Diag%sbsnoa(i) + sbsno(i) * dtf - Diag%snowca(i) = Diag%snowca(i) + snowc(i) * dtf - Diag%snohfa(i) = Diag%snohfa(i) + snohf(i) * dtf - Diag%ep(i) = Diag%ep(i) + ep1d(i) * dtf -!*## CCPP ## -!## CCPP ##* sfc_diag_post.F90/sfc_diag_post_run - Diag%tmpmax(i) = max(Diag%tmpmax(i), Sfcprop%t2m(i)) - Diag%tmpmin(i) = min(Diag%tmpmin(i), Sfcprop%t2m(i)) - - Diag%spfhmax(i) = max(Diag%spfhmax(i), Sfcprop%q2m(i)) - Diag%spfhmin(i) = min(Diag%spfhmin(i), Sfcprop%q2m(i)) - enddo - - do i=1, im -! find max wind speed then decompose - tem = sqrt(Diag%u10m(i)*Diag%u10m(i) + Diag%v10m(i)*Diag%v10m(i)) - 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)), qmin) - Diag%dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - one) + 273.14 - enddo - - endif -!*## CCPP ## - -!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! -! do i=1,im -! --- ... compute coefficient of evaporation in evapc -! -! if (evapc(i) > one) evapc(i) = one -! --- ... over snow cover or ice or sea, coef of evap =one -! if (weasd(i) > zero .or. slmsk(i) /= one) evapc(i) = one -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_post_run -! --- ... Boundary Layer and Free atmospheic turbulence parameterization -! -! in order to achieve heat storage within canopy layer, in the canopy heat -! storage parameterization the kinematic sensible and latent heat fluxes -! (hflx & evap) as surface boundary forcings to the pbl scheme are -! reduced as a function of surface roughness -! - do i=1,im - hflxq(i) = hflx(i) - evapq(i) = evap(i) - hffac(i) = one - hefac(i) = one - enddo - if (Model%lheatstrg) then - do i=1,im - tem = 0.01_kind_phys * Sfcprop%zorl(i) ! change unit from cm to m - tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = Model%z0fac * min(max(tem1, zero), one) - tem = sqrt(Diag%u10m(i)*Diag%u10m(i)+Diag%v10m(i)*Diag%v10m(i)) - tem1 = (tem - u10min) / (u10max - u10min) - tem2 = one - min(max(tem1, zero), one) - hffac(i) = tem2 * hffac(i) - hefac(i) = one + Model%e0fac * hffac(i) - hffac(i) = one + hffac(i) - hflxq(i) = hflx(i) / hffac(i) - evapq(i) = evap(i) / hefac(i) - enddo - endif -!*## CCPP ## -! -! if (lprnt) write(0,*)' tsea3=',Sfcprop%tsfc(ipr),' slmsk=',Sfcprop%slmsk(ipr) & -! &, ' kdt=',kdt,' evap=',evapq(ipr) -! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) - -! do i=1,im -! if (islmsk(i) == 0) then -! oro_land(i) = zero -! else -! oro_land(i) = oro(i) -! endif -! enddo - -! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat -! if (lprnt) write(0,*)'befmonshoc phii=',Statein%phii(ipr,:) -! if (lprnt) write(0,*)'befmonshoc=',Statein%tgrs(ipr,:) -! if (lprnt) write(0,*)'befmonshocdtdt=',dtdt(ipr,1:10) -! if (lprnt) write(0,*)'befmonshoctkh=',Tbd%phy_f3d(ipr,1:10,ntot3d-1) -! if (lprnt) write(0,*)'befmonshochflx=',hflxq(ipr),' tsea=',Sfcprop%tsfc(ipr),& -! ' evap=',evapq(ipr) -! if (lprnt) write(0,*)'befmonshocq=',Statein%qgrs(ipr,:,1) -! if (lprnt) write(0,*)'befmonice=',Statein%qgrs(ipr,:,ntiw) -! if (lprnt) write(0,*)'befmonwat=',Statein%qgrs(ipr,:,ntcw) -! if (lprnt) write(0,*)'befmonshoctke=',Statein%qgrs(ipr,:,ntke) - -! write(0,*)' before monsho hflx=',hflxq,' me=',me -! write(0,*)' before monsho evap=',evapq,' me=',me - -!## CCPP ##* Note: In the CCPP, the vdftra array is prepared in GFS_PBL_generic.F90/GFS_PBL_generic_pre_run -! regardless of the following conditions. Therefore, this block is redundant in the CCPP and is not included. - - if (nvdiff == ntrac .or. Model%do_ysu .or. Model%shinhong) then -! - ntiwx = 0 - - if (Model%do_shoc) then - call moninshoc(ix, im, levs, nvdiff, ntcw, nncl, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Tbd%phy_f3d(1,1,ntot3d-1), prnum, ntke, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & - Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc,hflxq,& - evapq,stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& - Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, dkt, Tbd%hpbl, kinver, & - Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & - lprnt, ipr, me) -! if (lprnt) then -! write(0,*)' aftpbl phii=',Statein%phii(ipr,:) -! write(0,*)' aftpbl dtdt=',dtdt(ipr,:) -! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) -! write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) -! write(0,*)'aftmonshocq=',Statein%qgrs(ipr,:,1) -! write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) -! write(0,*)'aftmonice=',Statein%qgrs(ipr,:,ntiw) -! write(0,*)'aftmonwat=',Statein%qgrs(ipr,:,ntcw) -! write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) -! endif - - else - if (Model%satmedmf) then - if (Model%isatmedmf == 0) then ! initial version of satmedmfvdif (Nov 2018) -!## CCPP ##* satmedmfvdif.F/satmedmfvdif_run Note: The conditional above is checked in satmedmfvdif_init - call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiw, ntke, & - dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, garea, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflxq, evapq, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s) -!*## CCPP ## - elseif (Model%isatmedmf == 1) then ! updated version of satmedmfvdif (May 2019) -!## CCPP ##* satmedmfvdifq.F/satmedmfvdifq_run Note: The conditional above is checked in satmedmfvdifq_init - call satmedmfvdifq(ix, im, levs, nvdiff, ntcw, ntiw, ntke, & - dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, garea, islmsk, snowd3, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflxq, evapq, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, & - Model%dspfac, Model%bl_upfr, Model%bl_dnfr) -!*## CCPP ## - endif - elseif (Model%hybedmf) then - if (Model%moninq_fac > 0) then - call moninedmf(ix, im, levs, nvdiff, 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, hflxq, evapq, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl,& - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & - Model%xkzminv, Model%moninq_fac) - else - call moninedmf_hafs(ix, im, levs, nvdiff, 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, hflxq, evapq, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl,& - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & - Model%xkzminv, Model%moninq_fac,islmsk) - endif -! 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%do_ysu) then - ! if (Model%me==0) then - ! write(0,*) 'Error, ysuvdif only available through CCPP' - ! stop - ! end if - !elseif (Model%shinhong) then - ! if (Model%me==0) then - ! write(0,*) 'Error, shinhongvdif only available through CCPP' - ! stop - ! end if - elseif (.not. Model%old_monin) then - call moninq(ix, im, levs, nvdiff, 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, hflxq, evapq,& - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%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, hflxq, evapq, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Tbd%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, hflxq, evapq, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & - Tbd%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) - endif - - endif ! end if_hybedmf - endif ! end if_do_shoc - else -!*## CCPP ## -!## CCPP ## These variables are allocated in GFS_typedefs.F90/interstitial_create and -! initialized in GFS_typedefs.F90/interstitial_phys_reset; ntiwx is set in -! GFS_typedef.F90/interstitial_setup_tracers - allocate(vdftra(ix,levs,nvdiff), dvdftra(im,levs,nvdiff)) - dvdftra(:,:,:) = zero - ntiwx = 0 -! -!## CCPP ##* GFS_PBL_generic.F90/GFS_PBL_generic_pre_run (ntiwx is set in GFS_typedef.F90/interstitial_setup_tracers) - if (imp_physics == Model%imp_physics_wsm6) then -! WSM6 - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 4 - ntiwx = 3 - elseif (imp_physics == Model%imp_physics_thompson) then -! Thompson - if(Model%ltaerosol) then - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntlnc) - vdftra(i,k,5) = Statein%qgrs(i,k,ntinc) - vdftra(i,k,6) = Statein%qgrs(i,k,ntoz) - vdftra(i,k,7) = Statein%qgrs(i,k,ntwa) - vdftra(i,k,8) = Statein%qgrs(i,k,ntia) - enddo - enddo - kk = 8 - ntiwx = 3 - else - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntinc) - vdftra(i,k,5) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 5 - ntiwx = 3 - endif - elseif (imp_physics == Model%imp_physics_mg) then ! MG3/2 - if (ntgl > 0) then ! MG3 - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntrw) - vdftra(i,k,5) = Statein%qgrs(i,k,ntsw) - vdftra(i,k,6) = Statein%qgrs(i,k,ntgl) - vdftra(i,k,7) = Statein%qgrs(i,k,ntlnc) - vdftra(i,k,8) = Statein%qgrs(i,k,ntinc) - vdftra(i,k,9) = Statein%qgrs(i,k,ntrnc) - vdftra(i,k,10) = Statein%qgrs(i,k,ntsnc) - vdftra(i,k,11) = Statein%qgrs(i,k,ntgnc) - vdftra(i,k,12) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 12 - else ! MG2 - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntrw) - vdftra(i,k,5) = Statein%qgrs(i,k,ntsw) - vdftra(i,k,6) = Statein%qgrs(i,k,ntlnc) - vdftra(i,k,7) = Statein%qgrs(i,k,ntinc) - vdftra(i,k,8) = Statein%qgrs(i,k,ntrnc) - vdftra(i,k,9) = Statein%qgrs(i,k,ntsnc) - vdftra(i,k,10) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 10 - endif - ntiwx = 3 -! - elseif (imp_physics == Model%imp_physics_gfdl) then! GFDL MP - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) - vdftra(i,k,4) = Statein%qgrs(i,k,ntrw) - vdftra(i,k,5) = Statein%qgrs(i,k,ntsw) - vdftra(i,k,6) = Statein%qgrs(i,k,ntgl) - vdftra(i,k,7) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 7 - ntiwx = 3 - elseif (imp_physics == Model%imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist - do k=1,levs - do i=1,im - vdftra(i,k,1) = Statein%qgrs(i,k,1) - vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) - vdftra(i,k,3) = Statein%qgrs(i,k,ntoz) - enddo - enddo - kk = 3 - endif -! - if (trans_aero) then - k1 = kk - do n=Model%ntchs,Model%ntchm+Model%ntchs-1 - k1 = k1 + 1 - do k=1,levs - do i=1,im - vdftra(i,k,k1) = Statein%qgrs(i,k,n) - enddo - enddo - enddo - endif -! - if (ntke > 0) then ! prognostic TKE - ntkev = nvdiff - do k=1,levs - do i=1,im - vdftra(i,k,ntkev) = Statein%qgrs(i,k,ntke) - enddo - enddo - endif -!*## CCPP ## -! for SHOC nvdiff=ntrac, so the following is not needed unless cplchm is true -! ----------------------------------------------------- - if (Model%do_shoc) then -!## CCPP ##* moninshoc.f/moninshoc_run Note: The conditional above is not checked in the CCPP scheme; -! therefore the use of this scheme is controlled via the CCPP SDF - call moninshoc(ix, im, levs, nvdiff, ntcw, nncl, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Tbd%phy_f3d(1,1,ntot3d-1), prnum, ntkev, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & - Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflxq, & - evapq, stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, dkt, Tbd%hpbl, kinver, & - Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & - lprnt, ipr, me) -!*## CCPP ## - else - if (Model%satmedmf) then - if (Model%isatmedmf == 0) then ! initial version of satmedmfvdif (Nov 2018) -!## CCPP ##* satmedmfvdif.F/satmedmfvdif_run Note: The conditional above is checked in satmedmfvdif_init - call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiwx, ntkev, & - dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, garea, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflxq, evapq, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s) -!*## CCPP ## - elseif (Model%isatmedmf == 1) then ! updated version of satmedmfvdif (May 2019) -!## CCPP ##* satmedmfvdifq.F/satmedmfvdifq_run Note: The conditional above is checked in satmedmfvdifq_init - call satmedmfvdifq(ix, im, levs, nvdiff, ntcw, ntiwx, ntkev, & - dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, garea, islmsk, snowd3, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflxq, evapq, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, & - Model%dspfac, Model%bl_upfr, Model%bl_dnfr) -!*## CCPP ## - endif - elseif (Model%hybedmf) then -!## CCPP ## moninedmf.f/hedmf_run Note: The conditional above is not checked in the CCPP scheme; -! therefore the use of this scheme is controlled via the CCPP SDF - if ( Model%moninq_fac > 0 ) then - call moninedmf(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & - rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & - Sfcprop%ffhh, Sfcprop%tsfc, qss, hflxq, evapq, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & - Model%xkzminv, Model%moninq_fac) -!*## CCPP ## -!## CCPP ##* The following schemes are not in the CCPP yet. - else - call moninedmf_hafs(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & - rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & - Sfcprop%ffhh, Sfcprop%tsfc, qss, hflxq, evapq, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & - Model%xkzminv, Model%moninq_fac,islmsk) - endif - elseif (.not. Model%old_monin) then - call moninq(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflxq, evapq, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Tbd%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, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflxq, evapq, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Tbd%hpbl, gamt, gamq, dkt, kinver, & - Model%xkzm_m, Model%xkzm_h) - else - call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflxq, evapq, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & - Tbd%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) - endif - - endif ! end if_satmedmf - endif ! end if_do_shoc -!*## CCPP ## -!## CCPP ## GFS_PBL_generic.F90/GFS_PBL_generic_post_run - if (ntke > 0) then - do k=1,levs - do i=1,im - dqdt(i,k,ntke) = dvdftra(i,k,ntkev) - enddo - enddo - endif - if (trans_aero) then - k1 = kk - do n=Model%ntchs,Model%ntchm+Model%ntchs-1 - k1 = k1 + 1 - do k=1,levs - do i=1,im - dqdt(i,k,n) = dvdftra(i,k,k1) - enddo - enddo - enddo - endif - if (imp_physics == Model%imp_physics_wsm6) then ! WSM6 - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntoz) = dvdftra(i,k,4) - enddo - enddo - elseif (imp_physics == Model%imp_physics_thompson) then ! Thompson - if(Model%ltaerosol) then - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntlnc) = dvdftra(i,k,4) - dqdt(i,k,ntinc) = dvdftra(i,k,5) - dqdt(i,k,ntoz) = dvdftra(i,k,6) - dqdt(i,k,ntwa) = dvdftra(i,k,7) - dqdt(i,k,ntia) = dvdftra(i,k,8) - enddo - enddo - else - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntinc) = dvdftra(i,k,4) - dqdt(i,k,ntoz) = dvdftra(i,k,5) - enddo - enddo - endif - elseif (imp_physics == Model%imp_physics_mg) then ! MG3/2 - if (ntgl > 0) then ! MG - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntrw) = dvdftra(i,k,4) - dqdt(i,k,ntsw) = dvdftra(i,k,5) - dqdt(i,k,ntgl) = dvdftra(i,k,6) - dqdt(i,k,ntlnc) = dvdftra(i,k,7) - dqdt(i,k,ntinc) = dvdftra(i,k,8) - dqdt(i,k,ntrnc) = dvdftra(i,k,9) - dqdt(i,k,ntsnc) = dvdftra(i,k,10) - dqdt(i,k,ntgnc) = dvdftra(i,k,11) - dqdt(i,k,ntoz) = dvdftra(i,k,12) - enddo - enddo - else ! MG2 - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntrw) = dvdftra(i,k,4) - dqdt(i,k,ntsw) = dvdftra(i,k,5) - dqdt(i,k,ntlnc) = dvdftra(i,k,6) - dqdt(i,k,ntinc) = dvdftra(i,k,7) - dqdt(i,k,ntrnc) = dvdftra(i,k,8) - dqdt(i,k,ntsnc) = dvdftra(i,k,9) - dqdt(i,k,ntoz) = dvdftra(i,k,10) - enddo - enddo - endif -! - elseif (imp_physics == Model%imp_physics_gfdl) then ! GFDL MP - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntrw) = dvdftra(i,k,4) - dqdt(i,k,ntsw) = dvdftra(i,k,5) - dqdt(i,k,ntgl) = dvdftra(i,k,6) - dqdt(i,k,ntoz) = dvdftra(i,k,7) - enddo - enddo - - elseif (imp_physics == Model%imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntoz) = dvdftra(i,k,3) - enddo - enddo - endif -! - deallocate(vdftra, dvdftra) - - endif -!*## CCPP ## - -!## CCPP ##* GFS_PBL_generic.F90/GFS_PBL_generic_post_run - if (Model%cplchm) then - do i = 1, im - tem1 = max(Diag%q1(i), qmin) - tem = Statein%prsl(i,1) / (con_rd*Diag%t1(i)*(one+con_fvirt*tem1)) - Coupling%ushfsfci(i) = -con_cp * tem * hflx(i) ! upward sensible heat flux - enddo - Coupling%dkt (:,:) = dkt (:,:) - endif - -! if (lprnt) then -! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt -! write(0,*) ' dvsfc1=',dvsfc1(ipr),' kdt=',kdt -! write(0,*)' dtsfc1=',dtsfc1(ipr)*hffac(ipr) -! write(0,*)' dqsfc1=',dqsfc1(ipr)*hefac(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 - do i=1,im - if (Sfcprop%oceanfrac(i) > zero) then ! Ocean only, NO LAKES - if (Sfcprop%fice(i) > one - epsln) then ! no open water, thus use results from CICE - Coupling%dusfci_cpl(i) = Coupling%dusfcin_cpl(i) - Coupling%dvsfci_cpl(i) = Coupling%dvsfcin_cpl(i) - Coupling%dtsfci_cpl(i) = Coupling%dtsfcin_cpl(i) - Coupling%dqsfci_cpl(i) = Coupling%dqsfcin_cpl(i) - elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - tem1 = max(Diag%q1(i), qmin) - rho = Statein%prsl(i,1) / (con_rd*Diag%t1(i)*(one+con_fvirt*tem1)) - if (wind(i) > zero) then - tem = - rho * stress3(i,3) / wind(i) - Coupling%dusfci_cpl(i) = tem * Statein%ugrs(i,1) ! U-momentum flux - Coupling%dvsfci_cpl(i) = tem * Statein%vgrs(i,1) ! V-momentum flux - else - Coupling%dusfci_cpl(i) = zero - Coupling%dvsfci_cpl(i) = zero - endif - Coupling%dtsfci_cpl(i) = con_cp * rho * hflx3(i,3) ! sensible heat flux over open ocean - Coupling%dqsfci_cpl(i) = con_hvap * rho * evap3(i,3) ! latent heat flux over open ocean - else ! use results from PBL scheme for 100% open ocean - Coupling%dusfci_cpl(i) = dusfc1(i) - Coupling%dvsfci_cpl(i) = dvsfc1(i) - Coupling%dtsfci_cpl(i) = dtsfc1(i)*hffac(i) - Coupling%dqsfci_cpl(i) = dqsfc1(i)*hefac(i) - endif - - Coupling%dusfc_cpl (i) = Coupling%dusfc_cpl(i) + Coupling%dusfci_cpl(i) * dtf - Coupling%dvsfc_cpl (i) = Coupling%dvsfc_cpl(i) + Coupling%dvsfci_cpl(i) * dtf - Coupling%dtsfc_cpl (i) = Coupling%dtsfc_cpl(i) + Coupling%dtsfci_cpl(i) * dtf - Coupling%dqsfc_cpl (i) = Coupling%dqsfc_cpl(i) + Coupling%dqsfci_cpl(i) * dtf -! - else - Coupling%dusfc_cpl(i) = huge - Coupling%dvsfc_cpl(i) = huge - Coupling%dtsfc_cpl(i) = huge - Coupling%dqsfc_cpl(i) = huge - endif ! Ocean only, NO LAKES - enddo - endif -!*## CCPP ## -!-------------------------------------------------------lssav if loop ---------- -!## CCPP ## GFS_PBL_generic.F90/GFS_PBL_generic_post_run - if (Model%lssav) then - do i=1,im - Diag%dusfc (i) = Diag%dusfc(i) + dusfc1(i)*dtf - Diag%dvsfc (i) = Diag%dvsfc(i) + dvsfc1(i)*dtf - Diag%dtsfc (i) = Diag%dtsfc(i) + dtsfc1(i)*hffac(i)*dtf - Diag%dqsfc (i) = Diag%dqsfc(i) + dqsfc1(i)*hefac(i)*dtf - Diag%dusfci(i) = dusfc1(i) - Diag%dvsfci(i) = dvsfc1(i) - Diag%dtsfci(i) = dtsfc1(i)*hffac(i) - Diag%dqsfci(i) = dqsfc1(i)*hefac(i) - enddo -! 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(1:im,:,3) = Diag%dt3dt(1:im,:,3) + dtdt(1:im,:)*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 - do k=1,levs - do i=1,im - Diag%du3dt(i,k,1) = Diag%du3dt(i,k,1) + dudt(i,k) * dtf - Diag%du3dt(i,k,2) = Diag%du3dt(i,k,2) - dudt(i,k) * dtf - Diag%dv3dt(i,k,1) = Diag%dv3dt(i,k,1) + dvdt(i,k) * dtf - Diag%dv3dt(i,k,2) = Diag%dv3dt(i,k,2) - dvdt(i,k) * dtf - enddo - enddo - endif - - endif ! end if_lssav -!*## CCPP ## - -!## CCPP ##* This block not yet in CCPP. -! - if (ldiag_ugwp) then -! -! here for COORDE-2018 clean way to store averaged du3dt_pbl -! - do k=1,levs - do i=1,im - Diag%du3dt_pbl(i,k) = Diag%du3dt_pbl(i,k) + dUdt(i,k) * fdaily - Diag%dv3dt_pbl(i,k) = Diag%dv3dt_pbl(i,k) + dVdt(i,k) * fdaily - Diag%dt3dt_pbl(i,k) = Diag%dt3dt_pbl(i,k) + dTdt(i,k) * fdaily -! Tdudt(i,k) = Tdudt(i,k) + dUdt(i,k) * fdaily -! Tdvdt(i,k) = Tdvdt(i,k) + dVdt(i,k) * fdaily -! Tdtdt(i,k) = Tdtdt(i,k) + dTdt(i,k) * fdaily - enddo - enddo - endif - - if (Model%lssav) then - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,7) = Diag%dt3dt(i,k,7) - dtdt(i,k)*dtf - enddo - enddo - endif - endif -!*## CCPP ## - -!============================================================= GW-physics start -! -! Orographic gravity wave drag parameterization -! --------------------------------------------- - -!## CCPP ##* GFS_GWD_generic.F90/GFS_GWD_generic_pre_run - if (nmtvr == 14) then ! current operational - as of 2014 - do i=1,im -! vay-2018 -! copy to the separate container to avoid "use" of Sfcprop as "static" field -! sgh30 for TOFD -! - sgh30(i) = abs(Sfcprop%oro(i) - Sfcprop%oro_uf(i)) - - oc(i) = Sfcprop%hprime(i,2) - oa4(i,1) = Sfcprop%hprime(i,3) - oa4(i,2) = Sfcprop%hprime(i,4) - oa4(i,3) = Sfcprop%hprime(i,5) - oa4(i,4) = Sfcprop%hprime(i,6) - clx(i,1) = Sfcprop%hprime(i,7) - clx(i,2) = Sfcprop%hprime(i,8) - clx(i,3) = Sfcprop%hprime(i,9) - clx(i,4) = Sfcprop%hprime(i,10) - theta(i) = Sfcprop%hprime(i,11) - gamma(i) = Sfcprop%hprime(i,12) - sigma(i) = Sfcprop%hprime(i,13) - elvmax(i) = Sfcprop%hprime(i,14) - enddo - elseif (nmtvr == 10) then - do i=1,im - oc(i) = Sfcprop%hprime(i,2) - oa4(i,1) = Sfcprop%hprime(i,3) - oa4(i,2) = Sfcprop%hprime(i,4) - oa4(i,3) = Sfcprop%hprime(i,5) - oa4(i,4) = Sfcprop%hprime(i,6) - clx(i,1) = Sfcprop%hprime(i,7) - clx(i,2) = Sfcprop%hprime(i,8) - clx(i,3) = Sfcprop%hprime(i,9) - clx(i,4) = Sfcprop%hprime(i,10) - enddo - elseif (nmtvr == 6) then - do i=1,im - oc(i) = Sfcprop%hprime(i,2) - oa4(i,1) = Sfcprop%hprime(i,3) - oa4(i,2) = Sfcprop%hprime(i,4) - oa4(i,3) = Sfcprop%hprime(i,5) - oa4(i,4) = Sfcprop%hprime(i,6) - clx(i,1) = zero - clx(i,2) = zero - clx(i,3) = zero - clx(i,4) = zero - enddo - else -! -! no-oro effects -! - sgh30(:) = zero - oc = zero ; oa4 = zero ; clx = zero ; theta = zero - gamma = zero ; sigma = zero ; elvmax = zero - - endif ! end if_nmtvr -!*## CCPP ## - -!## CCPP ##* cires_ugwp.F90/cires_ugwp_run - only V0 is implemented -! -!===== UGWP-start: two versions V0 (knob_ugwp_version=0) and V1(knob_ugwp_version=1) -! -! - if (Model%do_gwd) then - if (knob_ugwp_version == 1 ) then - if (kdt < 2 .and. me == master) then - print *, ' VAY-attention UGWP-V1 cires_ugwp_driver ' - print *, ' Only Test-mode by developers ' - stop ' cires_ugwp_driver Test-mode Jan 2019 ' - endif - - call cires_ugwp_driver & - (im, levs, dtp, kdt, me, lprnt, Model%lonr, & - Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & - Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, & - Statein%qgrs(1:im,1:levs,1), Statein%prsi, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, & - del, Sfcprop%hprime, kpbl, & - dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & -!diagnostics - Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & - Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & - Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & - Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & - Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & -!COORDE-2019 diagnostics without 3d-fluxes: tauz_ogw, tauz_ngw .... - Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & - Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & - Diag%du3dt_ogw, Diag%du3dt_tms ) - -! do k=1,levs -! do i=1,im -! Pdtdt(i,k) = gw_dtdt(i,k) -! Pdudt(i,k) = gw_dudt(i,k) -! Pdvdt(i,k) = gw_dvdt(i,k) -! enddo -! enddo - - else -! -!knob_ugwp_version == o -! - if (kdt < 2 .and. me == master) then - print *, ' VAY-attention UGWP-V0, Jan 2019 ' - endif -! - allocate (tke(im,levs)) - if (ntke > 0) then - tke(1:im,:) = Statein%qgrs(1:im,:,ntke) + dqdt(1:im,:,ntke) * dtp - else - tke(:,:) = -9999.0_kind_phys - endif -! -! tendency without PBL-accumulations -! - call cires_ugwp_driver_v0 & - (me, master, im, levs, nmtvr, dtp, kdt, Model%lonr, & - Model%do_ugwp, Model%do_tofd, Model%cdmbgwd, & - Grid%xlat, Grid%xlat_d, & - Grid%sinlat, Grid%coslat, Grid%area, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs(1,1,1),& - Statein%prsi, Statein%prsl, Statein%prslk, Statein%phii, & - Statein%phil, del, Sfcprop%hprime(:,1), oc, oa4, clx, theta, & - gamma, sigma, elvmax, sgh30, kpbl, & - dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - tau_tms, tau_mtb, tau_ogw, tau_ngw, & - zm_mtb, zm_lwb, zm_ogw, ax_mtb, ax_ogw, ax_tms, & - Diag%zmtnblck, Diag%rain, ntke, tke, lprnt, ipr) - - -!Diag for COORDE-2019....... for cires_ugwp_driver_v0 - - if (ldiag_ugwp) then - do i=1,im - Diag%zmtb(i) = Diag%zmtb(i) + fdaily * zm_mtb(i) - Diag%zlwb(i) = Diag%zlwb(i) + fdaily * zm_lwb(i) - Diag%zogw(i) = Diag%zogw(i) + fdaily * zm_ogw(i) - Diag%tau_tofd(i) = Diag%tau_tofd(i) + fdaily * tau_tms(i) - Diag%tau_mtb(i) = Diag%tau_mtb(i) + fdaily * tau_mtb(i) - Diag%tau_ogw(i) = Diag%tau_ogw(i) + fdaily * tau_ogw(i) - Diag%tau_ngw(i) = Diag%tau_ngw(i) + fdaily * tau_ngw(i) - enddo - do k=1,levs - do i=1,im - Diag%du3dt_mtb(i,k) = Diag%du3dt_mtb(i,k) + fdaily * ax_mtb(i,k) - Diag%du3dt_tms(i,k) = Diag%du3dt_tms(i,k) + fdaily * ax_tms(i,k) - Diag%du3dt_ogw(i,k) = Diag%du3dt_ogw(i,k) + fdaily * ax_ogw(i,k) - Diag%du3dt_ngw(i,k) = Diag%du3dt_ngw(i,k) + fdaily * gw_dudt(i,k) - Diag%dv3dt_ngw(i,k) = Diag%dv3dt_ngw(i,k) + fdaily * gw_dvdt(i,k) - -! Tdudt(i,k) = Tdudt(i,k) + gw_dudt(i,k)* fdaily -! Tdvdt(i,k) = Tdvdt(i,k) + gw_dvdt(i,k)* fdaily -! Tdtdt(i,k) = Tdtdt(i,k) + gw_dvdt(i,k)* fdaily - enddo - enddo - endif -! - do k=1,levs - do i=1,im - dtdt(i,k) = dtdt(i,k) + gw_dtdt(i,k) - dudt(i,k) = dudt(i,k) + gw_dudt(i,k) - dvdt(i,k) = dvdt(i,k) + gw_dvdt(i,k) - enddo - enddo - - endif ! if (knob_ugwp_version == 1 ) then - endif ! if (do_gwd) then - -! *DH UGWD not yet in CCPP -! -!===== UGWP-end ===== ===== ===== -! - - if (Model%lssav) then - do i=1,im - Diag%dugwd(i) = Diag%dugwd(i) + dusfcg(i)*dtf - Diag%dvgwd(i) = Diag%dvgwd(i) + dvsfcg(i)*dtf - enddo - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%du3dt(i,k,2) = Diag%du3dt(i,k,2) + dudt(i,k) * dtf - Diag%dv3dt(i,k,2) = Diag%dv3dt(i,k,2) + dvdt(i,k) * dtf - Diag%dt3dt(i,k,7) = Diag%dt3dt(i,k,7) + dtdt(i,k) * dtf - enddo - enddo - endif - endif - -! -!=============================================== -! -!! if (ldiag_ugwp) then -!! do k=1,levs -!! do i=1,im -!! Tdudt(i,k) = Tdudt(i,k) + PdUdt(i,k) * fdaily -!! Tdvdt(i,k) = Tdvdt(i,k) + PdVdt(i,k) * fdaily -!! Tdtdt(i,k) = Tdtdt(i,k) + PdTdt(i,k) * fdaily -! -!! enddo -!! enddo -!! endif - -!## CCPP ##* rayleigh_damp.f/rayleigh_damp_run Note: Conditional IS checked -! within the scheme (returns from scheme if condition is not met) -! Rayleigh damping near the model top - if( .not. Model%lsidea .and. Model%ral_ts > zero) 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=',(Statein%tgrs(ipr,k),k=1,10) -! write(0,*)' dtdt=',(dtdt(ipr,k),k=1,10) -! endif - -! Standard accum-Update before "moist physics" by "PBL + GWP + RF" as in GFS/GSM -! - -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_stateout_update Note: Terms -! containing gw_* are related to the CIRES UGWP code and are not currently in -! this scheme. - do k=1,levs - do i=1,im - Stateout%gt0(i,k) = Statein%tgrs(i,k) + dtdt(i,k) * dtp - Stateout%gu0(i,k) = Statein%ugrs(i,k) + dudt(i,k) * dtp - Stateout%gv0(i,k) = Statein%vgrs(i,k) + dvdt(i,k) * dtp - enddo - enddo - Stateout%gq0(1:im,:,:) = Statein%qgrs(1:im,:,:) + dqdt(1:im,:,:) * dtp -!*## CCPP ## - -!## CCPP ##* This is not in the CCPP yet. -!================================================================================ -! above: updates of the state by UGWP oro-GWS and RF-damp -! Diag%tav_ugwp & Diag%uav_ugwp(i,k)-Updated U-T state before moist/micro ! physics -!================================================================================ - - if (ldiag_ugwp) then - do k=1,levs - do i=1,im - Diag%tav_ugwp(i,k) = Diag%tav_ugwp(i,k) + Stateout%gt0(i,k) * fdaily - Diag%uav_ugwp(i,k) = Diag%uav_ugwp(i,k) + Stateout%gu0(i,k) * fdaily -! Diag%vav_ogw(i,k) = Diag%vav_ogw(i,k) + Stateout%gv0(i,k) * fdaily - enddo - enddo - endif -!*## CCPP ## - -!================================================================================ -! It is not clear Do we need it, "ideaca_up", having stability check inside UGWP-module -!## CCPP ##* This is not in the CCPP yet. - if (Model%lsidea) then ! idea convective adjustment - call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) - endif -!*## CCPP ## - -! --- ... ozone physics - - if (ntoz > 0 .and. ntrac >= ntoz) then - if (oz_coeff > 4) then -!## CCPP ##* ozphys_2015.f/ozphys_2015_run Note: The conditionals above are not -! checked in the scheme. The scheme's use is controlled by its presense in the -! CCPP SDF - call ozphys_2015 (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,ntoz), & - Stateout%gq0(1,1,ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) -!*## CCPP ## -! if (Model%ldiag3d) then -! do k=1,levs -! do i=1,im -! Diag%dq3dt(i,k,6) = dq3dt_loc(i,k,6) -! Diag%dq3dt(i,k,7) = dq3dt_loc(i,k,7) -! Diag%dq3dt(i,k,8) = dq3dt_loc(i,k,8) -! Diag%dq3dt(i,k,9) = dq3dt_loc(i,k,9) -! enddo -! enddo -! endif - else -!## CCPP ##* ozphys.f/ozphys_run - call ozphys (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,ntoz), & - Stateout%gq0(1,1,ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) -!*## CCPP ## -! if (Model%ldiag3d) then -! do k=1,levs -! do i=1,im -! Diag%dq3dt(i,k,6) = dq3dt_loc(i,k,6) -! Diag%dq3dt(i,k,7) = dq3dt_loc(i,k,7) -! Diag%dq3dt(i,k,8) = dq3dt_loc(i,k,8) -! Diag%dq3dt(i,k,9) = dq3dt_loc(i,k,9) -! enddo -! enddo -! endif - endif - endif - - if (Model%h2o_phys) then -!## CCPP ## h2ophys.f/h2ophys_run Note: The conditional is not checked within -! the scheme. The scheme's use is controlled via the CCPP SDF. - 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) -!*## CCPP ## - 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=',Stateout%gt0(ipr,:) & -! &, ' kdt=',kdt,' xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) -! print *,' dtdt=',dtdt(ipr,:) -! print *,' gu0=',gu0(ipr,:) -! print *,' gv0=',gv0(ipr,:) -! write(0,*) ' gt0=',(Stateout%gt0(ipr,k),k=1,levs),' kdt=',kdt -! write(0,*)' gq0=',(Stateout%gq0(ipr,k,1),k=1,levs) -! write(0,*)' gq0i2=',(Stateout%gq0(ipr,k,ntiw),k=1,levs) -! write(0,*)' gq1=',(Stateout%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,:) - -!## CCPP ## GFS_DCNV_generic.F90/GFS_DCNV_generic_pre_run - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - dtdt(i,k) = Stateout%gt0(i,k) - dudt(i,k) = Stateout%gu0(i,k) - dvdt(i,k) = Stateout%gv0(i,k) - enddo - enddo - elseif (Model%do_cnvgwd) then - dtdt(1:im,:) = Stateout%gt0(1:im,:) - endif ! end if_ldiag3d/cnvgwd - - if (Model%ldiag3d .or. Model%cplchm) then - dqdt(1:im,:,1) = Stateout%gq0(1:im,:,1) - endif ! end if_ldiag3d/cplchm - - if (Model%cplchm) then - Coupling%dqdti(1:im,:) = zero - endif ! end if_cplchm -!*## CCPP ## - -!## CCPP ## Only get_prs_fv3.F90/get_phi_fv3_run is a scheme (GFS_HYDRO is assumed to be undefined) -#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 -! if (lprnt) write(0,*)'bef get_phi_fv3 gt0=',Stateout%gt0(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)'bef get_phi_fv3 gq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)'bef get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt - -!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) - -! if (lprnt) write(0,*)'aft get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt -#endif -!*## CCPP ## - -!## CCPP ## These variables are initialized every physics time step through -! GFS_typedefs.F90/interstitial_phys_reset - do k=1,levs - do i=1,im - clw(i,k,1) = zero - clw(i,k,2) = -999.9_kind_phys - enddo - enddo - - if(imp_physics == Model%imp_physics_thompson) then - if(Model%ltaerosol) then - ice00 (:,:) = zero - liq0 (:,:) = zero - else - ice00 (:,:) = zero - endif - endif -!*## CCPP ## - -! --- ... for convective tracer transport (while using ras, csaw, or samf) -! (the code here implicitly assumes that ntiw=ntcw+1) - -!## CCPP ## Most of this code block is in GFS_typedefs.F90/interstitial_setup_tracers except -! for code that needs to be executed every time step (noted below). For those lines, -! they are in GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run. - ntk = 0 - tottracer = 0 - if (Model%cscnv .or. Model%satmedmf .or. Model%trans_trac ) then - otspt(:,:) = .true. ! otspt is used only for cscnv - otspt(1:3,:) = .false. ! this is for sp.hum, ice and liquid water -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & -! n /= ntlnc .and. n /= ntinc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - do k=1,levs - do i=1,im - clw(i,k,tracers) = Stateout%gq0(i,k,n) - enddo - enddo -!*## CCPP ## - if (ntke == n ) then - otspt(tracers+1,1) = .false. - ntk = tracers - endif - if (ntlnc == n .or. ntinc == n .or. ntrnc == n .or. ntsnc == n .or. ntgnc == n) & -! if (ntlnc == n .or. ntinc == n .or. ntrnc == n .or. ntsnc == n .or.& -! ntrw == n .or. ntsw == n .or. ntgl == n) & - otspt(tracers+1,1) = .false. - if (trans_aero .and. Model%ntchs == n) itc = tracers - endif - enddo - tottracer = tracers - 2 - endif ! end if_ras or cfscnv or samf -!*## CCPP ## - -! if (kdt == 1 .and. me == 0) & -! write(0,*)' trans_trac=',Model%trans_trac,' tottracer=', & -! & tottracer,' kdt=',kdt,' ntk=',ntk -!## CCPP ##* These variables are initialized in GFS_typedefs.F90/interstitial_phys_reset - do i=1,im - ktop(i) = 1 - kbot(i) = levs - enddo -!*## CCPP ## - -! --- ... calling condensation/precipitation processes -! -------------------------------------------- -!## CCPP ## GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run - if (ntcw > 0) then -! if (imp_physics == Model%imp_physics_mg .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf - if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < half) then ! compute rhc for GMAO macro physics cloud pdf - do i=1,im - tx1(i) = one / Statein%prsi(i,1) - tx2(i) = one - rhc_max*work1(i) - Model%crtrh(1)*work2(i) - kk = min(kinver(i), max(2,kpbl(i))) - tx3(i) = Statein%prsi(i,kk)*tx1(i) - tx4(i) = Model%crtrh(2) - Model%crtrh(3)*abs(cos(Grid%xlat(i))) - enddo - do k = 1, levs - do i = 1, im - tem = Statein%prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) -! -! Using crtrh(2) and crtrh(3) from the namelist instead of 0.3 and 0.2 -! and crtrh(1) represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) - - if (islmsk(i) > 0) then - tem1 = one / (one+exp(tem1+tem1)) - else - tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) - endif - tem2 = one / (one+exp(tem2)) - - rhc(i,k) = min(rhc_max, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) - enddo - enddo - else - do k=1,levs - do i=1,im - kk = max(10,kpbl(i)) - if (k < kk) then - tem = Model%crtrh(1) - (Model%crtrh(1)-Model%crtrh(2)) & - * (one-Statein%prslk(i,k)) / (one-Statein%prslk(i,kk)) - else - tem = Model%crtrh(2) - (Model%crtrh(2)-Model%crtrh(3)) & - * (Statein%prslk(i,kk)-Statein%prslk(i,k)) / Statein%prslk(i,kk) - endif - if (rhc_max > tem) tem = rhc_max * work1(i) + tem * work2(i) - rhc(i,k) = max(zero, min(one, tem)) - enddo - enddo - endif - endif ! ntcw > 0 -!*## CCPP ## -! - if (imp_physics == Model%imp_physics_zhao_carr .or. & - imp_physics == Model%imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics -!## CCPP ##* precpd.f/zhaocarr_precpd_run - do i=1,im - psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) - prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) - enddo -!*## CCPP ## -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntcw) - enddo - enddo - elseif (imp_physics == Model%imp_physics_gfdl) then - clw(1:im,:,1) = Stateout%gq0(1:im,:,ntcw) - elseif (imp_physics == Model%imp_physics_thompson) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - enddo - enddo - if(Model%ltaerosol) then - ice00(:,:) = clw(:,:,1) - liq0(:,:) = clw(:,:,2) - else - ice00(:,:) = clw(:,:,1) - endif - elseif (imp_physics == Model%imp_physics_wsm6 .or. & - imp_physics == Model%imp_physics_mg) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - enddo - enddo -!*## CCPP ## -!## CCPP ## These lines are not in the CCPP since it appeared that they were -! not needed. These variables are only ever used if (imp_physics == 99 .or. imp_physics == 98) -! which is handled by the first if statement. - else - do i=1,im - psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) - prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) - enddo -!*## CCPP ## -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run - rhc(:,:) = one -!*## CCPP ## - endif - -! if (lprnt) write(0,*)' clwice=',clw(ipr,:,1) -! if (lprnt) write(0,*)' clwwat=',clw(ipr,:,2) -! if (lprnt) write(0,*)' rhc=',rhc(ipr,:) - -! -! Call SHOC if do_shoc is true and shocaftcnv is false -! -!## CCPP ##* gcm_shoc.F90/shoc_run Note: do_shoc is not checked in the scheme, so -! using this scheme is controlled via the CCPP SDF. - if (Model%do_shoc .and. .not. Model%shocaftcnv) then - if (imp_physics == Model%imp_physics_mg) then - do k=1,levs - do i=1,im -!## CCPP ##* These lines are commented out in gcm_shoc.F90/shoc_run since they are -! previously executed in GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run -! clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice -! clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water -!*## CCPP ## -!## CCPP ##* These lines are commented out in gcm_shoc.F90/shoc_run since it is -! not necessary to copy global variables to local variables - ncpl(i,k) = Stateout%gq0(i,k,ntlnc) - ncpi(i,k) = Stateout%gq0(i,k,ntinc) -!*## CCPP ## - enddo - enddo - if (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - enddo - enddo - elseif (Model%fprcp > 1) then - do k=1,levs - do i=1,im - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) + Stateout%gq0(i,k,ntgl) -! clw(i,k,1) = clw(i,k,1) + Stateout%gq0(i,k,ntgl) - enddo - enddo - endif - elseif (imp_physics == Model%imp_physics_gfdl) then ! GFDL MP - needs modify for condensation - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - enddo - enddo - elseif (imp_physics == Model%imp_physics_zhao_carr .or. & - imp_physics == Model%imp_physics_zhao_carr_pdf) then - do k=1,levs - do i=1,im - if (abs(Stateout%gq0(i,k,ntcw)) < epsq) then - Stateout%gq0(i,k,ntcw) = zero - endif - tem = Stateout%gq0(i,k,ntcw) & - & * max(zero, MIN(one, (TCR-Stateout%gt0(i,k))*TCRF)) - clw(i,k,1) = tem ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) - tem ! water - enddo - enddo - endif - -! if (lprnt) write(0,*)'gt01=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,:,1) -! if (lprnt) write(0,*)'phii=',Statein%phii(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)'clwi=',clw(ipr,:,1) -! if (lprnt) write(0,*)'clwl=',clw(ipr,:,2) -! if (lprnt) write(0,*)'befncpi=',ncpi(ipr,:) -! if (lprnt) write(0,*)'tkh=',Tbd%phy_f3d(ipr,:,ntot3d-1) -! if (lprnt) write(0,*) ' befshoc hflx=',hflxq(ipr),' evap=',evapq(ipr),& -! ' stress=',stress(ipr) -! dtshoc = 60.0 -! dtshoc = 120.0 -! dtshoc = dtp -! dtshoc = min(dtp, 300.0) -! nshocm = max(1, nint(dtp/dtshoc)) -! dtshoc = dtp / nshocm -! do nshoc=1,nshocm -! if (lprnt) write(0,*)' before shoc tke=',clw(ipr,1:45,ntk), & -! &' kdt=',kdt,'xlon=',grid%xlon(ipr),' xlat=',grid%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) = Stateout%gq0(1:im,:,1) -! dqdt(1:im,:,2) = Stateout%gq0(1:im,:,ntiw) -! dqdt(1:im,:,3) = Stateout%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), & -! call shoc (ix, im, 1, levs, levs+1, dtshoc, me, 1, Statein%prsl(1,1), & -! call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Staotein%prsl(1,1), & -! write(0,*)' before shoc hflx=',hflxq, ' me=',me -! write(0,*)' before shoc evap=',evapq,' me=',me - call shoc (ix, im, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), del,& - 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), qsnw, qrn, & - rhc, Model%sup, Model%shoc_parm(1), Model%shoc_parm(2), & - Model%shoc_parm(3), Model%shoc_parm(4), & - Model%shoc_parm(5), Tbd%phy_f3d(1,1,ntot3d-2), & - clw(1,1,ntk), hflxq, evapq, prnum, & - Tbd%phy_f3d(1,1,ntot3d-1), Tbd%phy_f3d(1,1,ntot3d), & - lprnt, ipr, imp_physics, ncpl, ncpi) - - -! if (lprnt) write(0,*)'aftncpi=',ncpi(ipr,:) -! enddo -! if (imp_physics == Model%imp_physics_mg .and. Model%fprcp > 1) then -! do k=1,levs -! do i=1,im -! clw(i,k,1) = clw(i,k,1) - Stateout%gq0(i,k,ntgl) -! enddo -! enddo -! endif - -! if (lprnt) write(0,*)'aftshocgt0=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'aftshocgq0=',Stateout%gq0(ipr,:,1) -! if (lprnt) write(0,*)' aft shoc tke=',clw(ipr,1:25,ntk), & -! &' kdt=',kdt,'xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) -! if (lprnt) write(0,*)' aftshoccld=',Tbd%phy_f3d(ipr,:,ntot3d-2)*100 -! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) -! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,2) -! write(1000+me,*)' at latitude = ',lat -! rain1 = zero -! 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 ') -! tem = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & -! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & -! &, ' shoc ', grid%xlon(1:im), grid%xlat(1:im)) - -!## CCPP ## this is in CCPP's gcm_shoc (but commented out because not needed) - if (imp_physics == Model%imp_physics_mg) then - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntlnc) = ncpl(i,k) - Stateout%gq0(i,k,ntinc) = ncpi(i,k) - enddo - enddo - endif -!*## CCPP ## -! 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 -! -!*## CCPP ## - endif ! if(do_shoc) - -! -! --- ... calling convective parameterization -! ----------------------------------- - if (Model%do_deep) then - -!## CCPP ## GFS_DCNV_generic.F90/GFS_DCNV_generic_pre_run Note: The conditional -! above is not checked within the scheme, so the execution of the code below -! is controlled via its presence in the CCPP SDF. - -!*## CCPP ## - if (.not. Model%ras .and. .not. Model%cscnv) then - - if (Model%imfdeepcnv == 1) then ! no random cloud top -!## CCPP ##* sascnvn.F/sascnvn_run - 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, ncld, 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,imp_physics,& - Model%clam_deep, Model%c0s_deep, & - Model%c1_deep, Model%betal_deep, Model%betas_deep, & - Model%evfact_deep, Model%evfactl_deep, & - Model%pgcon_deep) -!*## CCPP ## - elseif (Model%imfdeepcnv == 2) then -!## CCPP ##* GFS_typedefs.f90/interstitial_setup_tracers - if(.not. Model%satmedmf .and. .not. Model%trans_trac) then - nsamftrac = 0 - else - nsamftrac = tottracer - endif -!*## CCPP ## -!## CCPP ##* samfdeepcnv.f/samfdeepcnv_run - call samfdeepcnv(im, ix, levs, dtp, itc, Model%ntchm, ntk, nsamftrac, & - del, Statein%prsl, Statein%pgr, Statein%phil, clw, & - Stateout%gq0(:,:,1), Stateout%gt0, & - Stateout%gu0, Stateout%gv0, Model%fscav, & - cld1d, rain1, kbot, ktop, kcnv, & - islmsk, garea, & - Statein%vvl, ncld, 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, & - imp_physics, & - 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, & - Model%do_ca, Model%ca_closure, Model%ca_entr, & - Model%ca_trigger, Model%nthresh, Coupling%ca_deep, & - Coupling%condition) -!*## CCPP ## -! if (lprnt) print *,' rain1=',rain1(ipr) - !elseif (Model%imfdeepcnv == 3) then - ! if (Model%me==0) then - ! write(0,*) 'Error, GF convection scheme only available through CCPP' - ! stop - ! end if - !elseif (Model%imfdeepcnv == 4) then - ! if (Model%me==0) then - ! write(0,*) 'Error, New Tiedtke convection scheme only available through CCPP' - ! stop - ! end if - elseif (Model%imfdeepcnv == 0) then ! random cloud top -!## CCPP ##* This is not in the CCPP yet. - 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, ncld, & - 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,imp_physics ) -! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) -!*## CCPP ## - endif - -!## CCPP ##* GFS_DCNV_generic.F90/GFS_DCNV_generic_post_run - 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) = zero - cnvc(i,k) = zero - 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) = zero - enddo - enddo - endif -!*## CCPP ## -! - else ! ras or cscnv -!## CCPP ## cs_conv.F90/cs_conv_pre_run - fscav(:) = zero - if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) - - fswtr(:) = zero -! write(0,*)' bef cs_cconv phii=',phii(ipr,:) -! &,' sizefsc=',size(fscav) -! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me -! do k=1,levs -! do i=1,im -! dqdt(i,k,1) = Stateout%gq0(i,k,1) -! dqdt(i,k,2) = clw(i,k,2) -! dqdt(i,k,3) = clw(i,k,1) -! enddo -! enddo -!*## CCPP ## - -! -! JLS NOTE: The convective mass fluxes (dt_mf, dd_mf and ud_mf) passed in and out of cs_conv have not been multiplied by -! the timestep (i.e, the are in kg/m2/sec) as they are in all other convective schemes. EMC is aware of this problem, -! and in the future will be fixing this discrepancy. In the meantime, CCPP will use the same mass flux standard_name -! and long_name as the other convective schemes, where the units are in kg/m2. (Aug 2018) -! -! if (lprnt) write(0,*)'befcsgt0=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'befcstke=',clw(ipr,1:25,ntk) - - allocate (sigmatot(im,levs), sigmafrac(im,levs)) - -! JLS NOTE: The variable rain1 output from cs_convr (called prec inside the subroutine) is a precipitation flux (kg/m2/sec), -! not meters LWE like the other schemes. It is converted to m after the call to cs_convr. - -!## CCPP ## cs_conv.F90/cs_conv_run - call cs_convr (ix, im, levs, ntrac+1, nn, tottracer+3, & - Model%nctp, otspt(1:ntrac+1,1:2), 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), Model%cs_parm(9), sigmatot, & -! Model%cs_parm(4), sigmai, sigmatot, vverti, & - Model%do_aw, Model%do_awdd, Model%flx_form, & - lprnt, ipr, kcnv, QLCN, QICN, & - w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & -! w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics) -!*## CCPP ## -! if (lprnt) write(0,*)'aftcsgt0=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'aftcstke=',clw(ipr,1:25,ntk) - -! 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') -! tem = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & -! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & -! &, ' cs_conv', grid%xlon(1:im), grid%xlat(1:im)) - -!## CCPP ##* Not in the CCPP. TODO: Does this need to be in cs_conv_post_run? - rain1(:) = rain1(:) * (dtp*con_p001) -!## CCPP ##* cs_conv.F90/cs_conv_post_run - 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) = half * (sigmatot(i,k)+sigmatot(i,kk)) - enddo - enddo - endif -!*## CCPP ## -! if (lprnt) then -! write(0,*)' gt01=',stateout%gt0(ipr,:),' kdt=',kdt -! write(0,*)' gq01=',stateout%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 - -!## CCPP ##* This code not yet in CCPP Note: Likely belongs in rascnv_pre. - if (Model%ccwf(1) >= zero .or. Model%ccwf(2) >= 0) then - do i=1,im - ccwfac(i) = Model%ccwf(1)*work1(i) + Model%ccwf(2)*work2(i) - dlqfac(i) = Model%dlqf(1)*work1(i) + Model%dlqf(2)*work2(i) - psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) - praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) - enddo - else - do i=1,im - ccwfac(i) = -999.0_kind_phys - dlqfac(i) = zero - psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) - praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) - enddo - 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) = Stateout%gq0(i,k,1) -! dqdt(i,k,2) = clw(i,k,2) -! dqdt(i,k,3) = clw(i,k,1) -! enddo -! enddo - - revap = .true. -! if (ncld ==2) revap = .false. - trcmin(:) = -999999.0_kind_phys - if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kind_phys -!*## CCPP ## -! if (lprnt) write(0,*)' gt04bras=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)' gq04bras=',Stateout%gq0(ipr,:,1) -! if (lprnt) write(0,*)'befrasclw1=',clw(ipr,:,1) -! if (lprnt) write(0,*)'befrasclw2=',clw(ipr,:,2) -! if (lprnt) write(0,*)'befrastke=',clw(ipr,:,ntk) -! if (lprnt) write(0,*)'trcmin=',trcmin(ntk-2),' ntk=',ntk -!## CCPP ## Not in CCPP yet. - 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, ccwfac, Model%nrcm, rhc, ud_mf, & - dd_mf, dt_mf, praur_l, Model%wminras(1), & - psaur_l, Model%wminras(2), dlqfac, & - lprnt, ipr, kdt, revap, QLCN, & - QICN, w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & -! QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics, & -! trcmin) - trcmin, ntk) -!*## CCPP ## - -! if (lprnt) write(0,*)' gt04=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)' gq04=',Stateout%gq0(ipr,:,1) -! if (lprnt) write(0,*)'aftrasclw1=',clw(ipr,:,1) -! if (lprnt) write(0,*)'aftrasclw2=',clw(ipr,:,2) -! if (lprnt) write(0,*)'aftrastke=',clw(ipr,:,ntk) - - endif - -! write(1000+me,*)' at latitude = ',lat -! tem = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & -! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & -! &, ' ras_conv', grid%xlon(1:im), grid%xlat(1:im)) -! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr),' me=',me,' kdt=',kdt -! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) -! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) - -!## CCPP ##* Not in CCPP yet. - cld1d = 0 -!*## CCPP ## - - endif ! end if_not_ras - -!## CCPP ##* GFS_DCNV_generic.F90/GFS_DCNV_generic_post - -!*## CCPP ## - else ! no parameterized deep convection -!## CCPP ##* GFS_typedefs.F90/interstitial_phys_reset Note: These are only zeroed out -! initially, prior to calling physics. - cld1d = zero - rain1 = zero - ud_mf = zero - dd_mf = zero - dt_mf = zero -!*## CCPP ## - endif - -! if (lprnt) then -! write(0,*)' aftcnvgt0=',stateout%gt0(ipr,:),' kdt=',kdt -! write(0,*)' aftcnvgq0=',(stateout%gq0(ipr,k,1),k=1,levs) -! write(0,*)' gq0i2=',(stateout%gq0(ipr,k,ntiw),k=1,levs) -! write(0,*)' aftcnvgq1=',(stateout%gq0(ipr,k,ntcw),k=1,levs) -! endif -! -!## CCPP ## GFS_DCNV_generic.F90/GFS_DCNV_generic_post_run - do i=1,im - Diag%rainc(i) = frain * rain1(i) - enddo -! - if (Model%lssav) then - do i=1,im - Diag%cldwrk (i) = Diag%cldwrk (i) + cld1d(i) * dtf - enddo - - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,4) = Diag%dt3dt(i,k,4) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain -! Diag%dq3dt(i,k,2) = Diag%dq3dt(i,k,2) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - Diag%du3dt(i,k,3) = Diag%du3dt(i,k,3) + (Stateout%gu0(i,k)-dudt(i,k)) * frain - Diag%dv3dt(i,k,3) = Diag%dv3dt(i,k,3) + (Stateout%gv0(i,k)-dvdt(i,k)) * frain - -! Diag%upd_mf(i,k) = Diag%upd_mf(i,k) + ud_mf(i,k) * (con_g*frain) -! Diag%dwn_mf(i,k) = Diag%dwn_mf(i,k) + dd_mf(i,k) * (con_g*frain) -! Diag%det_mf(i,k) = Diag%det_mf(i,k) + dt_mf(i,k) * (con_g*frain) - enddo - enddo - endif ! if (ldiag3d) - - endif ! end if_lssav -!*## CCPP ## -! -!## CCPP ##* This block not yet in CCPP. - if (ldiag_ugwp) then - tem = frain/dtp - do k=1,levs - do i=1,im -! -! frain = dtf / dtp = 1 -! - PdUdt = (Stateout%gu0(i,k)-dudt(i,k)) * tem - PdVdt = (Stateout%gv0(i,k)-dVdt(i,k)) * tem - PdTdt = (Stateout%gt0(i,k)-dTdt(i,k)) * tem - - Diag%du3dt_moist(i,k) = Diag%du3dt_moist(i,k) + PdUdt - Diag%dv3dt_moist(i,k) = Diag%dv3dt_moist(i,k) + PdVdt - Diag%dt3dt_moist(i,k) = Diag%dt3dt_moist(i,k) + PdTdt -! -! Attention : frain and increments -! -! Tdudt(i,k) = Tdudt(i,k) + PdUdt * fdaily -! Tdvdt(i,k) = Tdvdt(i,k) + PdVdt * fdaily -! Tdtdt(i,k) = Tdtdt(i,k) + PdTdt * fdaily - enddo - enddo - endif -! if (Model%do_ugwp) then -! -! Put in the instantaneous "Diag%-arrays" to drive UGWP-convective triggers -! from previous time step we need: LH-release + cld_top/bot + precip -! -! endif -!*## CCPP ## - -! 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 (lprnt) then -! write(0,*) ' befgwgt0=',Stateout%gt0(ipr,:) -! write(0,*) ' befgwgq0=',Stateout%gq0(ipr,:,1) -! write(0,*) ' do_cnvgwd=',Model%do_cnvgwd -! endif - -! DH* this block is in gwdc_pre -!## CCPP ##* gwdc.f/gwdc_pre Note: The conditional above is not in the scheme, so -! the execution of the code below is controlled by its presence in the CCPP SDF -! --- ... calculate maximum convective heating rate - if (Model%do_cnvgwd) then ! call convective gravity wave drag - - allocate(gwdcu(im,levs), gwdcv(im,levs)) -! --- ... calculate maximum convective heating rate -! cuhr = temperature change due to deep convection - - do i=1,im - cumabs(i) = zero - work4 (i) = zero - enddo - 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) - work4(i) = work4(i) + del(i,k) - endif - enddo - enddo - do i=1,im - if (work4(i) > zero) cumabs(i) = cumabs(i) / (dtp*work4(i)) - enddo -!*## CCPP ## - -! DH* 20180817 - note: the above non-CCPP code modifies work3, which until then was defined -! as the ratio of the exner function between midlayer and interface at lowest model layer: -! work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) -! This does not happen for the CCPP code, because gwdc_pre uses an internal array -! work3 (maybe not a good name, given that we have work1/2/3 in GFS_physics_driver and -! in the GFS_Interstitial DDT). Therefore, work3 is different from here on until the end -! of GFS_physics_driver. This is ok as long as Model%lgocart is set to .false. - if -! Model%lgocart is set to .true., sfc_diag is called again, which uses work3 as input. -! This work3 used in sfc_diag should be the ratio of the exner function, not the modified -! value derived in the non-CCPP code above. If we get different results for the surface -! diagnstics with Model%lgocart=.true., then the CCPP code is correct! *DH 20180817 - -! 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)*rad2dg,xlat(ipr)*rad2dg -! 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 ******************************************** - -!## CCPP ##* gwdc.f/gwdc_run Note: The conditional above is not in the scheme, so -! the execution of the code below is controlled by its presence in the CCPP SDF - -!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(1,1,1), 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 -!## CCPP ## gwdc.f/gwdc_post_run - if (Model%lssav) then - do i=1,im - Diag%dugwd(i) = Diag%dugwd(i) + dusfcg(i)*dtf - Diag%dvgwd(i) = Diag%dvgwd(i) + dvsfcg(i)*dtf - enddo - - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%du3dt(i,k,4) = Diag%du3dt(i,k,4) + gwdcu(i,k) * dtf - Diag%dv3dt(i,k,4) = Diag%dv3dt(i,k,4) + gwdcv(i,k) * dtf - enddo - enddo - endif - endif ! end if_lssav - -! --- ... update the wind components with gwdc tendencies - - do k=1,levs - do i=1,im - eng0 = half*(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 = half*(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 -!*## CCPP ## - -! 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 - - deallocate(gwdcu, gwdcv) - endif ! end if_cnvgwd (convective gravity wave drag) - -! if (lprnt) then -! write(0,*) ' befgwegt0=',Stateout%gt0(ipr,:) -! write(0,*) ' befgwegq0=',Stateout%gq0(ipr,:,1) -! endif - -! 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 -------- - -!## CCPP ## GFS_SCNV_generic.F90/GFS_SCNV_generic_pre_run - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - dtdt(i,k) = Stateout%gt0(i,k) - enddo - enddo - endif -!*## CCPP ## - - if (.not. Model%do_shoc) then - - if (Model%shal_cnv) then ! Shallow convection parameterizations -! -------------------------------------- - if (Model%imfshalcnv == 1) then ! opr option now at 2014 - !----------------------- -!## CCPP ##* shalcnv.F/shalcnv_run - 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, ncld, & - Tbd%hpbl, hflxq, evapq, ud_mf, dt_mf, cnvw, cnvc, & - Model%clam_shal, Model%c0s_shal, Model%c1_shal, & - Model%pgcon_shal) -!*## CCPP ## - -!## CCPP ##* GFS_SCNV_generic.F90/GFS_SCNV_generic_post_run - do i=1,im - Diag%rainc(i) = Diag%rainc(i) + frain * rain1(i) - enddo -! in shalcnv, 'cnvw' and 'cnvc' are not set to zero - if (Model%shcnvcw .and. Model%num_p3d == 4 .and. Model%npdf3d == 3) then - do k=1,levs - do i=1,im - Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) - Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) - 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) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) - enddo - enddo - endif -!*## CCPP ## - - elseif (Model%imfshalcnv == 2) then -!## CCPP ##* GFS_typedef.F90/interstitial_setup_tracers - if(.not. Model%satmedmf .and. .not. Model%trans_trac) then - nsamftrac = 0 - else - nsamftrac = tottracer - endif -! if (lprnt) then -! write(0,*) ' befshgt0=',Stateout%gt0(ipr,:) -! write(0,*) ' befshgq0=',Stateout%gq0(ipr,:,1) -! endif -!*## CCPP ## -!## CCPP ##* samfshalcnv.f/samfshalcnv_run - call samfshalcnv (im, ix, levs, dtp, itc, Model%ntchm, ntk, nsamftrac, & - del, Statein%prsl, Statein%pgr, Statein%phil, clw, & - Stateout%gq0(:,:,1), Stateout%gt0, & - Stateout%gu0, Stateout%gv0, Model%fscav, & - rain1, kbot, ktop, kcnv, islmsk, garea, & - Statein%vvl, ncld, Tbd%hpbl, ud_mf, & - dt_mf, cnvw, cnvc, & - Model%clam_shal, Model%c0s_shal, Model%c1_shal, & - Model%pgcon_shal, Model%asolfac_shal) -!*## CCPP ## -!## CCPP ##* GFS_SCNV_generic.F90/GFS_SCNV_generic_post_run - do i=1,im - Diag%rainc(i) = Diag%rainc(i) + frain * rain1(i) - enddo - -! 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 - do k=1,levs - do i=1,im - Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) - Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) - 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) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) - enddo - enddo - endif -!*## CCPP ## - - !elseif (Model%imfshalcnv == 3) then - !if (Model%me==0) write(0,*) "CCPP DEBUG: shallow convection of GF is called in gf_driver" - - !elseif (Model%imfshalcnv == 4) then - !if (Model%me==0) write(0,*) "CCPP DEBUG: shallow convection of New Tiedtke is called in cu_tiedtke" - - elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton - !----------------------------------- -!## CCPP ## This block is not in the CCPP yet. - levshc(:) = 0 - do k=2,levs - do i=1,im - dpshc = 0.3_kind_phys * 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 - -!*## CCPP ## - endif ! end if_shal_cnv - -!## CCPP ## GFS_SCNV_generic.F90/GFS_SCNV_generic_post_run - if (Model%lssav) then - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,5) = Diag%dt3dt(i,k,5) + (Stateout%gt0(i,k) -dtdt(i,k)) * frain -! Diag%dq3dt(i,k,3) = Diag%dq3dt(i,k,3) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - enddo - enddo - endif - endif ! end if_lssav - - if (Model%cplchm) 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 -! - do k=1,levs - do i=1,im - if (clw(i,k,2) <= -999.0_kind_phys) clw(i,k,2) = zero - enddo - enddo -!*## CCPP ## -! 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 - -!## CCPP ##* gcm_shoc.F90/shoc_run - elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc - if (imp_physics == Model%imp_physics_mg) then - do k=1,levs - do i=1,im - ncpl(i,k) = Stateout%gq0(i,k,ntlnc) - ncpi(i,k) = Stateout%gq0(i,k,ntinc) - enddo - enddo - -! 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(one, (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 - if (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - enddo - enddo - elseif (Model%fprcp > 1) then - do k=1,levs - do i=1,im - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) + Stateout%gq0(i,k,ntgl) - enddo - enddo - endif - endif - -! dtshoc = 60.0 -! dtshoc = min(dtp, 300.0) -! nshocm = max(1, nint(dtp/dtshoc)) -! 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), qsnw, qrn, 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), & - call shoc (ix, im, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), del, & - 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), qsnw, qrn, & - rhc, Model%sup, Model%shoc_parm(1), Model%shoc_parm(2), & - Model%shoc_parm(3), Model%shoc_parm(4), & - Model%shoc_parm(5), Tbd%phy_f3d(1,1,ntot3d-2), & - clw(1,1,ntk), hflxq, evapq, prnum, & - Tbd%phy_f3d(1,1,ntot3d-1), Tbd%phy_f3d(1,1,ntot3d), & - lprnt, ipr, imp_physics, ncpl, ncpi) -! enddo - - if (imp_physics == Model%imp_physics_mg) then - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntlnc) = ncpl(i,k) - Stateout%gq0(i,k,ntinc) = ncpi(i,k) - enddo - enddo - 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 -! -!*## CCPP ## - 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 -! -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_4_run -!------------------------------------------------------------------------------ -! --- update the tracers due to deep & shallow cumulus convective transport -! (except for suspended water and ice) -! - if (tottracer > 0) then - tracers = 2 - do n=2,ntrac -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & -! n /= ntlnc .and. n /= ntinc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then - tracers = tracers + 1 - do k=1,levs - do i=1,im - Stateout%gq0(i,k,n) = clw(i,k,tracers) - enddo - enddo - endif - enddo - endif -!------------------------------------------------------------------------------- -! - if (ntcw > 0) then - -! for microphysics - - if (imp_physics == Model%imp_physics_zhao_carr .or. & - imp_physics == Model%imp_physics_zhao_carr_pdf .or. & - imp_physics == Model%imp_physics_gfdl) then - Stateout%gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) - elseif (ntiw > 0) then - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntiw) = clw(i,k,1) ! ice - Stateout%gq0(i,k,ntcw) = clw(i,k,2) ! water - enddo - enddo - if (imp_physics == Model%imp_physics_thompson) then - if (Model%ltaerosol) then - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntlnc) = Stateout%gq0(i,k,ntlnc) & - + max(zero, (clw(i,k,2)-liq0(i,k))) / liqm - Stateout%gq0(i,k,ntinc) = Stateout%gq0(i,k,ntinc) & - + max(zero, (clw(i,k,1)-ice00(i,k))) / icem - enddo - enddo - else - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntinc) = Stateout%gq0(i,k,ntinc) & - + max(zero, (clw(i,k,1)-ice00(i,k))) / icem - enddo - enddo - endif - endif - else - do k=1,levs - do i=1,im - Stateout%gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntiw - else - do k=1,levs - do i=1,im - clw(i,k,1) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntcw -!*## CCPP ## - -! if (lprnt) then -! write(0,*)' aft shallow physics kdt=',kdt -! write(0,*)'qt0s=',Stateout%gt0(ipr,:) -! write(0,*)'qq0s=',Stateout%gq0(ipr,:,1) -! write(0,*)'qq0ws=',Stateout%gq0(ipr,:,ntcw) -! write(0,*)'qq0is=',Stateout%gq0(ipr,:,ntiw) -! write(0,*)'qq0ntic=',Stateout%gq0(ipr,:,ntinc) -! write(0,*)'qq0os=',Stateout%gq0(ipr,:,ntoz) -! endif - -! Legacy routine which determines convectve clouds - should be removed at some point -!## CCPP ## cnvc90.f/cnvc90_run - 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) -!*## CCPP ## - -!## CCPP ##* This is not in the CCPP yet. - 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,ntcw), rhc, lprnt, ipr) - -! if (lprnt) then -! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) -! print *,' gt0a=',gt0(ipr,:) -! print *,' gq0a=',gq0(ipr,:,1) -! endif - do i=1,im - Diag%rainc(i) = Diag%rainc(i) + frain * rain1(i) - enddo - -! if(Model%lssav) then -! update dqdt_v to include moisture tendency due to surface processes -! dqdt_v : instaneous moisture tendency (kg/kg/sec) -! if (Model%ldiag3d) then -! do k=1,levs -! do i=1,im -! Diag%dt3dt(i,k,8) = Diag%dt3dt(i,k,8) + (Stateout%gt0(i,k) -dtdt(i,k) ) * frain -!! Diag%dq3dt(i,k,2) = Diag%dq3dt(i,k,2) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain -! enddo -! enddo -! endif -! endif - endif ! moist convective adjustment over -!*## CCPP ## -!## CCPP ## GFS_MP_generic.F90/GFS_MP_generic_pre_run - if (Model%ldiag3d .or. Model%do_aw) then - do k=1,levs - do i=1,im - dtdt(i,k) = Stateout%gt0(i,k) - dqdt(i,k,1) = Stateout%gq0(i,k,1) - enddo - enddo - do n=ntcw,ntcw+nncl-1 - dqdt(1:im,:,n) = Stateout%gq0(1:im,:,n) - enddo - endif -!*## CCPP ## -! dqdt_v : instaneous moisture tendency (kg/kg/sec) -!## CCPP ##* GFS_suite_interstitial.F90/GFS_suite_interstitial_4_run -! Note: ( these lines are relevant for shallow and deep convection) - if (Model%cplchm) then - do k=1,levs - do i=1,im - Coupling%dqdti(i,k) = Coupling%dqdti(i,k) * (one / dtf) - enddo - enddo - endif -!*## CCPP ## -! -! grid-scale condensation/precipitations and microphysics parameterization -! ------------------------------------------------------------------------ -!## CCPP ##* This is not in the CCPP yet. - - if (ncld == 0) then ! no cloud microphysics - - call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & - Statein%prsl, del, Statein%prslk, rain1, clw) -!*## CCPP ## - else ! all microphysics - - if (imp_physics == Model%imp_physics_zhao_carr) then ! call zhao/carr/sundqvist microphysics - ! ------------ - - allocate(rainp(im,levs)) -! 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 - ! ------------------ -!## CCPP ##* This is not in the CCPP yet. - if (Model%do_shoc) then - call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, & - psautco_l, prautco_l, Model%evpco, Model%wminco, & - Tbd%phy_f3d(1,1,ntot3d-2), lprnt, ipr) -!*## CCPP ## - else -!## CCPP ##* gscond.f/zhaocarr_gscond_run - call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,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) -!*## CCPP ## -!## CCPP ##* precpd.f/zhaocarr_precpd_run - call precpd (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) -!*## CCPP ## - 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 - - deallocate(rainp) - elseif (imp_physics == Model%imp_physics_zhao_carr_pdf) then ! with pdf clouds -!## CCPP ##* These schemes are not in the CCPP yet. - allocate(rainp(im,levs)) - call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & - Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,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,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) - deallocate(rainp) -!*## CCPP ## - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat - - elseif (imp_physics == Model%imp_physics_thompson) then ! Thompson MP - ! ------------ -!## CCPP ##* mp_thompson.F90/mp_thompson_run - ims = 1 ; ime = ix ; kms = 1 ; kme = levs ; its = 1 ; ite = ix ; kts = 1 ; kte = levs - - if (Model%ltaerosol) then - print*,'aerosol version of the Thompson scheme is not included' - -! call mp_gt_driver(ims,ime,kms,kme,its,ite,kts,kte, & -! Stateout%gq0(1:im,1:levs,1), & -! Stateout%gq0(1:im,1:levs,Model%ntcw), Stateout%gq0(1:im,1:levs,Model%ntrw), & -! Stateout%gq0(1:im,1:levs,Model%ntiw), Stateout%gq0(1:im,1:levs,Model%ntsw), & -! Stateout%gq0(1:im,1:levs,Model%ntgl), Stateout%gq0(1:im,1:levs,Model%ntinc),& -! Stateout%gq0(1:im,1:im,Model%ntrnc), & -! Stateout%gt0, Statein%prsl, Statein%vvl, del, dtp, kdt, & -! rain1, & -! Diag%sr, & -!! Diag%refl_10cm, Model%lradar, & -!! Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3), & !has_reqc, has_reqi, has_reqs, -!! ims,ime,kms,kme,its,ite,kts,kte) -! Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3),me, & -! nc=Stateout%gq0(1:im,1:levs,Model%ntlnc), & -! nwfa=Stateout%gq0(1:im,1:levs,Model%ntwa), & -! nifa=Stateout%gq0(1:im,1:levs,Model%ntia), & -!! nwfa2d=Sfcprop%nwfa2d(1:im)) -! nwfa2d=Coupling%nwfa2d(1:im)) - else - call mp_gt_driver(ims,ime,kms,kme,its,ite,kts,kte, & - Stateout%gq0(1:im,1:levs,1), & - Stateout%gq0(1:im,1:levs,Model%ntcw), Stateout%gq0(1:im,1:levs,Model%ntrw), & - Stateout%gq0(1:im,1:levs,Model%ntiw), Stateout%gq0(1:im,1:levs,Model%ntsw), & - Stateout%gq0(1:im,1:levs,Model%ntgl), Stateout%gq0(1:im,1:levs,Model%ntinc),& - Stateout%gq0(1:im,1:levs,Model%ntrnc), & -!2014v Stateout%gt0, Statein%prsl, Statein%vvl, del, dtp, kdt, & - Stateout%gt0, Statein%prsl, del, dtp, kdt, & - rain1, & - Diag%sr, & - islmsk, & - Diag%refl_10cm, Model%lradar, & - Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3),me,Statein%phii) - endif -!*## CCPP ## - elseif (imp_physics == Model%imp_physics_wsm6) then ! WSM6 -!## CCPP ##* This is not in the CCPP yet. ! ----- - ims = 1 ; ime = ix ; kms = 1 ; kme = levs ; its = 1 ; ite = ix ; kts = 1 ; kte = levs - - call wsm6(Stateout%gt0, Statein%phii(1:im,1:levs+1), & - Stateout%gq0(1:im,1:levs,1), & - Stateout%gq0(1:im,1:levs,Model%ntcw), & - Stateout%gq0(1:im,1:levs,Model%ntrw), & - Stateout%gq0(1:im,1:levs,Model%ntiw), & - Stateout%gq0(1:im,1:levs,Model%ntsw), & - Stateout%gq0(1:im,1:levs,Model%ntgl), & - Statein%prsl, del, dtp, rain1, & - Diag%sr, & - islmsk, & - Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3), & - ims,ime, kms,kme, & - its,ite, kts,kte) -! -!*## CCPP ## - elseif (imp_physics == Model%imp_physics_mg) then ! MGB double-moment microphysics - ! ------------------------------ -!## CCPP ##* GFS_typedefs.F90/control_initialize - kk = 5 - if (Model%fprcp >= 2) kk = 6 -!*## CCPP ## -! 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 -!## CCPP ##* m_micro_insterstitial.F90/m_micro_pre_run - if (Model%do_shoc) then - skip_macro = Model%do_shoc - if (Model%fprcp == 0) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc - enddo - enddo - elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc - enddo - enddo - else - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - qgl(i,k) = Stateout%gq0(i,k,ntgl) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - ncgl(i,k) = Stateout%gq0(i,k,ntgnc) - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc - enddo - enddo - - endif - - else - ! clouds from t-dt and cnvc - if (Model%fprcp == 0 ) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - enddo - enddo - elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - enddo - enddo - else - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - qgl(i,k) = Stateout%gq0(i,k,ntgl) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - ncgl(i,k) = Stateout%gq0(i,k,ntgnc) - enddo - enddo - endif - endif -! add convective cloud fraction - do k = 1,levs - do i = 1,im - Tbd%phy_f3d(i,k,1) = min(one, Tbd%phy_f3d(i,k,1) + clcn(i,k)) - enddo - enddo -!*## CCPP ## - -! 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,*) ' befgt0=',Stateout%gt0(ipr,:),' kdt=',kdt -! if(lprnt) write(0,*) ' befgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt -! if(lprnt) write(0,*) ' befntlnc=',Stateout%gq0(ipr,:,ntlnc),' kdt=',kdt -! if(lprnt) write(0,*) ' befntinc=',Stateout%gq0(ipr,:,ntinc),' 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,*)' qrnb=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwb=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglb=',qgl(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' rhc=',rhc(ipr,:),' kdt=',kdt,' kk=',kk -! if (lprnt) write(0,*)' cloudsb=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' cloudsb=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clcn=',clcn(ipr,:)*100,' kdt=',kdt -! txa(:,:) = Stateout%gq0(:,:,1) -! do k=1,levs -! write(1000+me,*)' maxwatncb=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt',kdt -! enddo - -!## CCPP ##* m_micro.F90/m_micro_run - call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & - Statein%prsi, Statein%phil, Statein%phii, & - Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & - Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & - FRLAND, Tbd%Hpbl, CNV_MFD, CNV_DQLDT, & -! FRLAND, Tbd%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,ntcw), & - Stateout%gq0(1,1,ntiw), Stateout%gt0, rain1, & - Diag%sr, Stateout%gq0(1,1,ntlnc), & - Stateout%gq0(1,1,ntinc), Model%fprcp, qrn, & - qsnw, qgl, ncpr, ncps, ncgl, & - Tbd%phy_f3d(1,1,1), kbot, & - Tbd%phy_f3d(1,1,2), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f3d(1,1,5), & - Tbd%phy_f3d(1,1,kk), Tbd%aer_nm, & - Tbd%in_nm, Tbd%ccn_nm, Model%iccn, & - skip_macro, lprnt, & -! skip_macro, cn_prc, cn_snr, lprnt, & -! ipr, kdt, Grid%xlat, Grid%xlon) - Model%mg_alf, Model%mg_qcmin, Model%pdfflag, & - ipr, kdt, Grid%xlat, Grid%xlon, rhc) -!*## CCPP ## -! do k=1,levs -! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt -! enddo -! write(1000+me,*)' at kdt = ',kdt -! tem = 1000.0 - -! call moist_bud2(im,ix,ix,levs,me,kdt,con_g,tem,del,rain1 & -! &, txa, clw(1,1,2), clw(1,1,1) & -! &, Stateout%gq0(1:ix,1:levs,ntrw),Stateout%gq0(1:ix,1:levs,ntsw)& -! &, Stateout%gq0(1:ix,1:levs,ntgl) & -! &, Stateout%gq0(1:ix,1:levs,1),Stateout%gq0(1:ix,1:levs,ntcw) & -! &, Stateout%gq0(1:ix,1:levs,ntiw) & -! &, qrn, qsnw, qgl, ' m_micro ', grid%xlon(1:im), grid%xlat(1:im)) - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & -! &' rainc=',diag%rainc(ipr)*86400.0 -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr),' kdt=',kdt -! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' cli1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt -! if (ntgl > 0 .and. lprnt) & -! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt - -!## CCPP ##* m_micro_interstitial.F90/m_micro_post_run - - tem = dtp * con_p001 / con_day - if (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero - Stateout%gq0(i,k,ntrw) = qrn(i,k) - Stateout%gq0(i,k,ntsw) = qsnw(i,k) - Stateout%gq0(i,k,ntrnc) = ncpr(i,k) - Stateout%gq0(i,k,ntsnc) = ncps(i,k) - enddo - enddo - do i=1,im - Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) - Diag%snow(i) = tem * qsnw(i,1) - enddo - elseif (Model%fprcp > 1) then - do k=1,levs - do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero - if (abs(qgl(i,k)) < qsmall) qgl(i,k) = zero - Stateout%gq0(i,k,ntrw) = qrn(i,k) - Stateout%gq0(i,k,ntsw) = qsnw(i,k) - Stateout%gq0(i,k,ntgl) = qgl(i,k) - Stateout%gq0(i,k,ntrnc) = ncpr(i,k) - Stateout%gq0(i,k,ntsnc) = ncps(i,k) - Stateout%gq0(i,k,ntgnc) = ncgl(i,k) - enddo - enddo - do i=1,im - Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) - Diag%snow(i) = tem * qsnw(i,1) - Diag%graupel(i) = tem * qgl(i,1) - enddo - - endif -!*## CCPP ## - -! if (lprnt) write(0,*)' cloudsm=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt -! if (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt -! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt -! - - elseif (imp_physics == Model%imp_physics_gfdl) then ! GFDL MP - ! ------- - do i = 1, im -!## CCPP ##* Not necessary in the CCPP. - land (i,1) = frland(i) - area (i,1) = Grid%area(i) -!*## CCPP ## -!## CCPP ##* gfdl_cloud_microphys.F90/gfdl_cloud_microphys_run - rain0 (i,1) = zero - snow0 (i,1) = zero - ice0 (i,1) = zero - graupel0 (i,1) = zero - enddo - - do k = 1, levs - kk = levs-k+1 - do i = 1, im - qn1 (i,1,k) = zero - qv_dt(i,1,k) = zero - ql_dt(i,1,k) = zero - qr_dt(i,1,k) = zero - qi_dt(i,1,k) = zero - qs_dt(i,1,k) = zero - qg_dt(i,1,k) = zero - qa_dt(i,1,k) = zero - pt_dt(i,1,k) = zero - udt (i,1,k) = zero - vdt (i,1,k) = zero -! - qv1 (i,1,k) = Stateout%gq0(i,kk,1) - ql1 (i,1,k) = Stateout%gq0(i,kk,ntcw) - qr1 (i,1,k) = Stateout%gq0(i,kk,ntrw) - qi1 (i,1,k) = Stateout%gq0(i,kk,ntiw) - qs1 (i,1,k) = Stateout%gq0(i,kk,ntsw) - qg1 (i,1,k) = Stateout%gq0(i,kk,ntgl) - qa1 (i,1,k) = Stateout%gq0(i,kk,ntclamt) - pt (i,1,k) = Stateout%gt0(i,kk) - w (i,1,k) = -Statein%vvl(i,kk)*(one+con_fvirt*qv1(i,1,k)) & - * Stateout%gt0(i,kk) / Statein%prsl(i,kk) * (con_rd*onebg) - uin (i,1,k) = Stateout%gu0(i,kk) - vin (i,1,k) = Stateout%gv0(i,kk) - delp (i,1,k) = del(i,kk) - dz (i,1,k) = (Statein%phii(i,kk)-Statein%phii(i,kk+1)) * onebg - p123 (i,1,k) = Statein%prsl(i,kk) - refl (i,1,k) = Diag%refl_10cm(i,kk) - enddo - enddo - - - 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,p123,Model%lradar,refl, & - reset) - tem = dtp * con_p001 / con_day - do i = 1, im -! rain0(i,1) = max(zero, rain0(i,1)) -! snow0(i,1) = max(zero, snow0(i,1)) -! ice0(i,1) = max(zero, ice0(i,1)) -! graupel0(i,1) = max(zero, graupel0(i,1)) - if (rain0(i,1)*tem < rainmin) then - rain0(i,1) = zero - endif - if (ice0(i,1)*tem < rainmin) then - ice0(i,1) = zero - endif - if (snow0(i,1)*tem < rainmin) then - snow0(i,1) = zero - endif - if (graupel0(i,1)*tem < rainmin) then - graupel0(i,1) = zero - endif - - rain1(i) = (rain0(i,1)+snow0(i,1)+ice0(i,1)+graupel0(i,1)) * tem - Diag%ice(i) = ice0 (i,1) * tem - Diag%snow(i) = snow0 (i,1) * tem - Diag%graupel(i) = graupel0(i,1) * tem - if ( rain1(i) > rainmin ) then - Diag%sr(i) = (snow0(i,1) + ice0(i,1) + graupel0(i,1)) & - / (rain0(i,1) + snow0(i,1) + ice0(i,1) + graupel0(i,1)) - else - Diag%sr(i) = zero - endif - enddo -#ifdef REPRO - ! Convert rain0, ice0, graupel0 and snow0 from mm/day to m/physics-timestep - ! for later use (approx. lines 7970, calculation of srflag) - rain0 = tem*rain0 - ice0 = tem*ice0 - snow0 = tem*snow0 - graupel0 = tem*graupel0 -#endif - do k = 1, levs - kk = levs-k+1 - do i=1,im - Stateout%gq0(i,k,1 ) = qv1(i,1,kk) + qv_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntcw) = ql1(i,1,kk) + ql_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntrw) = qr1(i,1,kk) + qr_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntiw) = qi1(i,1,kk) + qi_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntsw) = qs1(i,1,kk) + qs_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntgl) = qg1(i,1,kk) + qg_dt(i,1,kk) * dtp - Stateout%gq0(i,k,ntclamt) = qa1(i,1,kk) + qa_dt(i,1,kk) * dtp - Stateout%gt0(i,k) = Stateout%gt0(i,k) + pt_dt(i,1,kk) * dtp - Stateout%gu0(i,k) = Stateout%gu0(i,k) + udt (i,1,kk) * dtp - Stateout%gv0(i,k) = Stateout%gv0(i,k) + vdt (i,1,kk) * dtp - Diag%refl_10cm(i,k) = refl(i,1,kk) - enddo - - - if (Model%effr_in) then - do i =1, im - den(i,k) = 0.622_kind_phys*Statein%prsl(i,k) / & - (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622_kind_phys)) - enddo - endif - enddo -!*## CCPP ## -!## CCPP ##* maximum_hourly_diagnostics.F90/maximum_hourly_diagnsostics_run -!Calculate hourly max 1-km agl and -10C reflectivity - if (Model%lradar .and. & - (imp_physics == Model%imp_physics_gfdl .or. & - imp_physics == Model%imp_physics_thompson)) then - allocate(refd(im)) - allocate(refd263k(im)) - call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) - if (reset) then - do i=1,im - Diag%refdmax(I) = -35.0_kind_phys - Diag%refdmax263k(I) = -35.0_kind_phys - enddo - endif - do i=1,im - Diag%refdmax(i) = max(Diag%refdmax(i),refd(i)) - Diag%refdmax263k(i) = max(Diag%refdmax263k(i),refd263k(i)) - enddo - deallocate (refd) - deallocate (refd263k) - endif -!*## CCPP ## -!## CCPP ##* gfdl_cloud_microphys.F90/gfdl_cloud_microphys_run - if(Model%effr_in) then - call cloud_diagnosis (1, im, 1, levs, den(1:im,1:levs), & - del(1:im,1:levs), islmsk(1:im), & - Stateout%gq0(1:im,1:levs,ntcw), Stateout%gq0(1:im,1:levs,ntiw), & - Stateout%gq0(1:im,1:levs,ntrw), & - Stateout%gq0(1:im,1:levs,ntsw)+Stateout%gq0(1:im,1:levs,ntgl), & - Stateout%gq0(1:im,1:levs,ntgl)*0.0, Stateout%gt0(1:im,1:levs), & - Tbd%phy_f3d(1:im,1:levs,1), Tbd%phy_f3d(1:im,1:levs,2), & - Tbd%phy_f3d(1:im,1:levs,3), Tbd%phy_f3d(1:im,1:levs,4), & - Tbd%phy_f3d(1:im,1:levs,5)) - -!*## CCPP ## -! do k = 1, levs -! do i=1,im -! if(Model%me==0) then -! if(Tbd%phy_f3d(i,k,1) > 5.) then -! write(6,*) 'phy driver:cloud radii:',Model%kdt, i,k, & -! Tbd%phy_f3d(i,k,1) -! endif -! if(Tbd%phy_f3d(i,k,3)> zero) then -! write(6,*) 'phy driver:rain radii:',Model%kdt, i,k, & -! Tbd%phy_f3d(i,k,3) -! endif -! -! endif -! enddo -! enddo - - endif - - endif ! end of if(Model%imp_physics) - endif ! end if_ncld - -! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) -! - if (Model%cscnv .and. 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 = zero ! 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 -!## CCPP ##* cs_conv_aw_adj.F90/cs_conv_aw_adj_run Note: The conditional above -! is not checked in the scheme, so the control of the code below is through its -! inclusion in a CCPP SDF - - temrain1(:) = zero - 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 -! add convective clouds if shoc is true and not MG microphysics - if (Model%do_shoc .and. imp_physics /= Model%imp_physics_mg) then - do k = 1,levs - do i = 1,im - Tbd%phy_f3d(i,k,ntot3d-2) = min(one, Tbd%phy_f3d(i,k,ntot3d-2) & - & + sigmafrac(i,k)) - enddo - enddo - endif - -! if (lprnt) write(0,*)' gt0aftpraw=',Stateout%gt0(ipr,:),' kdt=',kdt,'me=',me - do n=ntcw,ntcw+nncl-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 - do i = 1,im - rain1(i) = max(rain1(i) - temrain1(i)*con_p001, zero) - enddo - endif - -!*## CCPP ## -!## CCPP ##* GFS_MP_generic.F90/GFS_MP_generic_post_run - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) ! total rain per timestep - -! --- get the amount of different precip type for Noah MP -! --- convert from m/dtp to mm/s - if (Model%lsm==Model%lsm_noahmp) then - if (Model%imp_physics == Model%imp_physics_mg .or. & - Model%imp_physics == Model%imp_physics_gfdl) 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 = one / (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(:) = zero - Sfcprop%drainncprv(:) = zero - Sfcprop%dsnowprv(:) = zero - Sfcprop%dgraupelprv(:) = zero - Sfcprop%diceprv(:) = zero - endif - end if ! if (Model%lsm == Model%lsm_noahmp) - - if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm -! - 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, Sfcprop%tsfc, & !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)*rad2dg-114.0) .lt. 0.2 .and. -! & abs(xlat(i)*rad2dg- 40.0) .lt. 0.2) -! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', -! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) -! enddo -! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - - if (Model%imp_physics /= Model%imp_physics_gfdl) then - do i=1,im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) - if(doms(i) > zero .or. domip(i) > zero) then - Sfcprop%srflag(i) = one - else - Sfcprop%srflag(i) = zero - endif - enddo - endif - if (Model%lssav) then - do i=1,im - Diag%tdomr(i) = Diag%tdomr(i) + domr(i) * dtf - Diag%tdomzr(i) = Diag%tdomzr(i) + domzr(i) * dtf - Diag%tdomip(i) = Diag%tdomip(i) + domip(i) * dtf - Diag%tdoms(i) = Diag%tdoms(i) + doms(i) * dtf - enddo - endif - - endif - -!*## CCPP ## -!## CCPP ##* this block not yet in CCPP -!-------------------------------- -! vay-2018 for Dycore-Tendencies save Stateout%X => Diag%dX3dt_cgw -! - if (ldiag_ugwp) then - Diag%dt3dt_cgw = Stateout%gt0 - Diag%dv3dt_cgw = Stateout%gv0 - Diag%du3dt_cgw = Stateout%gu0 - endif -!-------------------------------- -!*## CCPP ## -!## CCPP ##* GFS_MP_generic.F90/GFS_MP_generic_post_run - -! --- ... estimate t850 for rain-snow decision - - t850(1:im) = Stateout%gt0(1:im,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 - - if (Model%imp_physics == Model%imp_physics_gfdl) then ! GFDL microphysics - ! ----------------- -! determine convective rain/snow by surface temperature -! determine large-scale rain/snow by rain/snow coming out directly from MP - tem = dtp * con_p001 / con_day - do i = 1, im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) )! clu: rain -> tprcp - Sfcprop%srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (Sfcprop%tsfc(i) >= 273.15_kind_phys) then - crain = Diag%rainc(i) - csnow = zero - else - crain = zero - csnow = Diag%rainc(i) - endif -! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then -! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > zero) then -! Sfcprop%srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) -! endif -! compute fractional srflag -#ifdef REPRO - ! For bit-for-bit identical results with CCPP code, snow0/ice0/graupel0/rain0 - ! were converted from mm per day to m per physics timestep previously in the code - total_precip = snow0(i,1)+ice0(i,1)+graupel0(i,1)+rain0(i,1)+Diag%rainc(i) - if (total_precip > rainmin) then - Sfcprop%srflag(i) = (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow)/total_precip - endif -#else - tem1 = snow0(i,1)+ice0(i,1)+graupel0(i,1) - total_precip = (tem1+rain0(i,1)) * tem + Diag%rainc(i) - if (total_precip > rainmin) then - Sfcprop%srflag(i) = (tem1*tem+csnow) / total_precip - endif -#endif - enddo - elseif( .not. Model%cal_pre) then - if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics - ! --------------- - do i=1,im - if (Diag%rain(i) > rainmin) then - tem1 = max(zero, (Diag%rain(i)-Diag%rainc(i))) * Diag%sr(i) - tem2 = one / Diag%rain(i) - if (t850(i) > 273.16_kind_phys) then - Sfcprop%srflag(i) = max(zero, min(one, tem1*tem2)) - else - Sfcprop%srflag(i) = max(zero, min(one, (tem1+Diag%rainc(i))*tem2)) - endif - else - Sfcprop%srflag(i) = zero - Diag%rain(i) = zero - Diag%rainc(i) = zero - endif - Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) - enddo - else ! not GFDL or MG microphysics - ! --------------------------- - do i = 1, im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) - Sfcprop%srflag(i) = Diag%sr(i) - enddo - endif - endif - - if (Model%lssav) then -! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & -! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & -! 'rain=',Diag%rain(1) - do i=1,im - Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) - Diag%totprcp (i) = Diag%totprcp (i) + Diag%rain(i) - Diag%totice (i) = Diag%totice (i) + Diag%ice(i) - Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) - Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) -! - Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + Diag%rainc(i) - Diag%totprcpb(i) = Diag%totprcpb(i) + Diag%rain(i) - Diag%toticeb (i) = Diag%toticeb (i) + Diag%ice(i) - Diag%totsnwb (i) = Diag%totsnwb (i) + Diag%snow(i) - Diag%totgrpb (i) = Diag%totgrpb (i) + Diag%graupel(i) - enddo - - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain -! Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - enddo - enddo - endif - endif - -! --- ... coupling insertion - - if (Model%cplflx .or. Model%cplchm) then - do i = 1, im - Tbd%dsnow_cpl(i)= max(zero, Diag%rain(i) * Sfcprop%srflag(i)) - Tbd%drain_cpl(i)= max(zero, Diag%rain(i) - Tbd%dsnow_cpl(i)) - Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Tbd%drain_cpl(i) - Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Tbd%dsnow_cpl(i) - enddo - endif - - if (Model%cplchm) then - do i = 1, im - Coupling%rainc_cpl(i) = Coupling%rainc_cpl(i) + Diag%rainc(i) - enddo - endif -!*## CCPP ## -! --- ... end coupling insertion - -!## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_post_run -! --- ... 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 - do i=1,im - Diag%runoff(i) = Diag%runoff(i) + (drain(i)+runof(i)) * dtf - Diag%srunoff(i) = Diag%srunoff(i) + runof(i) * dtf - enddo - endif -!*## CCPP ## -!## CCPP ##* This block is not in the CCPP because data transfer between global -! and local variables is not necessary in the CCPP. -! --- ... return updated smsoil and stsoil to global arrays - if (Model%frac_grid) then - do k=1,lsoil - do i=1,im - if (dry(i)) then - Sfcprop%smc(i,k) = smsoil(i,k) - Sfcprop%stc(i,k) = stsoil(i,k) - Sfcprop%slc(i,k) = slsoil(i,k) - endif - enddo - enddo - else - do k=1,lsoil - do i=1,im - Sfcprop%smc(i,k) = smsoil(i,k) - Sfcprop%stc(i,k) = stsoil(i,k) - Sfcprop%slc(i,k) = slsoil(i,k) - enddo - enddo - endif -!*## CCPP ## - -! --- ... calculate column precipitable water "pwat" - Diag%pwat(:) = zero - do k = 1, levs - do i=1,im - work1(i) = zero - enddo - if (ncld > 0) then - do ic = ntcw, ntcw+nncl-1 - do i=1,im - work1(i) = work1(i) + Stateout%gq0(i,k,ic) - enddo - enddo - endif - do i=1,im - Diag%pwat(i) = Diag%pwat(i) + del(i,k)*(Stateout%gq0(i,k,1)+work1(i)) - enddo -! if (lprnt .and. i == ipr) write(0,*)' gq0=', -! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k - enddo - do i=1,im - Diag%pwat(i) = Diag%pwat(i) * onebg - enddo - -! tem = dtf * 0.03456 / 86400.0 -! write(1000+me,*)' pwat=',pwat(i),'i=',i,', -! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*hefac(i)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(i)*hefac(i)*tem-rain(i)*1000.0 -! if (lprnt) write(0,*)' pwat=',pwat(ipr),', -! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*hefac(ipr)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(ipr)*hefac(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=',Stateout%gt0(ipr,:),' kdt=',kdt -! write(0,*) ' endgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat -! write(0,*) ' endzorl=',Sfcprop%zorl(ipr),' kdt=',kdt -! endif - - if (Model%do_sppt .or. Model%ca_global)then -!--- radiation heating rate - Tbd%dtdtr(1:im,:) = Tbd%dtdtr(1:im,:) + dtdtc(1:im,:)*dtf - endif -!*## CCPP ## -!## CCPP ##* This block is not in the CCPP since it is not needed in the CCPP. - deallocate (clw) - if (allocated(cnvc)) deallocate(cnvc) - if (allocated(cnvw)) deallocate(cnvw) - if (allocated(qrn)) deallocate(qrn) - if (allocated(qsnw)) deallocate(qsnw) - if (allocated(qgl)) deallocate(qgl) - if (allocated(ncpl)) deallocate(ncpl) - if (allocated(ncpi)) deallocate(ncpi) - if (allocated(ncpr)) deallocate(ncpr) - if (allocated(ncps)) deallocate(ncps) - if (allocated(ncgl)) deallocate(ncgl) - - if (allocated(liq0)) deallocate(liq0) - if (allocated(ice00)) deallocate(ice00) - - -! deallocate (fscav, fswtr) -! -! 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 (lprnt) then -! write(0,*)' at the end of physics kdt=',kdt -! write(0,*)' end rain=',diag%rain(ipr),' rainc=',diag%rainc(ipr) -! write(0,*)'qt0out=',Stateout%gt0(ipr,:) -! write(0,*)'qq0outv=',Stateout%gq0(ipr,:,1) -! write(0,*)'qq0outw=',Stateout%gq0(ipr,:,ntcw) -! write(0,*)'qq0outi=',Stateout%gq0(ipr,:,ntiw) -! write(0,*)'qq0outo=',Stateout%gq0(ipr,:,ntoz) -! endif -! if (lprnt) write(0,*)'gq0outtke=',Stateout%gq0(ipr,1:25,ntke) & -! ,'xlon=',grid%xlon(ipr)*rad2dg,' xlat=',grid%xlat(ipr)*rad2dg -! if (lprnt) write(0,*)' clouddriverend=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt - -! deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & - deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, & - CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) - if (imp_physics == Model%imp_physics_gfdl) then - deallocate (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,p123,refl) - deallocate (den) - endif -!*## CCPP ## -!## CCPP ##* maximum_hourly_diagnostics.F90/maximum_hourly_diagnostics_run - if (allocated(tke)) deallocate (tke) - if (Model%cscnv) then - deallocate (sigmatot, sigmafrac) - endif -! - if (reset) then - do i=1, im -! find max hourly wind speed then decompose - Diag%spd10max(i) = -999.0_kind_phys - Diag%u10max(i) = -999.0_kind_phys - Diag%v10max(i) = -999.0_kind_phys - Diag%t02max(i) = -999.0_kind_phys - Diag%t02min(i) = 999.0_kind_phys - Diag%rh02max(i) = -999.0_kind_phys - Diag%rh02min(i) = 999.0_kind_phys - enddo - endif - do i=1, im -! find max hourly wind speed then decompose - tem = sqrt(Diag%u10m(i)*Diag%u10m(i) + Diag%v10m(i)*Diag%v10m(i)) - if (tem > Diag%spd10max(i)) then - Diag%spd10max(i) = tem - Diag%u10max(i) = Diag%u10m(i) - Diag%v10max(i) = Diag%v10m(i) - endif - pshltr = Statein%pgr(i)*exp(-0.068283_kind_phys/Stateout%gt0(i,1)) - QCQ = PQ0/pshltr*EXP(A2A*(Sfcprop%t2m(i)-A3)/(Sfcprop%t2m(i)-A4)) - rh02 = Sfcprop%q2m(i) / QCQ - IF (rh02 > one) THEN - rh02 = one - ENDIF - IF (rh02 < RHmin) THEN !use smaller RH limit for stratosphere - rh02 = RHmin - ENDIF - Diag%rh02max(i) = max(Diag%rh02max(i), rh02) - Diag%rh02min(i) = min(Diag%rh02min(i), rh02) - Diag%T02MAX(I) = MAX(Diag%T02MAX(I), Sfcprop%t2m(i)) !<--- Hourly max 2m T - Diag%T02MIN(I) = MIN(Diag%T02MIN(I), Sfcprop%t2m(i)) !<--- Hourly min 2m T - enddo -!*## CCPP ## -! if (kdt > 2 ) stop - -! if (Model%nstf_name(1) > 0) then -! if (lprnt) write(0,*)' end driver sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt -! endif -! if (Model%frac_grid) then -! if (lprnt) write(0,*)' end driver sfcprop%tsfcl=',Sfcprop%tsfcl(ipr),' kdt=',kdt -! if (lprnt) write(0,*)' end driver sfcprop%tsfco=',Sfcprop%tsfco(ipr),' kdt=',kdt -! if (lprnt) write(0,*)' end driver sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt -! endif - - return -!................................... - end subroutine GFS_physics_driver -!----------------------------------- - - - subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) - use machine, only : kind_phys - integer, intent(in) :: im,levs - real (kind=kind_phys), intent(in) :: grav - real (kind=kind_phys), intent(in),dimension(im,levs) :: phil,ref3D,tk - integer :: i,k,ll,ipt,kpt - real :: dbz1avg,zmidp1,zmidloc,refl,fact - real, dimension(im,levs) :: z - real, dimension(im) :: zintsfc - real, dimension(im), intent(inout) :: refd,refd263k - REAL :: dbz1(2),dbzk,dbzk1 - logical counter - do i=1,im - do k=1,levs - z(i,k) = phil(i,k)/grav - enddo - enddo - do i=1,im - refd(I) = -35. - vloop: do k=1,levs-1 - if ( z(i,k+1) >= 1000. .and. z(i,k) <= 1000.) then - zmidp1 = z(i,k+1) - zmidLOC = z(i,k) - dbz1(1) = ref3d(i,k+1) !- dBZ (not Z) values - dbz1(2) = ref3d(i,k) !- dBZ values - exit vloop - endif - enddo vloop - -!!! Initial curefl value without reduction above freezing level -! -! curefl=0. -! if (cprate(i,j)>0.) then -! cuprate=rdtphs*cprate(i,j) -! curefl=cu_a*cuprate**cu_b -! endif - do ll=1,2 - refl=0. - if (dbz1(ll)>-35.) refl=10.**(0.1*dbz1(ll)) -! dbz1(l)=curefl+refl !- in Z units - dbz1(ll)=refl - enddo -!-- Vertical interpolation of Z (units of mm**6/m**3) - fact=(1000.-zmidloc)/(zmidloc-zmidp1) - dbz1avg=dbz1(2)+(dbz1(2)-dbz1(1))*fact -!-- Convert to dBZ (10*logZ) as the last step - if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) - else - dbz1avg=-35. - endif - refd(I)=max(refd(I),dbz1avg) - enddo - -!-- refl at -10C - do i=1,im - dbz1(1) = -35. - dbz1(2) = -35. - vloopm10: do k=1,levs-1 - if (tk(i,k+1) .le. 263.15 .and. tk(i,k) .ge. 263.15) then - dbz1(1)=ref3d(i,k+1) !- dBZ (not Z) values - dbz1(2)=ref3d(i,k) !- dBZ values - exit vloopm10 - endif - enddo vloopm10 - - do ll=1,2 - refl=0. - if (dbz1(ll)>-35.) refl=10.**(0.1*dbz1(ll)) -! dbz1(l)=curefl+refl !- in Z units - dbz1(ll)=refl - enddo -!-- Take max of bounding reflectivity values - dbz1avg=maxval(dbz1) -!-- Convert to dBZ (10*logZ) as the last step - if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) - else - dbz1avg=-35. - endif - refd263K(I)=dbz1avg - enddo - end subroutine max_fields - - subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & - qv0,ql0,qi0,qv1,ql1,qi1,comp, xlon, xlat) -! 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, xlon(im), xlat(im) - 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 -! - do i=1,im - sumqv(i) = 0.0_kind_phys - sumql(i) = 0.0_kind_phys - sumqi(i) = 0.0_kind_phys - sumq (i) = 0.0_kind_phys - enddo - do k=1,levs - do i=1,im - sumqv(i) = sumqv(i) + (qv1(i,k) - qv0(i,k)) * delp(i,k) - sumql(i) = sumql(i) + (ql1(i,k) - ql0(i,k)) * delp(i,k) - sumqi(i) = sumqi(i) + (qi1(i,k) - qi0(i,k)) * delp(i,k) - enddo - enddo - do i=1,im - sumqv(i) = - sumqv(i) * (1.0_kind_phys/grav) - sumql(i) = - sumql(i) * (1.0_kind_phys/grav) - sumqi(i) = - sumqi(i) * (1.0_kind_phys/grav) - sumq (i) = sumqv(i) + sumql(i) + sumqi(i) - enddo - do i=1,im - write(2000+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=',trim(comp), & - ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & - ' qi=',qi1(i,1), qi0(i,1),' xlon=',xlon(i),' xlat=',xlat(i) - enddo - return - - end subroutine moist_bud - - - subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & - qv0,ql0,qi0,qr0,qs0,qg0, & - qv1,ql1,qi1,qr1,qs1,qg1,comp,xlon,xlat) -! aug 2018 - 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, oneog, xlon(im), xlat(im) - real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp, & - qr0,qs0,qg0 - real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1, & - qr1,qs1,qg1 - REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi, & - sumqr, sumqs, sumqg - integer :: i, k -! - do i=1,im - sumqv(i) = 0.0_kind_phys - sumql(i) = 0.0_kind_phys - sumqi(i) = 0.0_kind_phys - sumqr(i) = 0.0_kind_phys - sumqs(i) = 0.0_kind_phys - sumqg(i) = 0.0_kind_phys - sumq (i) = 0.0_kind_phys - enddo - do k=1,levs - do i=1,im - sumqv(i) = sumqv(i) + (qv1(i,k) - qv0(i,k)) * delp(i,k) - sumql(i) = sumql(i) + (ql1(i,k) - ql0(i,k)) * delp(i,k) - sumqi(i) = sumqi(i) + (qi1(i,k) - qi0(i,k)) * delp(i,k) - sumqr(i) = sumqr(i) + (qr1(i,k) - qr0(i,k)) * delp(i,k) - sumqs(i) = sumqs(i) + (qs1(i,k) - qs0(i,k)) * delp(i,k) - sumqg(i) = sumqg(i) + (qg1(i,k) - qg0(i,k)) * delp(i,k) - enddo - enddo - oneog = 1.0_kind_phys / grav - do i=1,im - sumqv(i) = - sumqv(i) * oneog - sumql(i) = - sumql(i) * oneog - sumqi(i) = - sumqi(i) * oneog - sumqr(i) = - sumqr(i) * oneog - sumqs(i) = - sumqs(i) * oneog - sumqg(i) = - sumqg(i) * oneog - sumq (i) = sumqv(i) + sumql(i) + sumqi(i) + sumqr(i) & - + sumqs(i) + sumqg(i) - enddo - do i=1,im - write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & - ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & - ' sumqr=',sumqr(i),' sumqs=',sumqs(i),' sumqg=',sumqg(i), & - ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',trim(comp), & - ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & - ' qi=',qi1(i,1), qi0(i,1),' qr=',qr1(i,1),qr0(i,1), & - ' qs=',qs1(i,1), qs0(i,1),' qg=',qg1(i,1),qg0(i,1), & - ' xlon=',xlon(i),' xlat=',xlat(i) - enddo - return - - end subroutine moist_bud2 - - -!> @} - -end module module_physics_driver - diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 deleted file mode 100644 index da5078f7b..000000000 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ /dev/null @@ -1,2206 +0,0 @@ -!> \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. ! -! Mar 2017 Ruiyu s.- add effect radii and other cloud properties! -! from the advanced MPs ! -! ----2018 S. Moorthi - update to use unified cloud from SHOC ! -! and/or MG2/3 microphysics and fix some bugs ! -! jun 2018 h-m lin/y-t hou - added option of de-correlation ! -! length cloud overlap method (Barker, 2008), removed -! the legacy rh based diagnostic cloud scheme ! -! Feb 2019 Ruiyu Sun - add passing the effective radii from ! -! gfdl mp to radiation ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radiation_driver ! -!........................................! -! - use physparam - use physcons, only: eps => con_eps, & - & epsm1 => con_epsm1, & - & fvirt => con_fvirt & - &, rog => con_rog & - &, rocp => con_rocp, pi => con_pi - 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, progcld4o, & - & progclduni - - 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 - - use surface_perturbation, only: cdfnor -! - 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.0d-10, QME5=1.0d-7, QME6=1.0d-7, EPSQ=1.0d-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.0d-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 -! ================= - -!## CCPP ## This is now a private subroutine in GFS_rrtmg_setup.F90/radinit. -!> 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, imp_physics, me ) -!................................... - -! --- inputs: -! & ( si, NLAY, imp_physics, 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 ! -! imp_physics : MP identifier ! -! 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 (discontinued) ! -! =1: use prognostic cloud scheme (default) ! -! imp_physics : cloud microphysics scheme control flag ! -! =99 zhao/carr/sundqvist microphysics scheme ! -! =98 zhao/carr/sundqvist microphysics+pdf cloud & cnvc,cnvw! -! =11 GFDL cloud microphysics ! -! =8 Thompson microphysics scheme ! -! =6 WSM6 microphysics scheme ! -! =10 MG microphysics scheme ! -! 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, imp_physics - - 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, & - & ' IMP_PHYSICS=',imp_physics,' 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, imp_physics, me) ! --- ... cloud initialization routine - - call rlwinit ( me ) ! --- ... lw radiation initialization routine - - call rswinit ( me ) ! --- ... sw radiation initialization routine -! - return -!................................... - end subroutine radinit -!----------------------------------- -!> @} - -!## CCPP ## This is now a private subroutine in GFS_rrtmg_setup.F90/radupdate. -!> 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) -!................................... - -! ================= 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 ! -! ! -! 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 - - 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 - - call sol_update & -! --- inputs: - & ( jdate,kyear,deltsw,deltim,lsol_chg, me, & -! --- outputs: - & slag,sdec,cdec,solcon & - & ) - - 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 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 (not supported anymore) -!!\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(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 - -! ================= 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') ! -! 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 ! -! ! -! 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 ! -! imp_physics : cloud microphysics scheme control flag ! -! =99 zhao/carr/sundqvist microphysics scheme ! -! =98 zhao/carr/sundqvist microphysics +pdf cloud ! -! =11 GFDL cloud microphysics ! -! =8 Thompson cloud microphysics ! -! =6 WSM6 cloud microphysics ! -! =10 MG cloud microphysics ! -! ! -! 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, levs, nfxr, ntrac - integer :: i, j, k, k1, lv, itop, ibtc, nday, LP1, LMK, LMP, kd, & - lla, llb, lya, lyb, kt, kb, n, ntcw, ntiw, ncld, ntrw, & - ntsw, ntgl, k2, lsk, ncndl - 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, tem1, tem2 - - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - tsfa, tem1d, tsfg, tskn, de_lgth - - 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, prslk1, tem2da, & - dz,delp,cldcov, deltaq, cnvc, cnvw, effrl, effri, effrr, effrs - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp+1) :: plvl, tlvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp+1) :: tem2db -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp+1) :: hz - - 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 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,min(4,Model%ncnd)) :: ccnd - - ! mg, sfc perts - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: alb1d - real(kind=kind_phys) :: lndp_alb - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtausw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtaulw - - real(kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 - - !--- TYPED VARIABLES - type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw - - real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/pi -! logical :: lprnt -! integer :: ipt -! logical effr_in -! data effr_in/.false./ -! -!===> ... begin here -! - -!--- only call GFS_radiation_driver at radiation time step -!## CCPP ##* GFS_rrtmg_pre.F90/GFS_rrtmg_pre_run for code required to run before -! SW and LW. - if (.not. (Model%lsswr .or. Model%lslwr )) return - -!--- set commonly used integers - me = Model%me - LM = Model%levr - LEVS = Model%levs - IM = size(Grid%xlon,1) - NFXR = Model%nfxr - NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) - ntcw = Model%ntcw - ntiw = Model%ntiw - ncld = Model%ncld - ntrw = Model%ntrw - ntsw = Model%ntsw - ntgl = Model%ntgl - ncndl = min(Model%ncnd,4) - - 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 - - -! lprnt = .false. - -! do i=1,im -! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 -! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & -! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 -! if (kdt == 1) & -! write(2000+me,*)' i=',i,' xlon=',grid%xlon(i)*rad2dg, -! & -! ' xlat=',grid%xlat(i)*rad2dg,' me=',me -! if (lprnt) then -! ipt = i -! write(0,*)' ipt=',ipt,'xlon=',grid%xlon(i)*rad2dg,' xlat=',grid%xlat(i)*rad2dg,' me=',me -! exit -! endif -! enddo - -!> -# 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. -! - lsk = 0 - if (ivflip == 0 .and. lm < levs) lsk = levs - lm - -! convert pressure unit from pa to mb - do k = 1, LM - k1 = k + kd - k2 = k + lsk - do i = 1, IM - plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01d0 ! pa to mb (hpa) - plyr(i,k1) = Statein%prsl(i,k2) * 0.01d0 ! pa to mb (hpa) - tlyr(i,k1) = Statein%tgrs(i,k2) - prslk1(i,k1) = Statein%prslk(i,k2) - -!> - Compute relative humidity. - es = min( Statein%prsl(i,k2), fpvs( Statein%tgrs(i,k2) ) ) ! fpvs and prsl in pa - qs = max( QMIN, eps * es / (Statein%prsl(i,k2) + epsm1*es) ) - rhly(i,k1) = max( zero, min( one, max(QMIN, Statein%qgrs(i,k2,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 - k2 = k + lsk - tracer1(:,k1,j) = max(zero, Statein%qgrs(:,k2,j)) - enddo - enddo -! - if (ivflip == 0) then ! input data from toa to sfc - if (lsk > 0) then - k1 = 1 + kd - k2 = k1 + kb - do i = 1, IM - plvl(i,k2) = 0.01d0 * Statein%prsi(i,1+kb) ! pa to mb (hpa) - plyr(i,k1) = 0.5d0 * (plvl(i,k2+1) + plvl(i,k2)) - prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp - enddo - endif - else ! input data from sfc to top - if (Model%levs > lm) then - k1 = lm + kd - do i = 1, IM - plvl(i,k1+1) = 0.01d0 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) - plyr(i,k1) = 0.5d0 * (plvl(i,k1+1) + plvl(i,k1)) - prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp - enddo - else - k1 = lm + kd - do i = 1, IM - plvl(i,k1+1) = 0.01d0 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) - enddo - endif - endif -! - 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.0d0*prsmin - plyr(i,lyb) = 0.5d0 * plvl(i,lla) - tlyr(i,lyb) = tlyr(i,lya) - prslk1(i,lyb) = (plyr(i,lyb)*0.001d0) ** 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 - do k=1,lmk - do i=1,im - olyr(i,k) = max( QMIN, tracer1(i,k,Model%ntoz) ) - enddo - enddo - 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 (only when SW is called) - - if (Model%lsswr) then - call coszmn (Grid%xlon,Grid%sinlat, & ! --- inputs - Grid%coslat,Model%solhr, IM, me, & - 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) = log( max(prsmin, plvl(i,1)) ) - tem2db(i,LMP) = log( plvl(i,LMP) ) - 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) * (one + fvirt*qlyr(i,k1)) ! virtual T (K) - delp(i,k1) = plvl(i,k1+1) - plvl(i,k1) - enddo - enddo - - if ( lextop ) then - do i = 1, IM - qlyr(i,lyb) = qlyr(i,lya) - tvly(i,lyb) = tvly(i,lya) - delp(i,lyb) = plvl(i,lla) - plvl(i,llb) - 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 - -! --- ... level height and layer thickness (km) - - tem0d = 0.001d0 * rog - do i = 1, IM - do k = 1, LMK - dz(i,k) = tem0d * (tem2db(i,k+1) - tem2db(i,k)) * tvly(i,k) - enddo - -! hz(i,LMP) = 0.0 -! do k = LMK, 1, -1 -! hz(i,k) = hz(i,k+1) + dz(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) ) - tem2db(i,LMP) = log( max(prsmin, plvl(i,LMP)) ) - 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) * (one + fvirt*qlyr(i,k)) ! virtual T (K) - delp(i,k) = plvl(i,k) - plvl(i,k+1) - enddo - enddo - - if ( lextop ) then - do i = 1, IM - qlyr(i,lyb) = qlyr(i,lya) - tvly(i,lyb) = tvly(i,lya) - delp(i,lyb) = plvl(i,lla) - plvl(i,llb) - 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 - -! --- ... level height and layer thickness (km) - - tem0d = 0.001d0 * rog - do i = 1, IM - do k = LMK, 1, -1 - dz(i,k) = tem0d * (tem2db(i,k) - tem2db(i,k+1)) * tvly(i,k) - enddo - -! hz(i,1) = 0.0 -! do k = 1, LMP -! hz(i,k+1) = hz(i,k) + dz(i,k) -! enddo - enddo - endif ! end_if_ivflip -!*## CCPP ## - -!> - Check for daytime points for SW radiation. -!## CCPP ##* rrtmg_sw_pre.F90/rrtmg_sw_pre_run - nday = 0 - do i = 1, IM - if (Radtend%coszen(i) >= 0.0001d0) then - nday = nday + 1 - idxday(nday) = i - endif - enddo -!*## CCPP ## - -!> - Call module_radiation_aerosols::setaer(),to setup aerosols -!! property profile for radiation. - -!check print *,' in grrad : calling setaer ' -!## CCPP ##* GFS_rrtmg_pre.F90/GFS_rrtmg_pre_run - call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs - tracer1, Tbd%aer_nm, & - 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 - -! --- ... obtain cloud information for radiation calculations - -! if (ntcw > 0) then ! prognostic cloud schemes - ccnd = zero - if (Model%ncnd == 1) then ! Zhao_Carr_Sundqvist - do k=1,LMK - do i=1,IM - ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water/ice - enddo - enddo - elseif (Model%ncnd == 2) then ! MG - do k=1,LMK - do i=1,IM - ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water - ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water - enddo - enddo - elseif (Model%ncnd == 4) then ! MG2 - do k=1,LMK - do i=1,IM - ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water - ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water - ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water - ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water - enddo - enddo - elseif (Model%ncnd == 5) then ! GFDL MP, Thompson, MG3 - do k=1,LMK - do i=1,IM - ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water - ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water - ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water - ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + grapuel - enddo - enddo - endif - do n=1,ncndl - do k=1,LMK - do i=1,IM - if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = zero - enddo - enddo - enddo - if (Model%imp_physics == 11 ) then - if (.not. Model%lgfdlmprad) then - - -! rsun the summation methods and order make the difference in calculation - -! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & -! + tracer1(:,1:LMK,Model%ntiw) & -! + tracer1(:,1:LMK,Model%ntrw) & -! + tracer1(:,1:LMK,Model%ntsw) & -! + tracer1(:,1:LMK,Model%ntgl) - ccnd(:,:,1) = tracer1(:,1:LMK,ntcw) - ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntrw) - ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) - ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) - ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - -! else -! do j=1,Model%ncld -! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount -! enddo - endif - do k=1,LMK - do i=1,IM - if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = zero - enddo - enddo - endif -! - if (Model%uni_cld) then - if (Model%effr_in) then - do k=1,lm - k1 = k + kd - do i=1,im - cldcov(i,k1) = Tbd%phy_f3d(i,k,Model%indcld) - effrl(i,k1) = Tbd%phy_f3d(i,k,2) - effri(i,k1) = Tbd%phy_f3d(i,k,3) - effrr(i,k1) = Tbd%phy_f3d(i,k,4) - effrs(i,k1) = Tbd%phy_f3d(i,k,5) - enddo - enddo - else - do k=1,lm - k1 = k + kd - do i=1,im - cldcov(i,k1) = Tbd%phy_f3d(i,k,Model%indcld) - enddo - enddo - endif - elseif (Model%imp_physics == 11) then ! GFDL MP - cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,Model%ntclamt) - if(Model%effr_in) then - do k=1,lm - k1 = k + kd - do i=1,im - effrl(i,k1) = Tbd%phy_f3d(i,k,1) - effri(i,k1) = Tbd%phy_f3d(i,k,2) - effrr(i,k1) = Tbd%phy_f3d(i,k,3) - effrs(i,k1) = Tbd%phy_f3d(i,k,4) -! if(Model%me==0) then -! if(effrl(i,k1)> 5.0) then -! write(6,*) 'rad driver:cloud radii:',Model%kdt, i,k1, & -! effrl(i,k1) -! endif -! if(effrs(i,k1)==0.0) then -! write(6,*) 'rad driver:snow mixing ratio:',Model%kdt, i,k1, & -! tracer1(i,k,ntsw) -! endif -! endif - enddo - enddo - - endif - else ! neither of the other two cases - cldcov = zero - 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 (imp_phys=99) & -! ferrier's (imp_phys=5) microphysics schemes - - if ((Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then ! same as Model%imp_physics = 99 - do k=1,lm - k1 = k + kd - do i=1,im - deltaq(i,k1) = Tbd%phy_f3d(i,k,5) - cnvw (i,k1) = Tbd%phy_f3d(i,k,6) - cnvc (i,k1) = Tbd%phy_f3d(i,k,7) - enddo - enddo - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then ! same as MOdel%imp_physics=98 - do k=1,lm - k1 = k + kd - do i=1,im - deltaq(i,k1) = zero - cnvw (i,k1) = Tbd%phy_f3d(i,k,Model%num_p3d+1) - cnvc (i,k1) = zero - enddo - enddo - else ! all the rest - do k=1,lmk - do i=1,im - deltaq(i,k) = zero - cnvw (i,k) = zero - cnvc (i,k) = zero - enddo - enddo - endif - - if (lextop) then - do i=1,im - cldcov(i,lyb) = cldcov(i,lya) - deltaq(i,lyb) = deltaq(i,lya) - cnvw (i,lyb) = cnvw (i,lya) - cnvc (i,lyb) = cnvc (i,lya) - enddo - if (Model%effr_in) then - do i=1,im - effrl(i,lyb) = effrl(i,lya) - effri(i,lyb) = effri(i,lya) - effrr(i,lyb) = effrr(i,lya) - effrs(i,lyb) = effrs(i,lya) - enddo - endif - endif - - if (Model%imp_physics == 99) then - ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) - endif - - - if (Model%imp_physics == 99 .or. Model%imp_physics == 10) then ! zhao/moorthi's prognostic cloud scheme - ! or unified cloud and/or with MG microphysics - - if (Model%uni_cld .and. ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp,& - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & - Sfcprop%slmsk, dz, delp, IM, LMK, LMP, & - Model%uni_cld, Model%lmfshal, & - Model%lmfdeep2, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - endif - - elseif(Model%imp_physics == 98) then ! zhao/moorthi's prognostic cloud+pdfcld - - call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), & - cnvw, cnvc, Grid%xlat, Grid%xlon, & - Sfcprop%slmsk, dz, delp, im, lmk, lmp, deltaq, & - Model%sup, Model%kdt, me, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - - elseif (Model%imp_physics == 11) then ! GFDL cloud scheme - - if (.not.Model%lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, & - Grid%xlat, Grid%xlon, Sfcprop%slmsk, & - cldcov, dz, delp, im, lmk, lmp, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - else - - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp,& - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs -! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs -! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & -! dz, delp, & -! ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1,& -! Model%ntsw-1,Model%ntgl-1,Model%ntclamt-1, & -! im, lmk, lmp, & -! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs - endif - - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme - - if (Model%kdt == 1) then - Tbd%phy_f3d(:,:,1) = 10.0d0 - Tbd%phy_f3d(:,:,2) = 50.0d0 - Tbd%phy_f3d(:,:,3) = 250.0d0 - endif - - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs - Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, Model%uni_cld, & - Model%lmfshal,Model%lmfdeep2, & - cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & - Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs - - endif ! end if_imp_physics - -! endif ! end_if_ntcw - -! --- ... start radiation calculations -! remember to set heating rate unit to k/sec! - - -! mg, sfc-perts -! --- scale random patterns for surface perturbations with -! perturbation size -! --- turn vegetation fraction pattern into percentile pattern - alb1d(:) = 0. - lndp_alb = -999. - if (Model%lndp_type ==1) then - do k =1,Model%n_var_lndp - if (Model%lndp_var_list(k) == 'alb') then - do i=1,im - call cdfnor(Coupling%sfc_wts(i,k),alb1d(i)) - lndp_alb = Model%lndp_prt_list(k) - enddo - endif - enddo - endif -! mg, sfc-perts -!*## CCPP ## - -!## CCPP ##* rrtmg_sw_pre.F90/rrtmg_sw_pre_run; Note: includes check for lsswr in scheme -!> -# 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%hprime(:,1), Sfcprop%alvsf, & - Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & - Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & - Sfcprop%tisfc, IM, & - alb1d, lndp_alb, & ! mg, sfc-perts - sfcalb) ! --- outputs - -!> -# Approximate mean surface albedo from vis- and nir- diffuse values. - Radtend%sfalb(:) = max(0.01d0, 0.5d0 * (sfcalb(:,2) + sfcalb(:,4))) -!*## CCPP ## - -!## CCPP ##* radsw_main.f/rrtmg_sw_run; Note: The checks for nday and lsswr are included in the scheme (returns if -! nday <= 0 or lsswr == F). Optional arguments are used to handle the different calls below. - 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, dz, delp, de_lgth, & - Radtend%coszen, Model%solcon, & - nday, idxday, im, lmk, lmp, Model%lprnt,& - htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs - cldtausw, & - hsw0=htsw0, fdncmp=scmpsw) ! --- optional - else - call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs - gasvmr, clouds, Tbd%icsdsw, faersw, & - sfcalb, dz, delp, de_lgth, & - Radtend%coszen, Model%solcon, & - nday, idxday, IM, LMK, LMP, Model%lprnt,& - htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs - cldtausw, & - FDNCMP=scmpsw) ! --- optional - endif -!*## CCPP ## - -!## CCPP ##* rrtmg_sw_post.F90/rrtmg_sw_post_run - do k = 1, LM - k1 = k + kd - Radtend%htrsw(1:im,k) = htswc(1:im,k1) - enddo -! We are assuming that radiative tendencies are from bottom to top -! --- repopulate the points above levr i.e. LM - if (lm < levs) then - do k = lp1,levs - Radtend%htrsw (1:im,k) = Radtend%htrsw (1:im,LM) - enddo - endif - - if (Model%swhtr) then - do k = 1, lm - k1 = k + kd - Radtend%swhc(1:im,k) = htsw0(1:im,k1) - enddo -! --- repopulate the points above levr i.e. LM - if (lm < levs) then - do k = lp1,levs - Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) - enddo - endif - endif - -! --- surface down and up spectral component fluxes -!> - Save two spectral bands' surface downward and upward fluxes for -!! output. - - do i=1,im - Coupling%nirbmdi(i) = scmpsw(i)%nirbm - Coupling%nirdfdi(i) = scmpsw(i)%nirdf - Coupling%visbmdi(i) = scmpsw(i)%visbm - Coupling%visdfdi(i) = scmpsw(i)%visdf - - Coupling%nirbmui(i) = scmpsw(i)%nirbm * sfcalb(i,1) - Coupling%nirdfui(i) = scmpsw(i)%nirdf * sfcalb(i,2) - Coupling%visbmui(i) = scmpsw(i)%visbm * sfcalb(i,3) - Coupling%visdfui(i) = scmpsw(i)%visdf * sfcalb(i,4) - enddo - - else ! if_nday_block - - Radtend%htrsw(:,:) = zero - - 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 ) - - do i=1,im - Coupling%nirbmdi(i) = zero - Coupling%nirdfdi(i) = zero - Coupling%visbmdi(i) = zero - Coupling%visdfdi(i) = zero - - Coupling%nirbmui(i) = zero - Coupling%nirdfui(i) = zero - Coupling%visbmui(i) = zero - Coupling%visdfui(i) = zero - enddo - - if (Model%swhtr) then - Radtend%swhc(:,:) = zero - endif - - endif ! end_if_nday - -! --- radiation fluxes for other physics processes - do i=1,im - Coupling%sfcnsw(i) = Radtend%sfcfsw(i)%dnfxc - Radtend%sfcfsw(i)%upfxc - Coupling%sfcdsw(i) = Radtend%sfcfsw(i)%dnfxc - enddo - - endif ! end_if_lsswr -!*## CCPP ## - -!## CCPP ## rrtmg_lw_pre.F90/rrtmg_lw_pre_run; Note: scheme includes check for lslwr. -!> -# 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%hprime(:,1), IM, & - Radtend%semis) ! --- outputs -!*## CCPP ## - -!> - Call module_radlw_main::lwrad(), to compute LW heating rates and -!! fluxes. -! print *,' in grrad : calling lwrad' - -!## CCPP ##* radlw_main.f/rrtmg_lw_run; Note: The check lslwr is included in the scheme (returns if -! lslwr == F). Optional arguments are used to handle the different calls below. - if (Model%lwhtr) then - call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs - clouds, Tbd%icsdlw, faerlw, Radtend%semis, & - tsfg, dz, delp, de_lgth, & - im, lmk, lmp, Model%lprnt, & - htlwc, Diag%topflw, Radtend%sfcflw, cldtaulw,& ! --- outputs - hlw0=htlw0) ! --- optional - else - call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs - clouds, Tbd%icsdlw, faerlw, Radtend%semis, & - tsfg, dz, delp, de_lgth, & - IM, LMK, LMP, Model%lprnt, & - htlwc, Diag%topflw, Radtend%sfcflw, cldtaulw) ! --- outputs - endif -!*## CCPP ## - -!## CCPP ## rrtmg_lw_post.F90/rrtmg_lw_post_run; Note: includes check for lslwr. -!> -# 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(1:im,k) = htlwc(1:im,k1) - enddo -! --- repopulate the points above levr - if (lm < levs) then - do k = lm+1,levs - Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) - enddo - endif - - if (Model%lwhtr) then - do k = 1, lm - k1 = k + kd - Radtend%lwhc(1:im,k) = htlw0(1:im,k1) - enddo -! --- repopulate the points above levr - if (lm < levs) then - do k = lm+1,levs - Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) - enddo - endif - endif - -! --- radiation fluxes for other physics processes - Coupling%sfcdlw(:) = Radtend%sfcflw(:)%dnfxc - - endif ! end_if_lslwr -!*## CCPP ## - -!## CCPP ## GFS_rrtmg_post.F90/GFS_rrtmg_post_run -!> - 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 - do i=1,im -! Diag%fluxr(i,34) = Diag%fluxr(i,34) + Model%fhswr*aerodp(i,1) ! total aod at 550nm -! Diag%fluxr(i,35) = Diag%fluxr(i,35) + Model%fhswr*aerodp(i,2) ! DU aod at 550nm -! Diag%fluxr(i,36) = Diag%fluxr(i,36) + Model%fhswr*aerodp(i,3) ! BC aod at 550nm -! Diag%fluxr(i,37) = Diag%fluxr(i,37) + Model%fhswr*aerodp(i,4) ! OC aod at 550nm -! Diag%fluxr(i,38) = Diag%fluxr(i,38) + Model%fhswr*aerodp(i,5) ! SU aod at 550nm -! Diag%fluxr(i,39) = Diag%fluxr(i,39) + Model%fhswr*aerodp(i,6) ! SS aod at 550nm - Diag%fluxr(i,34) = aerodp(i,1) ! total aod at 550nm - Diag%fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm - Diag%fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm - Diag%fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm - Diag%fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm - Diag%fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm - enddo - endif - -! --- save lw toa and sfc fluxes - if (Model%lslwr) then -! --- lw total-sky fluxes - do i=1,im - Diag%fluxr(i,1 ) = Diag%fluxr(i,1 ) + Model%fhlwr * Diag%topflw(i)%upfxc ! total sky top lw up - Diag%fluxr(i,19) = Diag%fluxr(i,19) + Model%fhlwr * Radtend%sfcflw(i)%dnfxc ! total sky sfc lw dn - Diag%fluxr(i,20) = Diag%fluxr(i,20) + Model%fhlwr * Radtend%sfcflw(i)%upfxc ! total sky sfc lw up -! --- lw clear-sky fluxes - Diag%fluxr(i,28) = Diag%fluxr(i,28) + Model%fhlwr * Diag%topflw(i)%upfx0 ! clear sky top lw up - Diag%fluxr(i,30) = Diag%fluxr(i,30) + Model%fhlwr * Radtend%sfcflw(i)%dnfx0 ! clear sky sfc lw dn - Diag%fluxr(i,33) = Diag%fluxr(i,33) + Model%fhlwr * Radtend%sfcflw(i)%upfx0 ! clear sky sfc lw up - enddo - 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) > zero) 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 - do i=1,im - Diag%fluxr(i,17) = Diag%fluxr(i,17) + raddt * cldsa(i,4) - Diag%fluxr(i,18) = Diag%fluxr(i,18) + raddt * cldsa(i,5) - 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 - -! Anning adds optical depth and emissivity output - if (Model%lsswr .and. (nday > 0)) then - do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - tem1 = zero - do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 um channel - enddo - Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1 - enddo - enddo - endif - - if (Model%lslwr) then - do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - tem2 = zero - do k=ibtc,itop - tem2 = tem2 + cldtaulw(i,k) ! approx 10. um channel - enddo - Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (one-exp(-tem2)) - enddo - enddo - endif - - endif - - endif ! end_if_lssav -!*## CCPP ## - return -!........................................ - end subroutine GFS_radiation_driver -!---------------------------------------- - - -! -!> @} -!........................................! - end module module_radiation_driver ! -!========================================! -!> @} -!>@} diff --git a/gfsphysics/makefile b/gfsphysics/makefile deleted file mode 100644 index 2ae58e317..000000000 --- a/gfsphysics/makefile +++ /dev/null @@ -1,273 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 gfsphysics ...) - $(info ) -endif - -LIBRARY = libgfsphys.a - -FFLAGS += -I$(FMS_DIR) -I../cpl - -CPPDEFS += -DNEW_TAUCTMAX -DSMALL_PE -DNEMS_GSM -DINTERNAL_FILE_NML - -# CCPP build -ifneq (,$(findstring CCPP,$(CPPDEFS))) -# Set flags for 32-bit dynamics build -ifeq ($(DYN32),Y) -CPPDEFS += -DOVERLOAD_R4 -endif -CCPP_STATIC_API = ../ccpp/physics/ccpp_static_api.F90 - -# Set physics source files -# DH* 20190916 - can remove namelist_soilveg and set_soilveg -# once calculation of snocvr is moved from FV3GFS_io.F90/GFS_driver.F90 -# to CCPP (GFS_phys_time_vary.fv3.F90) *DH -SRCS_f = \ - ./physics/mersenne_twister.f \ - ./physics/namelist_soilveg.f \ - ./physics/physparam.f \ - ./physics/set_soilveg.f -SRCS_f90 = \ - ./physics/noahmp_tables.f90 -SRCS_F = -SRCS_F90 = \ - ./physics/GFDL_parse_tracers.F90 \ - ./physics/physcons.F90 \ - ./CCPP_layer/CCPP_data.F90 \ - $(CCPP_STATIC_API) \ - ./GFS_layer/GFS_abstraction_layer.F90 \ - ./GFS_layer/GFS_diagnostics.F90 \ - ./GFS_layer/GFS_driver.F90 \ - ./GFS_layer/GFS_restart.F90 -# non-CCPP build -else -SRCS_f = \ - ./physics/cnvc90.f \ - ./physics/co2hc.f \ - ./physics/date_def.f \ - ./physics/dcyc2.f \ - ./physics/dcyc2.pre.rad.f \ - ./physics/efield.f \ - ./physics/get_prs.f \ - ./physics/gocart_tracer_config_stub.f \ - ./physics/gscond.f \ - ./physics/gscondp.f \ - ./physics/gwdc.f \ - ./physics/gwdps.f \ - ./physics/ugwp_driver_v0.f \ - ./physics/cires_orowam2017.f \ - ./physics/h2o_def.f \ - ./physics/h2oc.f \ - ./physics/h2ohdc.f \ - ./physics/h2ophys.f \ - ./physics/ideaca.f \ - ./physics/idea_co2.f \ - ./physics/idea_composition.f \ - ./physics/idea_dissipation.f \ - ./physics/idea_h2o.f \ - ./physics/idea_ion.f \ - ./physics/idea_o2_o3.f \ - ./physics/idea_phys.f \ - ./physics/idea_solar_heating.f \ - ./physics/idea_tracer.f \ - ./physics/iounitdef.f \ - ./physics/lrgsclr.f \ - ./physics/mersenne_twister.f \ - ./physics/mfpbl.f \ - ./physics/mfpblt.f \ - ./physics/mfpbltq.f \ - ./physics/mfscu.f \ - ./physics/mfscuq.f \ - ./physics/module_bfmicrophysics.f \ - ./physics/moninedmf.f \ - ./physics/moninedmf_hafs.f \ - ./physics/moninp.f \ - ./physics/moninp1.f \ - ./physics/moninq.f \ - ./physics/moninq1.f \ - ./physics/moninshoc.f \ - ./physics/mstadb.f \ - ./physics/mstadbtn.f \ - ./physics/mstadbtn2.f \ - ./physics/mstcnv.f \ - ./physics/namelist_soilveg.f \ - ./physics/ozne_def.f \ - ./physics/iccn_def.f \ - ./physics/aerclm_def.f \ - ./physics/ozphys.f \ - ./physics/ozphys_2015.f \ - ./physics/physparam.f \ - ./physics/precpd.f \ - ./physics/precpd_shoc.f \ - ./physics/precpdp.f \ - ./physics/precpd_shoc.f \ - ./physics/progt2.f \ - ./physics/progtm_module.f \ - ./physics/rad_initialize.f \ - ./physics/radiation_aerosols.f \ - ./physics/radiation_astronomy.f \ - ./physics/radiation_clouds.f \ - ./physics/radiation_gases.f \ - ./physics/radiation_surface.f \ - ./physics/radlw_datatb.f \ - ./physics/radlw_main.f \ - ./physics/radlw_param.f \ - ./physics/radsw_datatb.f \ - ./physics/radsw_main.f \ - ./physics/radsw_param.f \ - ./physics/rascnvv2.f \ - ./physics/rayleigh_damp.f \ - ./physics/rayleigh_damp_mesopause.f \ - ./physics/samfaerosols.f \ - ./physics/samfdeepcnv.f \ - ./physics/samfshalcnv.f \ - ./physics/sascnv.f \ - ./physics/sascnvn.f \ - ./physics/satmedmfvdif.f \ - ./physics/satmedmfvdifq.f \ - ./physics/set_soilveg.f \ - ./physics/sfc_cice.f \ - ./physics/sfc_diag.f \ - ./physics/sfc_diff.f \ - ./physics/sfc_drv.f \ - ./physics/sfc_noahmp_drv.f \ - ./physics/sfc_nst.f \ - ./physics/sfc_ocean.f \ - ./physics/sfc_sice.f \ - ./physics/sflx.f \ - ./physics/shalcnv.f \ - ./physics/shalcv.f \ - ./physics/shalcv_1lyr.f \ - ./physics/shalcv_fixdp.f \ - ./physics/shalcv_opr.f \ - ./physics/tracer_const_h.f \ - ./physics/tridi2t3.f - -SRCS_f90 = \ - ./physics/calpreciptype.f90 \ - ./physics/funcphys.f90 \ - ./physics/gcm_shoc.f90 \ - ./physics/get_prs_fv3.f90 \ - ./physics/h2ointerp.f90 \ - ./physics/module_nst_model.f90 \ - ./physics/module_nst_parameters.f90 \ - ./physics/module_nst_water_prop.f90 \ - ./physics/ozinterp.f90 \ - ./physics/module_wrf_utl.f90 \ - ./physics/noahmp_tables.f90 \ - ./physics/module_sf_noahmplsm.f90 \ - ./physics/module_sf_noahmp_glacier.f90 \ - ./physics/iccninterp.f90 \ - ./physics/aerinterp.f90 \ - ./physics/wam_f107_kp_mod.f90 - -SRCS_F = \ - ./physics/aer_cloud.F \ - ./physics/cldmacro.F \ - ./physics/cldwat2m_micro.F \ - ./physics/gfs_phy_tracer_config.F \ - ./physics/machine.F \ - ./physics/num_parthds.F \ - ./physics/sfcsub.F \ - ./physics/wv_saturation.F - -SRCS_F90 = \ - ./physics/GFDL_parse_tracers.F90 \ - ./physics/gcycle.F90 \ - ./physics/cires_ugwp_initialize.F90 \ - ./physics/cires_ugwp_module.F90 \ - ./physics/cires_ugwp_utils.F90 \ - ./physics/cires_ugwp_triggers.F90 \ - ./physics/cires_ugwp_solvers.F90 \ - ./physics/cires_vert_lsatdis.F90 \ - ./physics/cires_vert_orodis.F90 \ - ./physics/cires_vert_wmsdis.F90 \ - ./physics/gfdl_cloud_microphys.F90 \ - ./physics/micro_mg_utils.F90 \ - ./physics/micro_mg2_0.F90 \ - ./physics/micro_mg3_0.F90 \ - ./physics/m_micro_driver.F90 \ - ./physics/cs_conv.F90 \ - ./physics/GFS_debug.F90 \ - ./physics/module_mp_radar.F90 \ - ./physics/module_mp_thompson_gfs.F90 \ - ./physics/module_mp_wsm6_fv3.F90 \ - ./physics/physcons.F90 \ - ./physics/surface_perturbation.F90 \ - ./GFS_layer/GFS_abstraction_layer.F90 \ - ./GFS_layer/GFS_diagnostics.F90 \ - ./GFS_layer/GFS_driver.F90 \ - ./GFS_layer/GFS_physics_driver.F90 \ - ./GFS_layer/GFS_radiation_driver.F90 \ - ./GFS_layer/GFS_restart.F90 \ - ./GFS_layer/GFS_typedefs.F90 -endif - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -# this is the place to override default (implicit) compilation rules -# and create specific (explicit) rules - -# Reduce optimization (substitute (x)CORE-AVX2, (x)CORE-AVX512 or xHOST with (x)CORE-AVX-I) for radiation_aerosols.f -FFLAGS_LOPT1=$(subst CORE-AVX512,CORE-AVX-I,\ - $(subst CORE-AVX2,CORE-AVX-I,\ - $(subst xHOST,xCORE-AVX-I,$(FFLAGS)))) -./physics/radiation_aerosols.o : ./physics/radiation_aerosols.f - $(FC) $(CPPDEFS) $(FFLAGS_LOPT1) $(OTHER_FFLAGS) -c $< -o $@ - -# Reduce optimization (add -O0) for GFS_diagnsostics.F90 -./GFS_layer/GFS_diagnostics.o : ./GFS_layer/GFS_diagnostics.F90 - $(FC) $(CPPDEFS) $(FFLAGS) $(OTHER_FFLAGS) -O0 -c $< -o $@ - -# Do preprocessing of the GFS drivers in two steps to be able -# to look at the actual .f90 file that is compiled -./GFS_layer/GFS_driver.o: ./GFS_layer/GFS_driver.F90 - $(CPP) $(CPPDEFS) $(CPPFLAGS) $< > $*.tmp.f90 - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $*.tmp.f90 -o $@ -./GFS_layer/GFS_physics_driver.o: ./GFS_layer/GFS_physics_driver.F90 - $(CPP) $(CPPDEFS) $(CPPFLAGS) $< > $*.tmp.f90 - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $*.tmp.f90 -o $@ -./GFS_layer/GFS_radiation_driver.o: ./GFS_layer/GFS_radiation_driver.F90 - $(CPP) $(CPPDEFS) $(CPPFLAGS) $< > $*.tmp.f90 - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -c $*.tmp.f90 -o $@ - -.PHONY: clean -clean: - @echo "Cleaning gfsphysics ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.o */*.o *.mod *.i90 *.lst *.i depend */*.tmp.f90 - -MKDEPENDS = ../mkDepends.pl -include ../conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/gfsphysics/physics/GFDL_parse_tracers.F90 b/gfsphysics/physics/GFDL_parse_tracers.F90 deleted file mode 100644 index c81127101..000000000 --- a/gfsphysics/physics/GFDL_parse_tracers.F90 +++ /dev/null @@ -1,41 +0,0 @@ -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/gfsphysics/physics/GFS_debug.F90 b/gfsphysics/physics/GFS_debug.F90 deleted file mode 100644 index 4dfef4aed..000000000 --- a/gfsphysics/physics/GFS_debug.F90 +++ /dev/null @@ -1,799 +0,0 @@ -#define MPI -!> \file GFS_debug.F90 - - module GFS_diagtoscreen - - private - - public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize - - public print_my_stuff, chksum_int, chksum_real, print_var - -! Calculating the checksum leads to segmentation faults with gfortran (bug in malloc?), -! thus print the sum of the array instead of the checksum. -#ifdef __GFORTRAN__ -#define PRINT_SUM -#else -#define PRINT_CHKSUM -#endif - - interface print_var - module procedure print_logic_0d - module procedure print_logic_1d - module procedure print_int_0d - module procedure print_int_1d - module procedure print_real_0d - module procedure print_real_1d - module procedure print_real_2d - module procedure print_real_3d - end interface - - integer, parameter :: ISTART = 1 - integer, parameter :: IEND = 9999999 - - integer, parameter :: KSTART = 1 - integer, parameter :: KEND = 9999999 - - contains - - subroutine GFS_diagtoscreen_init () - end subroutine GFS_diagtoscreen_init - - subroutine GFS_diagtoscreen_finalize () - end subroutine GFS_diagtoscreen_finalize - - subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, & - Grid, Tbd, Cldprop, Radtend, Diag, blkno) - -#ifdef MPI - use mpi -#endif -#ifdef _OPENMP - use omp_lib -#endif - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_statein_type, & - GFS_stateout_type, GFS_sfcprop_type, & - GFS_coupling_type, GFS_grid_type, & - GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type - - 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(in ) :: 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(in ) :: Diag - integer, intent(in ) :: blkno - - !--- local variables - integer :: impi, iomp, ierr, n - integer :: mpirank, mpisize, mpicomm - integer :: omprank, ompsize - - -#ifdef MPI - mpicomm = MPI_COMM_WORLD - mpirank = Model%me - call MPI_COMM_SIZE(mpicomm, mpisize, ierr) -#else - mpirank = 0 - mpisize = 1 - mpicomm = 0 -#endif -#ifdef _OPENMP - omprank = OMP_GET_THREAD_NUM() - ompsize = OMP_GET_NUM_THREADS() -#else - omprank = 0 - ompsize = 1 -#endif - -#ifdef _OPENMP -!$OMP BARRIER -#endif -#ifdef MPI -! call MPI_BARRIER(mpicomm,ierr) -#endif - - do impi=0,mpisize-1 - do iomp=0,ompsize-1 - if (mpirank==impi .and. omprank==iomp) then - call print_var(mpirank,omprank, blkno, 'Model%kdt' , Model%kdt) - ! Sfcprop - call print_var(mpirank,omprank, blkno, 'Sfcprop%slmsk' , Sfcprop%slmsk) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oceanfrac', Sfcprop%oceanfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%landfrac' , Sfcprop%landfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%lakefrac' , Sfcprop%lakefrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfc' , Sfcprop%tsfc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfco' , Sfcprop%tsfco) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfcl' , Sfcprop%tsfcl) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tisfc' , Sfcprop%tisfc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%snowd' , Sfcprop%snowd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorl' , Sfcprop%zorl) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorlo' , Sfcprop%zorlo) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorll' , Sfcprop%zorll) - call print_var(mpirank,omprank, blkno, 'Sfcprop%fice' , Sfcprop%fice) - call print_var(mpirank,omprank, blkno, 'Sfcprop%hprime' , Sfcprop%hprime) - call print_var(mpirank,omprank, blkno, 'Sfcprop%sncovr' , Sfcprop%sncovr) - call print_var(mpirank,omprank, blkno, 'Sfcprop%snoalb' , Sfcprop%snoalb) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alvsf' , Sfcprop%alvsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alnsf' , Sfcprop%alnsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alvwf' , Sfcprop%alvwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alnwf' , Sfcprop%alnwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%facsf' , Sfcprop%facsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%facwf' , Sfcprop%facwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%slope' , Sfcprop%slope) - call print_var(mpirank,omprank, blkno, 'Sfcprop%shdmin' , Sfcprop%shdmin) - call print_var(mpirank,omprank, blkno, 'Sfcprop%shdmax' , Sfcprop%shdmax) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tg3' , Sfcprop%tg3) - call print_var(mpirank,omprank, blkno, 'Sfcprop%vfrac' , Sfcprop%vfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%vtype' , Sfcprop%vtype) - call print_var(mpirank,omprank, blkno, 'Sfcprop%stype' , Sfcprop%stype) - call print_var(mpirank,omprank, blkno, 'Sfcprop%uustar' , Sfcprop%uustar) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oro' , Sfcprop%oro) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%hice' , Sfcprop%hice) - call print_var(mpirank,omprank, blkno, 'Sfcprop%weasd' , Sfcprop%weasd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%canopy' , Sfcprop%canopy) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ffmm' , Sfcprop%ffmm) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ffhh' , Sfcprop%ffhh) - call print_var(mpirank,omprank, blkno, 'Sfcprop%f10m' , Sfcprop%f10m) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tprcp' , Sfcprop%tprcp) - call print_var(mpirank,omprank, blkno, 'Sfcprop%srflag' , Sfcprop%srflag) - call print_var(mpirank,omprank, blkno, 'Sfcprop%slc' , Sfcprop%slc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%smc' , Sfcprop%smc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%stc' , Sfcprop%stc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%t2m' , Sfcprop%t2m) - call print_var(mpirank,omprank, blkno, 'Sfcprop%q2m' , Sfcprop%q2m) - if (Model%nstf_name(1)>0) then - call print_var(mpirank,omprank, blkno, 'Sfcprop%tref ', Sfcprop%tref) - call print_var(mpirank,omprank, blkno, 'Sfcprop%z_c ', Sfcprop%z_c) - call print_var(mpirank,omprank, blkno, 'Sfcprop%c_0 ', Sfcprop%c_0) - call print_var(mpirank,omprank, blkno, 'Sfcprop%c_d ', Sfcprop%c_d) - call print_var(mpirank,omprank, blkno, 'Sfcprop%w_0 ', Sfcprop%w_0) - call print_var(mpirank,omprank, blkno, 'Sfcprop%w_d ', Sfcprop%w_d) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xt ', Sfcprop%xt) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xs ', Sfcprop%xs) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xu ', Sfcprop%xu) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xv ', Sfcprop%xv) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xz ', Sfcprop%xz) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zm ', Sfcprop%zm) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xtts ', Sfcprop%xtts) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xzts ', Sfcprop%xzts) - call print_var(mpirank,omprank, blkno, 'Sfcprop%d_conv ', Sfcprop%d_conv) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ifd ', Sfcprop%ifd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%dt_cool ', Sfcprop%dt_cool) - call print_var(mpirank,omprank, blkno, 'Sfcprop%qrain ', Sfcprop%qrain) - end if - ! CCPP/RUC only - !if (Model%lsm == Model%lsm_ruc) then - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%sh2o', Sfcprop%sh2o) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%smois', Sfcprop%smois) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%tslb', Sfcprop%tslb) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%zs', Sfcprop%zs) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%clw_surf', Sfcprop%clw_surf) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%qwv_surf', Sfcprop%qwv_surf) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%cndm_surf', Sfcprop%cndm_surf) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%flag_frsoil', Sfcprop%flag_frsoil) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%rhofr', Sfcprop%rhofr) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%tsnow', Sfcprop%tsnow) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%snowfallac ', Sfcprop%snowfallac) - ! call print_var(mpirank,omprank, blkno, 'Sfcprop%acsnow ', Sfcprop%acsnow) - !end if - ! Radtend - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%upfxc', Radtend%sfcfsw(:)%upfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%dnfxc', Radtend%sfcfsw(:)%dnfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%upfx0', Radtend%sfcfsw(:)%upfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%dnfx0', Radtend%sfcfsw(:)%dnfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%upfxc', Radtend%sfcflw(:)%upfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%upfx0', Radtend%sfcflw(:)%upfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%dnfxc', Radtend%sfcflw(:)%dnfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%dnfx0', Radtend%sfcflw(:)%dnfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%htrsw', Radtend%htrsw) - call print_var(mpirank,omprank, blkno, 'Radtend%htrlw', Radtend%htrlw) - call print_var(mpirank,omprank, blkno, 'Radtend%sfalb', Radtend%sfalb) - call print_var(mpirank,omprank, blkno, 'Radtend%coszen', Radtend%coszen) - call print_var(mpirank,omprank, blkno, 'Radtend%tsflw', Radtend%tsflw) - call print_var(mpirank,omprank, blkno, 'Radtend%semis', Radtend%semis) - call print_var(mpirank,omprank, blkno, 'Radtend%coszdg', Radtend%coszdg) - call print_var(mpirank,omprank, blkno, 'Radtend%swhc', Radtend%swhc) - call print_var(mpirank,omprank, blkno, 'Radtend%lwhc', Radtend%lwhc) - call print_var(mpirank,omprank, blkno, 'Radtend%lwhd', Radtend%lwhd) - ! Tbd - call print_var(mpirank,omprank, blkno, 'Tbd%icsdsw' , Tbd%icsdsw) - call print_var(mpirank,omprank, blkno, 'Tbd%icsdlw' , Tbd%icsdlw) - call print_var(mpirank,omprank, blkno, 'Tbd%ozpl' , Tbd%ozpl) - call print_var(mpirank,omprank, blkno, 'Tbd%h2opl' , Tbd%h2opl) - call print_var(mpirank,omprank, blkno, 'Tbd%rann' , Tbd%rann) - call print_var(mpirank,omprank, blkno, 'Tbd%acv' , Tbd%acv) - call print_var(mpirank,omprank, blkno, 'Tbd%acvb' , Tbd%acvb) - call print_var(mpirank,omprank, blkno, 'Tbd%acvt' , Tbd%acvt) - call print_var(mpirank,omprank, blkno, 'Tbd%hpbl' , Tbd%hpbl) - if (Model%do_sppt) then - call print_var(mpirank,omprank, blkno, 'Tbd%dtdtr' , Tbd%dtdtr) - call print_var(mpirank,omprank, blkno, 'Tbd%dtotprcp' , Tbd%dtotprcp) - call print_var(mpirank,omprank, blkno, 'Tbd%dcnvprcp' , Tbd%dcnvprcp) - call print_var(mpirank,omprank, blkno, 'Tbd%drain_cpl' , Tbd%drain_cpl) - call print_var(mpirank,omprank, blkno, 'Tbd%dsnow_cpl' , Tbd%dsnow_cpl) - end if - if (Model%nctp > 0 .and. Model%cscnv) then - call print_var(mpirank,omprank, blkno, 'Tbd%phy_fctd' , Tbd%phy_fctd) - end if - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f2d' , Tbd%phy_f2d) - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f3d' , Tbd%phy_f3d) - do n=1,size(Tbd%phy_f3d(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f3d_n' , Tbd%phy_f3d(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Tbd%in_nm' , Tbd%in_nm) - call print_var(mpirank,omprank, blkno, 'Tbd%ccn_nm' , Tbd%ccn_nm) - call print_var(mpirank,omprank, blkno, 'Tbd%aer_nm' , Tbd%aer_nm) - ! Diag - !call print_var(mpirank,omprank, blkno, 'Diag%fluxr ', Diag%fluxr) - !do n=1,size(Diag%fluxr(1,:)) - ! call print_var(mpirank,omprank, blkno, 'Diag%fluxr_n ', Diag%fluxr(:,n)) - !end do - call print_var(mpirank,omprank, blkno, 'Diag%srunoff ', Diag%srunoff) - call print_var(mpirank,omprank, blkno, 'Diag%evbsa ', Diag%evbsa) - call print_var(mpirank,omprank, blkno, 'Diag%evcwa ', Diag%evcwa) - call print_var(mpirank,omprank, blkno, 'Diag%snohfa ', Diag%snohfa) - call print_var(mpirank,omprank, blkno, 'Diag%transa ', Diag%transa) - call print_var(mpirank,omprank, blkno, 'Diag%sbsnoa ', Diag%sbsnoa) - call print_var(mpirank,omprank, blkno, 'Diag%snowca ', Diag%snowca) - call print_var(mpirank,omprank, blkno, 'Diag%soilm ', Diag%soilm) - call print_var(mpirank,omprank, blkno, 'Diag%tmpmin ', Diag%tmpmin) - call print_var(mpirank,omprank, blkno, 'Diag%tmpmax ', Diag%tmpmax) - call print_var(mpirank,omprank, blkno, 'Diag%dusfc ', Diag%dusfc) - call print_var(mpirank,omprank, blkno, 'Diag%dvsfc ', Diag%dvsfc) - call print_var(mpirank,omprank, blkno, 'Diag%dtsfc ', Diag%dtsfc) - call print_var(mpirank,omprank, blkno, 'Diag%dqsfc ', Diag%dqsfc) - call print_var(mpirank,omprank, blkno, 'Diag%totprcp ', Diag%totprcp) - call print_var(mpirank,omprank, blkno, 'Diag%totice ', Diag%totice) - call print_var(mpirank,omprank, blkno, 'Diag%totsnw ', Diag%totsnw) - call print_var(mpirank,omprank, blkno, 'Diag%totgrp ', Diag%totgrp) - call print_var(mpirank,omprank, blkno, 'Diag%totprcpb ', Diag%totprcpb) - call print_var(mpirank,omprank, blkno, 'Diag%toticeb ', Diag%toticeb) - call print_var(mpirank,omprank, blkno, 'Diag%totsnwb ', Diag%totsnwb) - call print_var(mpirank,omprank, blkno, 'Diag%totgrpb ', Diag%totgrpb) - call print_var(mpirank,omprank, blkno, 'Diag%suntim ', Diag%suntim) - call print_var(mpirank,omprank, blkno, 'Diag%runoff ', Diag%runoff) - call print_var(mpirank,omprank, blkno, 'Diag%ep ', Diag%ep) - call print_var(mpirank,omprank, blkno, 'Diag%cldwrk ', Diag%cldwrk) - call print_var(mpirank,omprank, blkno, 'Diag%dugwd ', Diag%dugwd) - call print_var(mpirank,omprank, blkno, 'Diag%dvgwd ', Diag%dvgwd) - call print_var(mpirank,omprank, blkno, 'Diag%psmean ', Diag%psmean) - call print_var(mpirank,omprank, blkno, 'Diag%cnvprcp ', Diag%cnvprcp) - call print_var(mpirank,omprank, blkno, 'Diag%cnvprcpb ', Diag%cnvprcpb) - call print_var(mpirank,omprank, blkno, 'Diag%spfhmin ', Diag%spfhmin) - call print_var(mpirank,omprank, blkno, 'Diag%spfhmax ', Diag%spfhmax) - call print_var(mpirank,omprank, blkno, 'Diag%u10mmax ', Diag%u10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%v10mmax ', Diag%v10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%wind10mmax ', Diag%wind10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%rain ', Diag%rain) - call print_var(mpirank,omprank, blkno, 'Diag%rainc ', Diag%rainc) - call print_var(mpirank,omprank, blkno, 'Diag%ice ', Diag%ice) - call print_var(mpirank,omprank, blkno, 'Diag%snow ', Diag%snow) - call print_var(mpirank,omprank, blkno, 'Diag%graupel ', Diag%graupel) - call print_var(mpirank,omprank, blkno, 'Diag%u10m ', Diag%u10m) - call print_var(mpirank,omprank, blkno, 'Diag%v10m ', Diag%v10m) - call print_var(mpirank,omprank, blkno, 'Diag%dpt2m ', Diag%dpt2m) - call print_var(mpirank,omprank, blkno, 'Diag%zlvl ', Diag%zlvl) - call print_var(mpirank,omprank, blkno, 'Diag%psurf ', Diag%psurf) - call print_var(mpirank,omprank, blkno, 'Diag%pwat ', Diag%pwat) - call print_var(mpirank,omprank, blkno, 'Diag%t1 ', Diag%t1) - call print_var(mpirank,omprank, blkno, 'Diag%q1 ', Diag%q1) - call print_var(mpirank,omprank, blkno, 'Diag%u1 ', Diag%u1) - call print_var(mpirank,omprank, blkno, 'Diag%v1 ', Diag%v1) - call print_var(mpirank,omprank, blkno, 'Diag%chh ', Diag%chh) - call print_var(mpirank,omprank, blkno, 'Diag%cmm ', Diag%cmm) - call print_var(mpirank,omprank, blkno, 'Diag%epi ', Diag%epi) - call print_var(mpirank,omprank, blkno, 'Diag%smcwlt2 ', Diag%smcwlt2) - call print_var(mpirank,omprank, blkno, 'Diag%smcref2 ', Diag%smcref2) - call print_var(mpirank,omprank, blkno, 'Diag%sr ', Diag%sr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomr ', Diag%tdomr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomzr ', Diag%tdomzr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomip ', Diag%tdomip) - call print_var(mpirank,omprank, blkno, 'Diag%tdoms ', Diag%tdoms) - ! CCPP/RUC only - !if (Model%lsm == Model%lsm_ruc) then - ! call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Sfcprop%wetness) - !else - call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Diag%wet1) - !end if - call print_var(mpirank,omprank, blkno, 'Diag%skebu_wts ', Diag%skebu_wts) - call print_var(mpirank,omprank, blkno, 'Diag%skebv_wts ', Diag%skebv_wts) - call print_var(mpirank,omprank, blkno, 'Diag%sppt_wts ', Diag%sppt_wts) - call print_var(mpirank,omprank, blkno, 'Diag%shum_wts ', Diag%shum_wts) - call print_var(mpirank,omprank, blkno, 'Diag%zmtnblck ', Diag%zmtnblck) - if (Model%ldiag3d) then - call print_var(mpirank,omprank, blkno, 'Diag%du3dt ', Diag%du3dt) - do n=1,size(Diag%du3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%du3dt_n ', Diag%du3dt(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Diag%dv3dt ', Diag%dv3dt) - do n=1,size(Diag%dv3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dv3dt_n ', Diag%dv3dt(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Diag%dt3dt ', Diag%dt3dt) - do n=1,size(Diag%dt3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dt3dt_n ', Diag%dt3dt(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Diag%dq3dt ', Diag%dq3dt) - do n=1,size(Diag%dq3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dq3dt_n ', Diag%dq3dt(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Diag%upd_mf ', Diag%upd_mf) - call print_var(mpirank,omprank, blkno, 'Diag%dwn_mf ', Diag%dwn_mf) - call print_var(mpirank,omprank, blkno, 'Diag%det_mf ', Diag%det_mf) - call print_var(mpirank,omprank, blkno, 'Diag%cldcov ', Diag%cldcov) - end if - if(Model%lradar) then - call print_var(mpirank,omprank, blkno, 'Diag%refl_10cm ', Diag%refl_10cm) - end if - ! CCPP/MYNNPBL only - !if (Model%do_mynnedmf) then - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_a ', Diag%edmf_a) - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_w ', Diag%edmf_w) - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_qt ', Diag%edmf_qt) - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_thl ', Diag%edmf_thl) - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_ent ', Diag%edmf_ent) - ! call print_var(mpirank,omprank, blkno, 'Diag%edmf_qc ', Diag%edmf_qc) - ! call print_var(mpirank,omprank, blkno, 'Diag%nupdraft ', Diag%nupdraft) - ! call print_var(mpirank,omprank, blkno, 'Diag%maxMF ', Diag%maxMF) - ! call print_var(mpirank,omprank, blkno, 'Diag%ktop_plume ', Diag%ktop_plume) - ! call print_var(mpirank,omprank, blkno, 'Diag%exch_h ', Diag%exch_h) - ! call print_var(mpirank,omprank, blkno, 'Diag%exch_m ', Diag%exch_m) - !end if - ! Statein - call print_var(mpirank,omprank, blkno, 'Statein%phii' , Statein%phii) - call print_var(mpirank,omprank, blkno, 'Statein%prsi' , Statein%prsi) - call print_var(mpirank,omprank, blkno, 'Statein%prsik' , Statein%prsik) - call print_var(mpirank,omprank, blkno, 'Statein%phil' , Statein%phil) - call print_var(mpirank,omprank, blkno, 'Statein%prsl' , Statein%prsl) - call print_var(mpirank,omprank, blkno, 'Statein%prslk' , Statein%prslk) - call print_var(mpirank,omprank, blkno, 'Statein%pgr' , Statein%pgr) - call print_var(mpirank,omprank, blkno, 'Statein%ugrs' , Statein%ugrs) - call print_var(mpirank,omprank, blkno, 'Statein%vgrs' , Statein%vgrs) - call print_var(mpirank,omprank, blkno, 'Statein%vvl' , Statein%vvl) - call print_var(mpirank,omprank, blkno, 'Statein%tgrs' , Statein%tgrs) - call print_var(mpirank,omprank, blkno, 'Statein%qgrs' , Statein%qgrs) - do n=1,size(Statein%qgrs(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Statein%qgrs_n', Statein%qgrs(:,:,n)) - end do - call print_var(mpirank,omprank, blkno, 'Statein%diss_est', Statein%diss_est) - call print_var(mpirank,omprank, blkno, 'Statein%smc' , Statein%smc) - call print_var(mpirank,omprank, blkno, 'Statein%stc' , Statein%stc) - call print_var(mpirank,omprank, blkno, 'Statein%slc' , Statein%slc) - ! Stateout - call print_var(mpirank,omprank, blkno, 'Stateout%gu0', Stateout%gu0) - call print_var(mpirank,omprank, blkno, 'Stateout%gv0', Stateout%gv0) - call print_var(mpirank,omprank, blkno, 'Stateout%gt0', Stateout%gt0) - call print_var(mpirank,omprank, blkno, 'Stateout%gq0', Stateout%gq0) - do n=1,size(Stateout%gq0(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Stateout%gq0_n', Stateout%gq0(:,:,n)) - end do - ! Coupling - call print_var(mpirank,omprank, blkno, 'Coupling%nirbmdi', Coupling%nirbmdi) - call print_var(mpirank,omprank, blkno, 'Coupling%nirdfdi', Coupling%nirdfdi) - call print_var(mpirank,omprank, blkno, 'Coupling%visbmdi', Coupling%visbmdi) - call print_var(mpirank,omprank, blkno, 'Coupling%visdfdi', Coupling%visdfdi) - call print_var(mpirank,omprank, blkno, 'Coupling%nirbmui', Coupling%nirbmui) - call print_var(mpirank,omprank, blkno, 'Coupling%nirdfui', Coupling%nirdfui) - call print_var(mpirank,omprank, blkno, 'Coupling%visbmui', Coupling%visbmui) - call print_var(mpirank,omprank, blkno, 'Coupling%visdfui', Coupling%visdfui) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcdsw ', Coupling%sfcdsw ) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcnsw ', Coupling%sfcnsw ) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcdlw ', Coupling%sfcdlw ) - if (Model%cplflx .or. Model%do_sppt .or. Model%cplchm) then - call print_var(mpirank,omprank, blkno, 'Coupling%rain_cpl', Coupling%rain_cpl) - call print_var(mpirank,omprank, blkno, 'Coupling%snow_cpl', Coupling%snow_cpl) - end if -! if (Model%cplwav2atm) then -! call print_var(mpirank,omprank, blkno, 'Coupling%zorlwav_cpl' , Coupling%zorlwav_cpl ) -! end if - if (Model%cplflx) then - call print_var(mpirank,omprank, blkno, 'Coupling%oro_cpl' , Coupling%oro_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%slmsk_cpl' , Coupling%slmsk_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%slimskin_cpl', Coupling%slimskin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfcin_cpl ', Coupling%dusfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfcin_cpl ', Coupling%dvsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfcin_cpl ', Coupling%dtsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfcin_cpl ', Coupling%dqsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%ulwsfcin_cpl', Coupling%ulwsfcin_cpl ) -! call print_var(mpirank,omprank, blkno, 'Coupling%tseain_cpl ', Coupling%tseain_cpl ) -! call print_var(mpirank,omprank, blkno, 'Coupling%tisfcin_cpl ', Coupling%tisfcin_cpl ) -! call print_var(mpirank,omprank, blkno, 'Coupling%ficein_cpl ', Coupling%ficein_cpl ) -! call print_var(mpirank,omprank, blkno, 'Coupling%hicein_cpl ', Coupling%hicein_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%hsnoin_cpl ', Coupling%hsnoin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfc_cpl ', Coupling%dusfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfc_cpl ', Coupling%dvsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfc_cpl ', Coupling%dtsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfc_cpl ', Coupling%dqsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dlwsfc_cpl ', Coupling%dlwsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dswsfc_cpl ', Coupling%dswsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirbm_cpl ', Coupling%dnirbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirdf_cpl ', Coupling%dnirdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisbm_cpl ', Coupling%dvisbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisdf_cpl ', Coupling%dvisdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nlwsfc_cpl ', Coupling%nlwsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nswsfc_cpl ', Coupling%nswsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirbm_cpl ', Coupling%nnirbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirdf_cpl ', Coupling%nnirdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisbm_cpl ', Coupling%nvisbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisdf_cpl ', Coupling%nvisdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfci_cpl ', Coupling%dusfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfci_cpl ', Coupling%dvsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfci_cpl ', Coupling%dtsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfci_cpl ', Coupling%dqsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dlwsfci_cpl ', Coupling%dlwsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dswsfci_cpl ', Coupling%dswsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirbmi_cpl ', Coupling%dnirbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirdfi_cpl ', Coupling%dnirdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisbmi_cpl ', Coupling%dvisbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisdfi_cpl ', Coupling%dvisdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nlwsfci_cpl ', Coupling%nlwsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nswsfci_cpl ', Coupling%nswsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirbmi_cpl ', Coupling%nnirbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirdfi_cpl ', Coupling%nnirdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisbmi_cpl ', Coupling%nvisbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisdfi_cpl ', Coupling%nvisdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%t2mi_cpl ', Coupling%t2mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%q2mi_cpl ', Coupling%q2mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%u10mi_cpl ', Coupling%u10mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%v10mi_cpl ', Coupling%v10mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tsfci_cpl ', Coupling%tsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%psurfi_cpl ', Coupling%psurfi_cpl ) - end if - if (Model%cplchm) then - call print_var(mpirank,omprank, blkno, 'Coupling%rainc_cpl', Coupling%rainc_cpl) - call print_var(mpirank,omprank, blkno, 'Coupling%ushfsfci ', Coupling%ushfsfci ) - call print_var(mpirank,omprank, blkno, 'Coupling%dkt ', Coupling%dkt ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqdti ', Coupling%dqdti ) - end if - if (Model%do_sppt) then - call print_var(mpirank,omprank, blkno, 'Coupling%sppt_wts', Coupling%sppt_wts) - end if - if (Model%do_shum) then - call print_var(mpirank,omprank, blkno, 'Coupling%shum_wts', Coupling%shum_wts) - end if - if (Model%do_skeb) then - call print_var(mpirank,omprank, blkno, 'Coupling%skebu_wts', Coupling%skebu_wts ) - call print_var(mpirank,omprank, blkno, 'Coupling%skebv_wts', Coupling%skebv_wts ) - end if - if (Model%lndp_type .NE. 0) then - call print_var(mpirank,omprank, blkno, 'Coupling%sfc_wts' , Coupling%sfc_wts ) - end if - if (Model%do_ca) then - call print_var(mpirank,omprank, blkno, 'Coupling%ca1 ', Coupling%ca1 ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_deep ', Coupling%ca_deep ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_turb ', Coupling%ca_turb ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_shal ', Coupling%ca_shal ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_rad ', Coupling%ca_rad ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_micro ', Coupling%ca_micro ) - end if - if(Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then - call print_var(mpirank,omprank, blkno, 'Coupling%nwfa2d', Coupling%nwfa2d) - call print_var(mpirank,omprank, blkno, 'Coupling%nifa2d', Coupling%nifa2d) - end if - ! Grid - call print_var(mpirank,omprank, blkno, 'Grid%xlon ', Grid%xlon ) - call print_var(mpirank,omprank, blkno, 'Grid%xlat ', Grid%xlat ) - call print_var(mpirank,omprank, blkno, 'Grid%xlat_d', Grid%xlat_d) - call print_var(mpirank,omprank, blkno, 'Grid%sinlat', Grid%sinlat) - call print_var(mpirank,omprank, blkno, 'Grid%coslat', Grid%coslat) - call print_var(mpirank,omprank, blkno, 'Grid%area ', Grid%area ) - call print_var(mpirank,omprank, blkno, 'Grid%dx ', Grid%dx ) - if (Model%ntoz > 0) then - call print_var(mpirank,omprank, blkno, 'Grid%ddy_o3 ', Grid%ddy_o3 ) - call print_var(mpirank,omprank, blkno, 'Grid%jindx1_o3', Grid%jindx1_o3) - call print_var(mpirank,omprank, blkno, 'Grid%jindx2_o3', Grid%jindx2_o3) - endif - if (Model%h2o_phys) then - call print_var(mpirank,omprank, blkno, 'Grid%ddy_h ', Grid%ddy_h ) - call print_var(mpirank,omprank, blkno, 'Grid%jindx1_h', Grid%jindx1_h) - call print_var(mpirank,omprank, blkno, 'Grid%jindx2_h', Grid%jindx2_h) - endif - ! Model/Control - ! not yet - end if -#ifdef _OPENMP -!$OMP BARRIER -#endif - end do -#ifdef MPI -! call MPI_BARRIER(mpicomm,ierr) -#endif - end do - -#ifdef _OPENMP -!$OMP BARRIER -#endif -#ifdef MPI -! call MPI_BARRIER(mpicomm,ierr) -#endif - - end subroutine GFS_diagtoscreen_run - - subroutine print_logic_0d(mpirank,omprank,blkno,name,var) - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - logical, intent(in) :: var - - write(0,'(2a,3i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_logic_0d - - subroutine print_int_0d(mpirank,omprank,blkno,name,var) - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - integer, intent(in) :: var - - write(0,'(2a,3i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_int_0d - - subroutine print_logic_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - logical, intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_logic_1d - - subroutine print_int_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - integer, intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_int(size(var),var), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_int_1d - - subroutine print_real_0d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var - - write(0,'(2a,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_real_0d - - subroutine print_real_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),var), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_real_1d - - subroutine print_real_2d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:,:) - - integer :: k, i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:,1))) - do k=KSTART,min(KEND,size(var(1,:))) - write(0,'(2a,3i6,2i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, var(i,k) - end do - end do -#endif - - end subroutine print_real_2d - - subroutine print_real_3d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:,:,:) - - integer :: k, i, l - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:,1,1))) - do k=KSTART,min(KEND,size(var(1,:,1))) - do l=1,size(var(1,1,:)) - write(0,'(2a,3i6,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, var(i,k,l) - end do - end do - end do -#endif - - end subroutine print_real_3d - - function chksum_int(N, var) result(hash) - implicit none - integer, intent(in) :: N - integer, dimension(1:N), intent(in) :: var - integer*8, dimension(1:N) :: int_var - integer*8 :: a, b, i, hash - integer*8, parameter :: mod_adler=65521 - - a=1 - b=0 - i=1 - hash = 0 - int_var = TRANSFER(var, a, N) - - do i= 1, N - a = MOD(a + int_var(i), mod_adler) - b = MOD(b+a, mod_adler) - end do - - hash = ior(b * 65536, a) - - end function chksum_int - - function chksum_real(N, var) result(hash) - use machine, only: kind_phys - implicit none - integer, intent(in) :: N - real(kind_phys), dimension(1:N), intent(in) :: var - integer*8, dimension(1:N) :: int_var - integer*8 :: a, b, i, hash - integer*8, parameter :: mod_adler=65521 - - a=1 - b=0 - i=1 - hash = 0 - int_var = TRANSFER(var, a, N) - - do i= 1, N - a = MOD(a + int_var(i), mod_adler) - b = MOD(b+a, mod_adler) - end do - - hash = ior(b * 65536, a) - - end function chksum_real - - function print_my_stuff(mpitoprint,omptoprint) result(flag) -#ifdef MPI - use mpi -#endif -#ifdef _OPENMP - use omp_lib -#endif - implicit none - integer, intent(in) :: mpitoprint, omptoprint - logical :: flag - integer :: ompthread, mpirank, ierr -#ifdef MPI - call MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) -#else - mpirank = 0 -#endif -#ifdef _OPENMP - ompthread = OMP_GET_THREAD_NUM() -#else - ompthread = 0 -#endif - - if (mpitoprint==mpirank .and. omptoprint==ompthread) then - flag = .true. - else - flag = .false. - end if - end function print_my_stuff - - end module GFS_diagtoscreen - - module GFS_abort - - private - - public GFS_abort_init, GFS_abort_run, GFS_abort_finalize - - contains - - subroutine GFS_abort_init () - end subroutine GFS_abort_init - - subroutine GFS_abort_finalize () - end subroutine GFS_abort_finalize - - subroutine GFS_abort_run (Model, blkno) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type - - implicit none - - !--- interface variables - type(GFS_control_type), intent(in ) :: Model - integer, intent(in ) :: blkno - - if (Model%kdt==1 .and. blkno==4) then - if (Model%me==0) write(0,*) "GFS_abort_run: ABORTING MODEL" - call sleep(10) - stop - end if - - end subroutine GFS_abort_run - - end module GFS_abort diff --git a/gfsphysics/physics/aer_cloud.F b/gfsphysics/physics/aer_cloud.F deleted file mode 100644 index 364b2782f..000000000 --- a/gfsphysics/physics/aer_cloud.F +++ /dev/null @@ -1,4023 +0,0 @@ - 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=mapl_pi, sq2pi_par=sqrt(pi_par) -! &, 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) -! & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn, lprnt) - - - - - type(AerProps), intent(in) :: Aer_Props - - logical :: use_average_v -! logical :: use_average_v, lprnt - - 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) - -! if (lprnt) write(0,*)' in aero Aer_Props%num=' -! &,Aer_Props%num,' nmodes=',nmodes,' air_den=',air_den -! if (lprnt) write(0,*)' in aero Aer_Props%kap=' -! &,Aer_Props%kap - - antot = 0.0 - - 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)) - - tp_par(n) = Aer_Props%num(n) * air_den - dpg_par(n) = max(Aer_Props%dpg(n), 1.0e-10) - sig_par(n) = Aer_Props%sig(n) - kappa_par(n) = max(Aer_Props%kap(n), 0.001) - dens_par(n) = 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) - antot = antot + tp_par(n) - -! if (lprnt) write(0,*)' n=',n,' tp_par=',tp_par(n),' antot=',antot -! &,' Aer_Props%num=',Aer_Props%num(n),' kappa_par=',kappa_par(n) -! &,' air_den=',air_den - 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 (lprnt) write(0,*)' in aero tparc=',tparc,' antot=',antot -! if (lprnt) write(0,*)' in aero tp_par=',tp_par(1:nmodes) - - 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) - -! if (lprnt) write(0,*)' in aero cdncr8=',cdncr8,' nact=',nact, -! &' air_den=',air_den,' wparc=',wparc,' act_param=',act_param -!============ 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)) - - ddust_ice = zero_par - ndust_ice = zero_par - sigdust_ice = zero_par - 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(1:nbindust_ice) :: 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/gfsphysics/physics/aerclm_def.f b/gfsphysics/physics/aerclm_def.f deleted file mode 100644 index 84852a1de..000000000 --- a/gfsphysics/physics/aerclm_def.f +++ /dev/null @@ -1,23 +0,0 @@ - module aerclm_def - use machine , only : kind_phys - implicit none - - integer, parameter :: levsaer=50, ntrcaerm=15, timeaer=12 - integer :: latsaer, lonsaer, ntrcaer - - character*10 :: specname(ntrcaerm) - real (kind=kind_phys):: aer_time(13) - - real (kind=kind_phys), allocatable, dimension(:) :: aer_lat - real (kind=kind_phys), allocatable, dimension(:) :: aer_lon - real (kind=kind_phys), allocatable, dimension(:,:,:,:) :: aer_pres - real (kind=kind_phys), allocatable, dimension(:,:,:,:,:) :: aerin - - data aer_time/15.5, 45., 74.5, 105., 135.5, 166., 196.5, - & 227.5, 258., 288.5, 319., 349.5, 380.5/ - - data specname /'DU001','DU002','DU003','DU004','DU005', - & 'SS001','SS002','SS003','SS004','SS005','SO4', - & 'BCPHOBIC','BCPHILIC','OCPHOBIC','OCPHILIC'/ - - end module aerclm_def diff --git a/gfsphysics/physics/aerinterp.f90 b/gfsphysics/physics/aerinterp.f90 deleted file mode 100644 index 6a0eadb99..000000000 --- a/gfsphysics/physics/aerinterp.f90 +++ /dev/null @@ -1,363 +0,0 @@ - SUBROUTINE read_aerdata (me, master, iflip, idate ) - use machine, only: kind_phys, kind_io4, kind_io8 - use aerclm_def - use netcdf - -!--- in/out - integer, intent(in) :: me, master, iflip, idate(4) -!--- locals - integer :: ncid, varid, ndims, dim1, dim2, dim3, hmx - integer :: i, j, k, n, ii, imon, klev - character :: fname*50, mn*2, vname*10 - logical :: file_exist - - integer, allocatable :: invardims(:) - real(kind=kind_io4),allocatable,dimension(:,:,:) :: buff - real(kind=kind_io4),allocatable,dimension(:,:,:,:):: buffx - real(kind=kind_io4),allocatable,dimension(:,:) :: pres_tmp - real(kind=kind_io8),allocatable,dimension(:) :: aer_lati - real(kind=kind_io8),allocatable,dimension(:) :: aer_loni -! -!! =================================================================== - if (me == master) then - if ( iflip == 0 ) then ! data from toa to sfc - print *, "GFS is top-down" - else - print *, "GFS is bottom-up" - endif - endif -! -!! =================================================================== -!! fetch dim spec and lat/lon from m01 data set -!! =================================================================== - fname=trim("aeroclim.m"//'01'//".nc") - inquire (file = fname, exist = file_exist) - if (.not. file_exist ) then - print *, 'fname not found, abort' - stop 8888 - endif - call nf_open(fname , NF90_NOWRITE, ncid) - - vname = trim(specname(1)) - call nf_inq_varid(ncid, vname, varid) - call nf_inq_varndims(ncid, varid, ndims) - - if(.not. allocated(invardims)) allocate(invardims(3)) - call nf_inq_vardimid(ncid,varid,invardims) - call nf_inq_dimlen(ncid, invardims(1), dim1) - call nf_inq_dimlen(ncid, invardims(2), dim2) - call nf_inq_dimlen(ncid, invardims(3), dim3) - -! specify latsaer, lonsaer, hmx - lonsaer = dim1 - latsaer = dim2 - hmx = int(dim1/2) ! to swap long from W-E to E-W - - if(me==master) then - print *, 'MERRA2 dim: ',dim1, dim2, dim3 - endif - -! allocate arrays - if (.not. allocated(aer_loni)) then - allocate (aer_loni(lonsaer)) - allocate (aer_lati(latsaer)) - endif - - if (.not. allocated(aer_lat)) then - allocate(aer_lat(latsaer)) - allocate(aer_lon(lonsaer)) - allocate(aerin(lonsaer,latsaer,levsaer,ntrcaerm,timeaer)) - allocate(aer_pres(lonsaer,latsaer,levsaer,timeaer)) - endif - -! construct lat/lon array - call nf_inq_varid(ncid, 'lat', varid) - call nf_get_var(ncid, varid, aer_lati) - call nf_inq_varid(ncid, 'lon', varid) - call nf_get_var(ncid, varid, aer_loni) - - do i = 1, hmx ! flip from (-180,180) to (0,360) - if(aer_loni(i)<0.) aer_loni(i)=aer_loni(i)+360. - aer_lon(i+hmx) = aer_loni(i) - aer_lon(i) = aer_loni(i+hmx) - enddo - - do i = 1, latsaer - aer_lat(i) = aer_lati(i) - enddo - - call nf_close(ncid) - -! allocate local working arrays - if (.not. allocated(buff)) then - allocate (buff(lonsaer, latsaer, dim3)) - allocate (pres_tmp(lonsaer,dim3)) - endif - if (.not. allocated(buffx)) then - allocate (buffx(lonsaer, latsaer, dim3,1)) - endif - -!! =================================================================== -!! loop thru m01 - m12 for aer/pres array -!! =================================================================== - do imon = 1, timeaer - write(mn,'(i2.2)') imon - fname=trim("aeroclim.m"//mn//".nc") - if (me == master) print *, "aerosol climo:", fname, & - "for imon:",imon,idate - - inquire (file = fname, exist = file_exist) - if ( file_exist ) then - if (me == master) print *, & - "aerosol climo found; proceed the run" - else - print *,"Error! aerosol climo not found; abort the run" - stop 555 - endif - - call nf_open(fname , nf90_NOWRITE, ncid) - -! ====> construct 3-d pressure array (Pa) - call nf_inq_varid(ncid, "DELP", varid) - call nf_get_var(ncid, varid, buff) - - do j = 1, latsaer - do i = 1, lonsaer -! constract pres_tmp (top-down), note input is top-down - pres_tmp(i,1) = 0. - do k=2, dim3 - pres_tmp(i,k) = pres_tmp(i,k-1)+buff(i,j,k) - enddo !k-loop - enddo !i-loop (lon) - -! extract pres_tmp to fill aer_pres (in Pa) - do k = 1, levsaer - if ( iflip == 0 ) then ! data from toa to sfc - klev = k - else ! data from sfc to top - klev = ( dim3 - k ) + 1 - endif - do i = 1, hmx - aer_pres(i+hmx,j,k,imon)= 1.d0*pres_tmp(i,klev) - aer_pres(i,j,k,imon) = 1.d0*pres_tmp(i+hmx,klev) - enddo !i-loop (lon) - enddo !k-loop (lev) - enddo !j-loop (lat) - -! ====> construct 4-d aerosol array (kg/kg) -! merra2 data is top down -! for GFS, iflip 0: toa to sfc; 1: sfc to toa - DO ii = 1, ntrcaerm - vname=trim(specname(ii)) - call nf_inq_varid(ncid, vname, varid) - call nf_get_var(ncid, varid, buffx) - - do j = 1, latsaer - do k = 1, levsaer -! input is from toa to sfc - if ( iflip == 0 ) then ! data from toa to sfc - klev = k - else ! data from sfc to top - klev = ( dim3 - k ) + 1 - endif - do i = 1, hmx - aerin(i+hmx,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) - if(aerin(i+hmx,j,k,ii,imon)<0.or.aerin(i+hmx,j,k,ii,imon)>1.) then - aerin(i+hmx,j,k,ii,imon) = 0. - end if - aerin(i,j,k,ii,imon) = 1.d0*buffx(i+hmx,j,klev,1) - if(aerin(i,j,k,ii,imon)<0.or.aerin(i,j,k,ii,imon)>1.) then - aerin(i,j,k,ii,imon) = 0. - end if - enddo !i-loop (lon) - enddo !k-loop (lev) - enddo !j-loop (lat) - - ENDDO ! ii-loop (ntracaerm) - -! close the file - call nf_close(ncid) - enddo !imon-loop -!--- - deallocate (aer_loni, aer_lati) - deallocate (buff, pres_tmp) - deallocate (buffx) - - END SUBROUTINE read_aerdata -! -!********************************************************************** -! - SUBROUTINE setindxaer(npts,dlat,jindx1,jindx2,ddy,dlon, & - iindx1,iindx2,ddx,me,master) -! - USE MACHINE, ONLY: kind_phys - use aerclm_def, only: aer_lat, jaero=>latsaer, & - aer_lon, iaero=>lonsaer -! - implicit none -! - integer me, master - integer npts, JINDX1(npts),JINDX2(npts),IINDX1(npts),IINDX2(npts) - real(kind=kind_phys) dlat(npts),DDY(npts),dlon(npts),DDX(npts) -! - integer i,j - - DO J=1,npts - jindx2(j) = jaero + 1 - do i=1,jaero - if (dlat(j) < aer_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),jaero) - if (jindx2(j) .ne. jindx1(j)) then - DDY(j) = (dlat(j) - aer_lat(jindx1(j))) & - / (aer_lat(jindx2(j)) - aer_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif - - ENDDO - - DO J=1,npts - iindx2(j) = iaero + 1 - do i=1,iaero - if (dlon(j) < aer_lon(i)) then - iindx2(j) = i - exit - endif - enddo - iindx1(j) = max(iindx2(j)-1,1) - iindx2(j) = min(iindx2(j),iaero) - if (iindx2(j) .ne. iindx1(j)) then - ddx(j) = (dlon(j) - aer_lon(iindx1(j))) & - / (aer_lon(iindx2(j)) - aer_lon(iindx1(j))) - else - ddx(j) = 1.0 - endif - ENDDO - - RETURN - END -! -!********************************************************************** -!********************************************************************** -! - SUBROUTINE aerinterpol(me,master,npts,IDATE,FHOUR,jindx1,jindx2, & - ddy,iindx1,iindx2,ddx,lev,prsl,aerout) -! - USE MACHINE, ONLY : kind_phys - use aerclm_def - implicit none - integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii - real(kind=kind_phys) fhour,temj, tx1, tx2,temi -! - - integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) - integer me,idate(4), master - integer IDAT(8),JDAT(8) -! - real(kind=kind_phys) DDY(npts), ddx(npts),ttt - real(kind=kind_phys) aerout(npts,lev,ntrcaer) - real(kind=kind_phys) aerpm(npts,levsaer,ntrcaer) - real(kind=kind_phys) prsl(npts,lev), aerpres(npts,levsaer) - 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. aer_time(1)) RJDAY = RJDAY+365. -! - n2 = 13 - do j=2, 12 - if (rjday .lt. aer_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 -! - tx1 = (aer_time(n2) - rjday) / (aer_time(n2) - aer_time(n1)) - tx2 = 1.0 - tx1 - if (n2 > 12) n2 = n2 -12 - -! - DO L=1,levsaer - DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) - I1 = IINDX1(J) - I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) - DO ii=1,ntrcaer - aerpm(j,L,ii) = & - tx1*(TEMI*TEMJ*aerin(I1,J1,L,ii,n1)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n1)& - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n1)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n1))& - +tx2*(TEMI*TEMJ*aerin(I1,J1,L,ii,n2)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n2) & - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n2)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n2)) - ENDDO - - aerpres(j,L) = & - tx1*(TEMI*TEMJ*aer_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n1)& - +TEMI*DDY(j)*aer_pres(I1,J2,L,n1)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n1))& - +tx2*(TEMI*TEMJ*aer_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n2) & - +TEMI*DDY(j)*aer_pres(I1,J2,L,n2)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n2)) - - ENDDO - ENDDO - -! don't flip, input is the same direction as GFS (bottom-up) - DO J=1,npts - DO L=1,lev - if(prsl(j,L).ge.aerpres(j,1)) then - DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,1,ii) !! sfc level - ENDDO - else if(prsl(j,L).le.aerpres(j,levsaer)) then - DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,levsaer,ii) !! toa top - ENDDO - else - DO k=1, levsaer-1 !! from sfc to toa - IF(prsl(j,L)aerpres(j,k+1)) then - i1=k - i2=min(k+1,levsaer) - exit - ENDIF - ENDDO - temi = prsl(j,L)-aerpres(j,i2) - temj = aerpres(j,i1) - prsl(j,L) - tx1 = temi/(aerpres(j,i1) - aerpres(j,i2)) - tx2 = temj/(aerpres(j,i1) - aerpres(j,i2)) - DO ii = 1, ntrcaer - aerout(j,L,ii)= aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 - ENDDO - endif - ENDDO !L-loop - ENDDO !J-loop -! - RETURN - END diff --git a/gfsphysics/physics/calpreciptype.f90 b/gfsphysics/physics/calpreciptype.f90 deleted file mode 100644 index 5376e44cb..000000000 --- a/gfsphysics/physics/calpreciptype.f90 +++ /dev/null @@ -1,1343 +0,0 @@ - subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & - xlat,xlon, & - gt0,gq0,prsl,prsi,prec, & !input - phii,tskin, & !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 - real,intent(in) :: xlat(im),xlon(im) - real,intent(in) :: randomno(ix,nrcm) - real(kind=kind_phys),dimension(im), intent(in) :: prec,tskin - real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl - 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 - 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 -! -! 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,nrcm,randomno', & -! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),, & -! nrcm,randomno(i,1:nrcm) -! 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) - - snow(5) = 0 - sleet(5) = 0 - freezr(5) = 0 - rain(5) = 0 -! - 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_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/gfsphysics/physics/cires_orowam2017.f b/gfsphysics/physics/cires_orowam2017.f deleted file mode 100644 index 4170a3d79..000000000 --- a/gfsphysics/physics/cires_orowam2017.f +++ /dev/null @@ -1,339 +0,0 @@ - subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, - & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, - & del, sigma, hprime, gamma, theta, - & sinlat, xlatd, taup, taud, pkdis) -! - USE MACHINE , ONLY : kind_phys - use ugwp_common , only : grav, omega2 -! - implicit none - - integer :: im, levs - integer :: npt - integer :: kdt, me, master - integer :: kref(im), ipt(im) - real(kind=kind_phys), intent(in) :: dtp, dxres - real(kind=kind_phys), intent(in) :: taub(im) - - real(kind=kind_phys), intent(in) :: sinlat(im), xlatd(im) - real(kind=kind_phys), intent(in), dimension(im) :: sigma, - & hprime, gamma, theta - - real(kind=kind_phys), intent(in), dimension(im) :: xn, yn - - real(kind=kind_phys), intent(in), dimension(im, levs) :: - & u1, v1, t1, bn2, rho, prsl, del - - real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi -! -! out : taup, taud, pkdis -! - real(kind=kind_phys), intent(inout), dimension(im, levs+1) :: taup - real(kind=kind_phys), intent(inout), dimension(im, levs) :: taud - real(kind=kind_phys), intent(inout), dimension(im, levs) :: pkdis - real(kind=kind_phys) :: belps, aelps, nhills, selps -! -! multiwave oro-spectra -! locals -! - integer :: i, j, k, isp, iw - - integer, parameter :: nworo = 30 - real(kind=kind_phys), parameter :: fc_flag = 0.0 - real(kind=kind_phys), parameter :: mkzmin = 6.28e-3/50.0 - real(kind=kind_phys), parameter :: mkz2min = mkzmin* mkzmin - real(kind=kind_phys), parameter :: kedmin = 1.e-3 - real(kind=kind_phys), parameter :: kedmax = 350.,axmax=250.e-5 - real(kind=kind_phys), parameter :: rtau = 0.01 ! nonlin-OGW scale 1/10sec - real(kind=kind_phys), parameter :: Linsat2 =0.5 - real(kind=kind_phys), parameter :: kxmin = 6.28e-3/100. - real(kind=kind_phys), parameter :: kxmax = 6.28e-3/5.0 - real(kind=kind_phys), parameter :: dkx = (kxmax -kxmin)/(nworo-1) - real(kind=kind_phys), parameter :: kx_slope= -5./3. - real(kind=kind_phys), parameter :: hps =7000., rhp2 = .5/hps - real(kind=kind_phys), parameter :: cxmin=0.5, cxmin2=cxmin*cxmin - - real :: akx(nworo), cxoro(nworo), akx2(nworo) - real :: aspkx(nworo), c2f2(nworo) , cdf2(nworo) - real :: tau_sp(nworo,levs+1), wkdis(nworo, levs+1) - real :: tau_kx(nworo),taub_kx(nworo) - real, dimension(nworo, levs+1) :: wrms, akzw - - real :: tauz(levs+1), rms_wind(levs+1) - real :: wave_act(nworo,levs+1) - - real :: kxw, kzw, kzw2, kzw3, kzi, dzmet, rhoint - real :: rayf, kturb - real :: uz, bv, bv2,kxsp, fcor2, cf2 - - real :: fdis - real :: wfdm, wfdt, wfim, wfit - real :: betadis, betam, betat, kds, cx, rhofac - real :: etwk, etws, tauk, cx2sat - real :: cdf1, tau_norm -! -! mean flow -! - real, dimension(levs+1) :: uzi,rhoi,ktur, kalp, dzi - - integer :: nw, nzi, ksrc - taud (:, :) = 0.0 ; pkdis(:,:) = 0.0 ; taup (:,:) = 0.0 - tau_sp (:,:) = 0.0 ; wrms(:,:) = 0.0 - nw = nworo - nzi = levs+1 - - do iw = 1, nw -! !kxw = 0.25/(dxres)*iw - kxw = kxmin+(iw-1)*dkx - akx(iw) = kxw - akx2(iw) = kxw*kxw - aspkx(iw) = kxw ** (kx_slope) - tau_kx(iw) = aspkx(iw)*dkx - enddo - - tau_norm = sum(tau_kx) - tau_kx(:) = tau_kx(:)/tau_norm - - if (kdt == 1) then -771 format( 'vay-oro19 ', 3(2x,F8.3)) - write(6,771) - & maxval(tau_kx)*maxval(taub)*1.e3, - & minval(tau_kx), maxval(tau_kx) - endif -! -! main loop over oro-points -! - do i =1, npt - j = ipt(i) - -! -! estimate "nhills" => stochastic choices for OGWs -! - if (taub(i) > 0.) then -! -! max_kxridge =min( .5*sigma(j)/hprime(j), kmax) -! ridge-dependent dkx = (max_kxridge -kxmin)/(nw-1) -! option to make grid-box variable kx-spectra kxw = kxmin+(iw-1)*dkx -! - wave_act(1:nw, 1:levs+1) = 1.0 - ksrc = kref(i) - tauz(1:ksrc) = taub(i) - taub_kx(1:nw) = tau_kx(1:nw) * taub(i) - wkdis(:,:) = kedmin - - call oro_meanflow(levs, nzi, u1(j,:), v1(j,:), t1(j,:), - & prsi(j,:), prsL(j,:), del(j,:), rho(i,:), - & bn2(i,:), uzi, rhoi,ktur, kalp,dzi, - & xn(i), yn(i)) - - fcor2 = (omega2*sinlat(j))*(omega2*sinlat(j))*fc_flag - - k = ksrc - - bv2 = bn2(i,k) - uz = uzi(k) !u1(j,ksrc)*xn(i)+v1(j,ksrc)*yn(i)! - kturb = ktur(k) - rayf = kalp(k) - rhoint = rhoi(k) - dzmet = dzi(k) - kzw = max(sqrt(bv2)/max(cxmin, uz), mkzmin) -! -! specify oro-kx spectra and related variables k=ksrc -! - do iw = 1, nw - kxw = akx(iw) - cxoro(iw) = 0.0 - uz - c2f2(iw) = fcor2/akx2(iw) - wrms(iw,k)= taub_kx(iw)/rhoint*kzw/kxw - tau_sp(iw, k) = taub_kx(iw) -! -! - if (cxoro(iw) > cxmin) then - wave_act(iw,k:levs+1) = 0. ! crit-level - else - cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) - if ( cdf2(iw) < cxmin2) then - wave_act(iw,k:levs+1) = 0. ! coriolis cut-off - else - kzw2 = max(Bv2/Cdf2(iw) - akx2(iw), mkz2min) - kzw = sqrt(kzw2) - akzw(iw,k)= kzw - wrms(iw,k)= taub_kx(iw)/rhoint * kzw/kxw - endif - endif - enddo ! nw-spectral loop -! -! defined abobe, k = ksrc: akx(nworo), cxoro(nworo), tau_sp(ksrc, nworo) -! propagate upward multiwave-spectra are filtered by dissipation & instability -! -! tau_sp(:,ksrc+1:levs+1) = tau_sp(:, ksrc) - do k= ksrc+1, levs - uz = uzi(k) - bv2 =bn2(i,k) - bv = sqrt(bv2) - rayf = kalp(k) - rhoint= rhoi(k) - dzmet = dzi(k) - rhofac = rhoi(k-1)/rhoi(k) - - do iw = 1, nworo -! - if (wave_act(iw, k-1) <= 0.0) cycle - cxoro(iw)= 0.0 - uz - if ( cxoro(iw) > cxmin) then - wave_act(iw,k:levs+1) = 0.0 ! crit-level - else - cdf2(iw) = cxoro(iw)*cxoro(iw) -c2f2(iw) - if ( cdf2(iw) < cxmin2) wave_act(iw,k:levs+1) = 0.0 - endif - if ( wave_act(iw,k) <= 0.0) cycle -! -! upward propagation -! - kzw2 = Bv2/Cdf2(iw) - akx2(iw) - - if (kzw2 < mkz2min) then - wave_act(iw,k:levs+1) = 0.0 - else -! -! upward propagation w/o reflection -! - kxw = akx(iw) - kzw = sqrt(kzw2) - akzw(iw,k) = kzw - kzw3 = kzw2*kzw - - cx = cxoro(iw) - betadis = cdf2(iw) / (Cx*Cx+c2f2(iw)) - betaM = 1.0 / (1.0+betadis) - betaT = 1.0 - BetaM - kds = wkdis(iw,k-1) - - etws = wrms(iw,k-1)*rhofac * kzw/akzw(iw,k-1) - - kturb = ktur(k)+pkdis(j,k-1) - wfiM = kturb*kzw2 +rayf - wfiT = wfiM ! do updates with Pr-numbers Kv/Kt - cdf1 = sqrt(Cdf2(iw)) - wfdM = wfiM/(kxw*Cdf1)*BetaM - wfdT = wfiT/(kxw*Cdf1)*BetaT - kzi = 2.*kzw*(wfdM+wfdT)*dzmet - Fdis = exp(-kzi) - - etwk = etws*Fdis - Cx2sat = Linsat2*Cdf2(iw) - - if (etwk > cx2sat) then - Kds = kxw*Cdf1*rhp2/kzw3 - etwk = cx2sat - wfiM = kds*kzw2 - wfdM = wfiM/(kxw*Cdf1) - kzi = 2.*kzw*(wfdm + wfdm)*dzmet - etwk = cx2sat*exp(-kzi) - endif -! if( lat(j) eq 40.5 ) then stop - wkdis(iw,k) = kds - wrms(iw,k) = etwk - tauk = etwk*kxw/kzw - tau_sp(iw,k) = tauk *rhoint - if ( tau_sp(iw,k) > tau_sp(iw,k-1)) - & tau_sp(iw,k) = tau_sp(iw,k-1) - - ENDIF ! upward - ENDDO ! spectral - -!......... do spectral sum of rms, wkdis, tau - - tauz(k) = sum( tau_sp(:,k)*wave_act(:,k) ) - rms_wind(k) = sum( wrms(:,k)*wave_act(:,k) ) - - pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k))+rms_wind(k)*rtau - - if (pkdis(j,k) > kedmax) pkdis(j,k) = kedmax - - ENDDO ! k=ksrc+1, levs - - k = ksrc - tauz(k) = sum(tau_sp(:,k)*wave_act(:,k)) - tauz(k) = tauz(k+1) ! zero momentum dep-n at k=ksrc - - pkdis(j,k) = sum(wkdis(:,k)*wave_act(:,k)) - rms_wind(k) = sum(wrms(:,k)*wave_act(:,k)) - tauz(levs+1) = tauz(levs) - taup(i, 1:levs+1) = tauz(1:levs+1) - do k=ksrc, levs - taud(i,k) = ( tauz(k+1) - tauz(k))*grav/del(j,k) -! if (taud(i,k) .gt. 0)taud(i,k)=taud(i,k)*.01 -! if (abs(taud(i,k)).ge.axmax)taud(i,k)=sign(taud(i,k),axmax) - enddo - endif ! taub > 0 - enddo ! oro-points (i, j, ipt) -!23456 - end subroutine oro_wam_2017 -!------------------------------------------------------------- -! -! define mean flow and dissipation for OGW-kx spectrum -! -!------------------------------------------------------------- - subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, - & delp, rho, bn2, uzi, rhoi, ktur, kalp, dzi, xn, yn) - - use ugwp_common , only : grav, rgrav, rdi, velmin, dw2min - implicit none - - integer :: nz, nzi - real, dimension(nz ) :: u1, v1, t1, delp, rho, pmid - real, dimension(nz ) :: bn2 ! define at the interfaces - real, dimension(nz+1) :: pint - real :: xn, yn -! output - - real, dimension(nz+1) :: dzi, uzi, rhoi, ktur, kalp - -! locals - integer :: i, j, k - real :: ui, vi, ti, uz, vz, shr2, rdz, kamp - real :: zgrow, zmet, rdpm, ritur, kmol, w1 -! paremeters - real, parameter :: hps = 7000., rpspa = 1.e-5 - real, parameter :: rhps=1.0/hps - real, parameter :: h4= 0.25/hps - real, parameter :: rimin = 1.0/8.0, kedmin = 0.01 - real, parameter :: lturb = 30. , uturb = 150.0 - real, parameter :: lsc2 = lturb*lturb,usc2 = uturb*uturb - kalp(1:nzi) = 2.e-7 ! radiative damping - - do k=2, nz - rdpm = grav/(pmid(k-1)-pmid(k)) - ui = .5*(u1(k-1)+u1(k)) - vi = .5*(v1(k-1)+v1(k)) - uzi(k) = Ui*xn + Vi*yn - ti = .5*(t1(k-1)+t1(k)) - rhoi(k) = rdi*pint(k)/ti - rdz = rdpm *rhoi(k) - dzi(k) = 1./rdz - uz = u1(k)-u1(k-1) - vz = v1(k)-v1(k-1) - shr2 = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - zmet = -hps*alog(pint(k)*rpspa) - zgrow = exp(zmet*h4) - kmol = 2.e-5*exp(zmet*rhps)+kedmin - ritur = max(bn2(k)/shr2, rimin) - kamp = sqrt(shr2)*lsc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur(k) = kamp * w1 * w1 +kmol - enddo - - k = 1 - uzi(k) = uzi(k+1) - ktur(k) = ktur(k+1) - rhoi(k) = rdi*pint(k)/t1(k+1) - dzi(k) = rgrav*delp(k)/rhoi(k) - - k = nzi - uzi(k) = uzi(k-1) - ktur(k) = ktur(k-1) - rhoi(k) = rhoi(k-1)*.5 - dzi(k) = dzi(k-1) - - end subroutine oro_meanflow diff --git a/gfsphysics/physics/cires_ugwp_initialize.F90 b/gfsphysics/physics/cires_ugwp_initialize.F90 deleted file mode 100644 index fd2a32d6b..000000000 --- a/gfsphysics/physics/cires_ugwp_initialize.F90 +++ /dev/null @@ -1,704 +0,0 @@ -!=============================== -! cu-cires ugwp-scheme -! initialization of selected -! init gw-solvers (1,2,3,4) -! init gw-source specifications -! init gw-background dissipation -!============================== -! -! Part-0 specifications of common constants, limiters and "criiical" values - - -! module oro_state - -! integer, parameter :: kind_phys=8 -! integer, parameter :: nvaroro=14 -! real (kind=kind_phys), allocatable :: oro_stat(:, :) -! contains - -! subroutine fill_oro_stat(nx, oc, oa4, clx4, theta, gamm, sigma, elvmax, hprime) - -! real (kind=kind_phys),dimension(nx) :: oc, theta, gamm, sigma, elvmax, hprime -! real(kind=kind_phys),dimension(nx,4) :: oa4, clx4 -! integer :: i -! do i=1, nx -! oro_stat(i,1) = hprime(i) -! oro_stat(i,2) = oc(i) -! oro_stat(i,3:6) = oa4(i,1:4) -! oro_stat(i,7:10) = clx4(i,1:4) -! oro_stat(i,11) = theta(i) -! oro_stat(i,12) = gamm(i) -! oro_stat(i,13) = sigma(i) -! oro_stat(i,14) = elvmax(i) -! enddo -! end subroutine fill_oro_stat - -! end module oro_state - - module ugwp_common -! - use machine, only: kind_phys - use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & - rv => con_rv, cpd => con_cp, fv => con_fvirt,& - arad => con_rerth - implicit none - - real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & - rdi = 1.0d0/rd, & - gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & - rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & - pi2 = pi + pi, omega1 = pi2/86400.0, & - omega2 = omega1+omega1, & - rad_to_deg=180.0/pi, deg_to_rad=pi/180.0, & - dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) - - - end module ugwp_common -! -! -!=================================================== -! -!Part-1 init => wave dissipation + RFriction -! -!=================================================== - subroutine init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) - implicit none - - integer :: levs - real, intent(in) :: zkm(levs), pmb(levs) - real, intent(out), dimension(levs+1) :: kvg, ktg, krad, kion -! -!locals + data -! - integer :: k - real, parameter :: vusurf = 2.e-5 - real, parameter :: musurf = vusurf/1.95 - real, parameter :: hpmol = 8.5 -! - real, parameter :: kzmin = 0.1 - real, parameter :: kturbo = 100. - real, parameter :: zturbo = 130. - real, parameter :: zturw = 30. - real, parameter :: inv_pra = 3. !kt/kv =inv_pr -! - real, parameter :: alpha = 1./86400./15. -! - real, parameter :: kdrag = 1./86400./10. - real, parameter :: zdrag = 100. - real, parameter :: zgrow = 50. -! - real :: vumol, mumol, keddy, ion_drag -! - do k=1, levs - vumol = vusurf*exp(-zkm(k)/hpmol) - mumol = musurf*exp(-zkm(k)/hpmol) - - keddy = kturbo*exp(-((zkm(k)-zturbo) /zturw)**2) - - kvg(k) = vumol + keddy - ktg(k) = mumol + keddy*inv_pra - - krad(k) = alpha -! - ion_drag = kdrag -! - kion(k) = ion_drag - enddo - - k= levs+1 - kion(k) = kion(k-1) - krad(k) = krad(k-1) - kvg(k) = kvg(k-1) - ktg(k) = ktg(k-1) -! - end subroutine init_global_gwdis -! -! - subroutine rf_damp_init(levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) - implicit none - - integer :: levs - real :: pa_rf, tau_rf - real :: dtp - - real :: pmb(levs) - real :: rfdis(levs), rfdist(levs) - integer :: levs_rf - - real :: krf, krfz - integer :: k -! - rfdis(1:levs) = 1.0 - rfdist(1:levs) = 0.0 - levs_rf = levs - if (tau_rf <= 0.0 .or. pa_rf == 0.0) return - - krf = 1.0/(tau_rf*86400.0) - - do k=levs, 1, -1 - if(pmb(k) < pa_rf ) then ! applied only on constant pressure surfaces fixed pmb in "Pa" - krfz = krf*log(pa_rf/pmb(k)) - rfdis(k) = 1.0/(1.+krfz*dtp) - rfdist(k) = (rfdis(k) -1.0)/dtp ! du/dtp - levs_rf = k - endif - enddo - - end subroutine rf_damp_init -! ======================================================================== -! Part 2 - sources -! wave sources -! ======================================================================== -! -! ugwp_oro_init -! -!========================================================================= - module ugwp_oro_init - - use ugwp_common, only : bnv2min, grav, grcp, fv, grav, cpd, grcp, pi - - implicit none -! -! constants and "crirtical" values to run oro-mtb_gw physics -! -! choice of oro-scheme: strver = 'vay_2018' , 'gfs_2018', 'kdn_2005', 'smc_2000' -! - character(len=8) :: strver = 'gfs_2018' - character(len=8) :: strbase = 'gfs_2018' - real, parameter :: rimin=-10., ric=0.25 - -! - real, parameter :: efmin=0.5, efmax=10.0 - real, parameter :: hpmax=2400.0, hpmin=25.0 - real, parameter :: sigma_std=1./100., gamm_std=1.0 - - real, parameter :: frmax=10., frc =1.0, frmin =0.01 -! - - real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 - real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 -! - real, parameter :: rlolev=50000.0 -! - real, parameter :: hncrit=9000. ! max value in meters for elvmax - -! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt - - real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor - real, parameter :: hminmt=50. ! min mtn height (*j*) - real, parameter :: minwnd=1.0 ! min wind component (*j*) - real, parameter :: dpmin=5000.0 ! minimum thickness of the reference layer in pa - - real, parameter :: kxoro=6.28e-3/200. ! - real, parameter :: coro = 0.0 - integer, parameter :: nridge=2 - - real :: cdmb ! scale factors for mtb - real :: cleff ! scale factors for orogw - integer :: nworo ! number of waves - integer :: nazoro ! number of azimuths - integer :: nstoro ! flag for stochastic launch above SG-peak - - integer, parameter :: mdir = 8 - real, parameter :: fdir=.5*mdir/pi - - integer nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ - save nwdir - - real, parameter :: odmin = 0.1, odmax = 10.0 -!------------------------------------------------------------------------------ -! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS -!------------------------------------------------------------------------------ - - integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl - real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters - real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] - real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km -!------------------------------------------------------------------------------ -! - real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm - real, parameter :: fcrit_gfs = 0.7 - real, parameter :: fcrit_mtb = 0.7 - - real, parameter :: lzmax = 18.e3 ! 18 km - real, parameter :: mkzmin = 6.28/lzmax - real, parameter :: mkz2min = mkzmin*mkzmin - real, parameter :: zbr_pi = (3.0/2.0)*pi - real, parameter :: zbr_ifs = 0.5*pi - - contains -! - subroutine init_oro_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cdmbgwd ) -! -! - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cdmbgwd(2) ! scaling factors for MTb (1) & (2) for cleff = cleff * cdmbgwd(2) - ! high res-n "larger" MTB and "less-active" cleff in GFS-2018 - real :: cdmbX - real :: kxw - real :: effac ! it is analog of cdmbgwd(2) for GWs, off for now -!-----------------------------! GFS-setup for cdmb & cleff -! cdmb = 4.0 * (192.0/IMX) -! cleff = 0.5E-5 / SQRT(IMX/192.0) = 0.5E-5*SQRT(192./IMX) -! - real, parameter :: lonr_refmb = 4.0 * 192.0 - real, parameter :: lonr_refgw = 192.0 - -! copy to "ugwp_oro_init" => nwaves, nazdir, nstoch - - nworo = nwaves - nazoro = nazdir - nstoro = nstoch - - cdmbX = lonr_refmb/float(lonr) - cdmb = cdmbX - if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) - - cleff = 0.5e-5 * sqrt(lonr_refgw/float(lonr)) !* effac - -!!! cleff = kxw * sqrt(lonr_refgw/float(lonr)) !* effac - - if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) -! -!.................................................................... -! higher res => smaller h' ..&.. higher kx -! flux_gwd ~ 'u'^2*kx/kz ~kxu/n ~1/dx *u/n tau ~ h'*h'*kx*kx = const (h'-less kx-grow) -!.................................................................... -! -! print *, ' init_oro_gws 2-1cdmb', cdmbgwd(2), cdmbgwd(1) - end subroutine init_oro_gws -! - - end module ugwp_oro_init -! ========================================================================= -! -! ugwp_conv_init -! -!========================================================================= - module ugwp_conv_init - - implicit none - real :: eff_con ! scale factors for conv GWs - integer :: nwcon ! number of waves - integer :: nazcon ! number of azimuths - integer :: nstcon ! flag for stochastic choice of launch level above Conv-cloud - real :: con_dlength - real :: con_cldf - - real, parameter :: cmin = 5 !2.5 - real, parameter :: cmax = 95. !82.5 - real, parameter :: cmid = 22.5 - real, parameter :: cwid = cmid - real, parameter :: bns = 2.e-2, bns2 = bns*bns, bns4=bns2*bns2 - real, parameter :: mstar = 6.28e-3/2. ! 2km - real :: dc - - real, allocatable :: ch_conv(:), spf_conv(:) - real, allocatable :: xaz_conv(:), yaz_conv(:) - contains -! - subroutine init_conv_gws(nwaves, nazdir, nstoch, effac, & - lonr, kxw, cgwf) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: cgwf(2) - real :: kxw, effac - real :: work1 = 0.5 - real :: chk, tn4, snorm - integer :: k - - nwcon = nwaves - nazcon = nazdir - nstcon = nstoch - eff_con = effac - - con_dlength = pi2*arad/float(lonr) - con_cldf = cgwf(1) * work1 + cgwf(2) *(1.-work1) -! -! allocate & define spectra in "selected direction": "dc" "ch(nwaves)" -! - if (.not. allocated(ch_conv)) allocate (ch_conv(nwaves)) - if (.not. allocated(spf_conv)) allocate (spf_conv(nwaves)) - if (.not. allocated(xaz_conv)) allocate (xaz_conv(nazdir)) - if (.not. allocated(yaz_conv)) allocate (yaz_conv(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) -! -! we may use different spectral "shapes" -! for example FVS-93 "Desabeius" -! E(s=1, t=3,m, w, k) ~ m^s/(m*^4 + m^4) ~ m^-3 saturated tail -! - do k = 1,nwaves - chk = cmin + (k-1)*dc - tn4 = (mstar*chk)**4 - ch_conv(k) = chk - spf_conv(k) = bns4*chk/(bns4+tn4) - enddo - - snorm = sum(spf_conv) - spf_conv = spf_conv/snorm*1.5 - - call init_nazdir(nazdir, xaz_conv, yaz_conv) - end subroutine init_conv_gws - - - end module ugwp_conv_init -!========================================================================= -! -! ugwp_fjet_init -! -!========================================================================= - - module ugwp_fjet_init - implicit none - real :: eff_fj ! scale factors for conv GWs - integer :: nwfj ! number of waves - integer :: nazfj ! number of azimuths - integer :: nstfj ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: fjet_trig=0. ! if ( abs(frgf) > fjet_trig ) launch GW-packet - - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_fjet(:) , spf_fjet(:) - real, allocatable :: xaz_fjet(:), yaz_fjet(:) - contains - subroutine init_fjet_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwfj = nwaves - nazfj = nazdir - nstfj = nstoch - eff_fj = effac - - if (.not. allocated(ch_fjet)) allocate (ch_fjet(nwaves)) - if (.not. allocated(spf_fjet)) allocate (spf_fjet(nwaves)) - if (.not. allocated(xaz_fjet)) allocate (xaz_fjet(nazdir)) - if (.not. allocated(yaz_fjet)) allocate (yaz_fjet(nazdir)) - - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_fjet(k) = chk - spf_fjet(k) = 1.0 - enddo - call init_nazdir(nazdir, xaz_fjet, yaz_fjet) - - end subroutine init_fjet_gws - - end module ugwp_fjet_init -! -!========================================================================= -! -! - module ugwp_okw_init -!========================================================================= - implicit none - - real :: eff_okw ! scale factors for conv GWs - integer :: nwokw ! number of waves - integer :: nazokw ! number of azimuths - integer :: nstokw ! flag for stochastic choice of launch level above Conv-cloud -! - real, parameter :: okw_trig=0. ! if ( abs(okwp) > okw_trig ) launch GW-packet - - real, parameter :: cmin = 2.5 - real, parameter :: cmax = 67.5 - real :: dc - real, allocatable :: ch_okwp(:), spf_okwp(:) - real, allocatable :: xaz_okwp(:), yaz_okwp(:) - - contains -! - subroutine init_okw_gws(nwaves, nazdir, nstoch, effac, lonr, kxw) - - use ugwp_common, only : pi2, arad - implicit none - - integer :: nwaves, nazdir, nstoch - integer :: lonr - real :: kxw, effac , chk - - integer :: k - - nwokw = nwaves - nazokw = nazdir - nstokw = nstoch - eff_okw = effac - - if (.not. allocated(ch_okwp)) allocate (ch_okwp(nwaves)) - if (.not. allocated(spf_okwp)) allocate (spf_okwp(nwaves)) - if (.not. allocated(xaz_okwp)) allocate (xaz_okwp(nazdir)) - if (.not. allocated(yaz_okwp)) allocate (yaz_okwp(nazdir)) - dc = (cmax-cmin)/float(nwaves-1) - do k = 1,nwaves - chk = cmin + (k-1)*dc - ch_okwp(k) = chk - spf_okwp(k) = 1. - enddo - - call init_nazdir(nazdir, xaz_okwp, yaz_okwp) - - end subroutine init_okw_gws - - end module ugwp_okw_init - -!=============================== end of GW sources -! -! init specific gw-solvers (1,2,3,4) -! - -!=============================== -! Part -3 init wave solvers -!=============================== - - module ugwp_lsatdis_init - implicit none - - integer :: nwav, nazd - integer :: nst - real :: eff - integer, parameter :: incdim = 4, iazdim = 4 -! - contains - - subroutine initsolv_lsatdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - - implicit none -! - integer :: me, master - integer :: nwaves, nazdir - integer :: nstoch - real :: effac - logical :: do_physb - real :: kxw -! -!locals: define azimuths and Ch(nwaves) - domain when physics-based soureces -! are not actibve -! - integer :: inc, jk, jl, iazi, i, j, k - - if( nwaves == 0 .or. nstoch == 1 ) then -! redefine from the default - nwav = incdim - nazd = iazdim - nst = 0 - eff = 1.0 - else -! from input_nml multi-wave spectra - nwav = nwaves - nazd = nazdir - nst = nstoch - eff = effac - endif -! - end subroutine initsolv_lsatdis -! - end module ugwp_lsatdis_init -! -! - module ugwp_wmsdis_init - - use ugwp_common, only : pi, pi2 - implicit none - - real, parameter :: maxdudt = 250.e-5 - - real, parameter :: hpscale= 7000., rhp2 = 0.5/hpscale - real, parameter :: omega2 = 2.*6.28/86400 - real, parameter :: gptwo=2.0 - - real, parameter :: dked_min =0.01 - real, parameter :: gssec = (6.28/30.)**2 ! max-value for bn2 - real, parameter :: bv2min = (6.28/60./120.)**2 ! min-value for bn2 7.6(-7) 2 hrs - real, parameter :: minvel = 0.5 - -! -! make parameter list that will be passed to SOLVER -! - - real, parameter :: v_kxw = 6.28e-3/200. - real, parameter :: v_kxw2 = v_kxw*v_kxw - real, parameter :: tamp_mpa = 30.e-3 - real, parameter :: zfluxglob= 3.75e-3 - - real , parameter :: nslope=1 ! the GW sprctral slope at small-m -! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level -! integer, parameter :: ilaunch=klaunch - - integer , parameter :: iazidim=4 ! number of azimuths - integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum - real , parameter :: ucrit2=0.5 - - real , parameter :: zcimin = ucrit2 - real , parameter :: zcimax = 125.0 - real , parameter :: zgam = 0.25 - real , parameter :: zms_l = 2000.0, zms = pi2 / zms_l, zmsi = 1.0 / zms - - integer :: ilaunch - real :: gw_eff - -!=========================================================================== - integer :: nwav, nazd, nst - real :: eff - - real :: zaz_fct - real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) - real, allocatable :: zcosang(:), zsinang(:) - contains -!============================================================================ - subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - -! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & -! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) -! - implicit none -! -!input -control for solvers: -! nwaves, nazdir, nstoch, effac, do_physb, kxw -! -! - integer :: me, master, nwaves, nazdir, nstoch - real :: effac, kxw - logical :: do_physb -! -!locals -! - integer :: inc, jk, jl, iazi -! - real :: zang, zang1, znorm - real :: zx1, zx2, ztx, zdx, zxran, zxmin, zxmax, zx, zpexp - - if( nwaves == 0) then -! -! redefine from the deafault -! - nwav = incdim - nazd = iazidim - nst = 0 - eff = 1.0 - gw_eff = eff - else -! -! from input.nml -! - nwav = nwaves - nazd = nazdir - nst = nstoch - gw_eff = effac - endif - - allocate ( zci(nwav), zci4(nwav), zci3(nwav),zci2(nwav), zdci(nwav) ) - allocate ( zcosang(nazd), zsinang(nazd) ) - - if (me == master) then - print *, 'ugwp_v0: init_gw_wmsdis_control ' -! print *, 'ugwp_v0: WMSDIS launch layer ', klaunch - print *, 'ugwp_v0: WMSDIS launch layer ', ilaunch - print *, 'ugwp_v0: WMSDID tot_mflux in mpa', tamp_mpa*1000. - endif - - zpexp = gptwo * 0.5 ! gptwo=2 , zpexp = 1. - -! -! set up azimuth directions and some trig factors -! -! - zang = pi2 / float(nazd) - -! get normalization factor to ensure that the same amount of momentum -! flux is directed (n,s,e,w) no mater how many azimuths are selected. -! - znorm = 0.0 - do iazi=1, nazd - zang1 = (iazi-1)*zang - zcosang(iazi) = cos(zang1) - zsinang(iazi) = sin(zang1) - znorm = znorm + abs(zcosang(iazi)) - enddo -! zaz_fct = 1.0 - zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums - -! define coordinate transform for "Ch" ....x = 1/c stretching transform -! ----------------------------------------------- -! note that this is expresed in terms of the intrinsic phase speed -! at launch ci=c-u_o so that the transformation is identical -! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform -! - zxmax = 1.0 / zcimin - zxmin = 1.0 / zcimax - zxran = zxmax - zxmin - zdx = zxran / real(nwav-1) ! dkz -! - zx1 = zxran/(exp(zxran/zgam)-1.0 ) ! zgam =1./4. - zx2 = zxmin - zx1 - -! -! computations for zci =1/zx -! if(lgacalc) zgam=(zxmax-zxmin)/log(zxmax/zxmin) -! zx1=zxran/(exp(zxran/zgam)-1.0_jprb) -! zx2=zxmin-zx1 -! zms = pi2 / zms_l - do inc=1, nwav - ztx = real(inc-1)*zdx+zxmin - zx = zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 - zci(inc) = 1.0 /zx !eq. 28 of scinocca 2003 - zdci(inc) = zci(inc)**2*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 - zci4(inc) = (zms*zci(inc))**4 - zci2(inc) = (zms*zci(inc))**2 - zci3(inc) = (zms*zci(inc))**3 - enddo -! -! -! all done and print-out -! -! - if (me == master) then - print * - print *, 'ugwp_v0: zcimin=' , zcimin - print *, 'ugwp_v0: zcimax=' , zcimax - print *, 'ugwp_v0: cd_crit=', zgam ! m/s precision for crit-level - print *, 'ugwp_v0: launch_level', ilaunch - print *, ' ugwp_v0 zms_l=', zms_l - print *, ' ugwp_vgw nslope=', nslope - - print * - endif - - - end subroutine initsolv_wmsdis -! -! make a list of all-initilized parameters needed for "gw_solver_wmsdis" -! - - end module ugwp_wmsdis_init -!========================================================================= -! -! work TODO for 2-extra WAM-solvers: -! DSPDIS (Hines)+ADODIS (Alexander-Dunkerton-Ortland) -! -!========================================================================= - subroutine init_dspdis - implicit none - end subroutine init_dspdis - - subroutine init_adodis - implicit none - end subroutine init_adodis - diff --git a/gfsphysics/physics/cires_ugwp_module.F90 b/gfsphysics/physics/cires_ugwp_module.F90 deleted file mode 100644 index 45b71f3ee..000000000 --- a/gfsphysics/physics/cires_ugwp_module.F90 +++ /dev/null @@ -1,670 +0,0 @@ -! -module cires_ugwp_module - -! -! driver is called after pbl & before chem-parameterizations -! -!.................................................................................... -! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re -!................................................................................... -! -! - implicit none - logical :: module_is_initialized -!logical :: do_ugwp = .false. ! control => true - ugwp false old gws + rayeleigh friction - - logical :: do_physb_gwsrcs = .false. ! control for physics-based GW-sources - logical :: do_rfdamp = .false. ! control for Rayleigh friction inside ugwp_driver - - real, parameter :: arad=6370.e3 - real, parameter :: pi = atan(1.0) - real, parameter :: pi2 = 2.*pi - real, parameter :: hps = 7000. - real, parameter :: hpskm = hps/1000. -! - real :: kxw = 6.28e-3/100. ! single horizontal wavenumber of ugwp schemes - real, parameter :: ricrit = 0.25 - real, parameter :: frcrit = 0.50 - real, parameter :: linsat = 1.00 - real, parameter :: linsat2 = linsat*linsat -! - - integer :: knob_ugwp_solver=1 ! 1, 2, 3, 4 - (linsat, ifs_2010, ad_gfdl, dsp_dis) - integer, dimension(4) :: knob_ugwp_source ! [1,1,1,0] - (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_wvspec ! number of waves for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_azdir ! number of wave azimuths for- (oro, fronts, conv, imbf-owp] - integer, dimension(4) :: knob_ugwp_stoch ! 1 - deterministic ; 0 - stochastic - real, dimension(4) :: knob_ugwp_effac ! efficiency factors for- (oro, fronts, conv, imbf-owp] - - integer :: knob_ugwp_doaxyz=1 ! 1 -gwdrag - integer :: knob_ugwp_doheat=1 ! 1 -gwheat - integer :: knob_ugwp_dokdis=0 ! 1 -gwmixing - integer :: knob_ugwp_ndx4lh = 2 ! n-number of "unresolved" "n*dx" for lh_gw -! - integer :: ugwp_azdir - integer :: ugwp_stoch - - integer :: ugwp_src - integer :: ugwp_nws - real :: ugwp_effac - -! - data knob_ugwp_source / 1,0, 1, 0 / ! oro-conv-fjet-okw-taub_lat: 1-active 0-off - data knob_ugwp_wvspec /1,32,32,32/ ! number of waves for- (oro, fronts, conv, imbf-owp, taulat] - data knob_ugwp_azdir /2, 4, 4,4/ ! number of wave azimuths for- (oro, fronts, conv, imbf-okwp] - data knob_ugwp_stoch /0, 0, 0,0/ ! 0 - deterministic ; 1 - stochastic, non-activated option - data knob_ugwp_effac /1.,1.,1.,1./ ! efficiency factors for- (oro, fronts, conv, imbf-owp] - integer :: knob_ugwp_version = 0 - integer :: launch_level = 55 -! - namelist /cires_ugwp_nml/ knob_ugwp_solver, knob_ugwp_source,knob_ugwp_wvspec, knob_ugwp_azdir, & - knob_ugwp_stoch, knob_ugwp_effac,knob_ugwp_doaxyz, knob_ugwp_doheat, knob_ugwp_dokdis, & - knob_ugwp_ndx4lh, knob_ugwp_version, launch_level - -!&cires_ugwp_nml -! knob_ugwp_solver=2 -! knob_ugwp_source=1,1,1,0 -! knob_ugwp_wvspec=1,32,32,32 -! knob_ugwp_azdir =2, 4, 4,4 -! knob_ugwp_stoch =0, 0, 0,0 -! knob_ugwp_effac=1, 1, 1,1 -! knob_ugwp_doaxyz=1 -! knob_ugwp_doheat=1 -! knob_ugwp_dokdis=0 -! knob_ugwp_ndx4lh=4 -!/ -! -! allocatable arrays, initilized during "cires_ugwp_init" & -! released during "cires_ugwp_finalize" -! - real, allocatable :: kvg(:), ktg(:), krad(:), kion(:) - real, allocatable :: zkm(:), pmb(:) - real, allocatable :: rfdis(:), rfdist(:) - integer :: levs_rf - real :: pa_rf, tau_rf -! -! limiters -! - real, parameter :: max_kdis = 400. ! 400 m2/s - real, parameter :: max_axyz = 400.e-5 ! 400 m/s/day - real, parameter :: max_eps = max_kdis*4.e-7 ! ~16 K/day -! -!====================================================================== - real, parameter :: F_coriol=1 ! Coriolis effects - real, parameter :: F_nonhyd=1 ! Nonhydrostatic waves - real, parameter :: F_kds =0 ! Eddy mixing due to GW-unstable below - real, parameter :: iPr_ktgw =1./3., iPr_spgw=iPr_ktgw - real, parameter :: iPr_turb =1./3., iPr_mol =1.95 - real, parameter :: rhp1=1./hps, rhp2=0.5*rhp1, rhp4 = rhp2*rhp2 - real, parameter :: khp = 0.287*rhp1 ! R/Cp/Hp - real, parameter :: cd_ulim = 1.0 ! critical level precision or Lz ~ 0 ~dz of model - - contains -! -! ----------------------------------------------------------------------- -! -! init of cires_ugwp (_init) called from GFS_driver.F90 -! -! ----------------------------------------------------------------------- - subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & - lonr, latr, levs, ak, bk, pref, dtp, cdmvgwd, cgwf, & - pa_rf_in, tau_rf_in) -! -! input_nml_file ='input.nml'=fn_nml -! - use ugwp_oro_init, only : init_oro_gws - use ugwp_conv_init, only : init_conv_gws - use ugwp_fjet_init, only : init_fjet_gws - use ugwp_okw_init, only : init_okw_gws - use ugwp_wmsdis_init, only : initsolv_wmsdis, ilaunch - use ugwp_lsatdis_init, only : initsolv_lsatdis - implicit none - - integer, intent (in) :: me - integer, intent (in) :: master - integer, intent (in) :: nlunit - integer, intent (in) :: logunit - integer, intent (in) :: lonr - integer, intent (in) :: levs - integer, intent (in) :: latr - real, intent (in) :: ak(levs+1), bk(levs+1), pref - real, intent (in) :: dtp - real, intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes - real, intent (in) :: pa_rf_in, tau_rf_in - - character(len=64), intent (in) :: fn_nml2 - character(len=64), parameter :: fn_nml='input.nml' - -! character, intent (in) :: input_nml_file -! integer, parameter :: logunit = 6 - integer :: ios - logical :: exists - real :: dxsg - integer :: k -! - if (me == master) print *, trim (fn_nml), ' GW-namelist file ' - inquire (file =trim (fn_nml) , exist = exists) -! - if (.not. exists) then - if (me == master) & - write (6, *) 'separate ugwp :: namelist file: ', trim (fn_nml), ' does not exist' - else - open (unit = nlunit, file = trim(fn_nml), action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = cires_ugwp_nml) - close (nlunit) -! - ilaunch = launch_level - pa_rf = pa_rf_in - tau_rf = tau_rf_in - -! write version number and namelist to log file - if (me == master) then - write (logunit, *) " ================================================================== " - write (logunit, *) "cires_ugwp_cires" - write (logunit, nml = cires_ugwp_nml) - endif -! -! effective kxw - resolution-aware -! - dxsg = pi2*arad/float(lonr) * knob_ugwp_ndx4lh -! -! kxw = pi2/dxsg -! -! init global background dissipation for ugwp -> 4d-variable for fv3wam linked with pbl-vert_diff -! - -! allocate(fcor(latr), fcor2(latr) ) -! - allocate( kvg(levs+1), ktg(levs+1) ) - allocate( krad(levs+1), kion(levs+1) ) - allocate( zkm(levs), pmb(levs) ) - allocate( rfdis(levs), rfdist(levs) ) -! -! ak -pa bk-dimensionless from surf => tol_lid_pressure =0 -! - do k=1, levs - pmb(k) = 1.e0*(ak(k) + pref*bk(k)) ! Pa -unit Pref = 1.e5 - zkm(k) = -hpskm*alog(pmb(k)/pref) - enddo -! -! Part-1 :init_global_gwdis -! - call init_global_gwdis(levs, zkm, pmb, kvg, ktg, krad, kion) - call rf_damp_init (levs, pa_rf, tau_rf, dtp, pmb, rfdis, rfdist, levs_rf) -! -! Part-2 :init_SOURCES_gws -! - -! -! call init-solver for "stationary" multi-wave spectra and sub-grid oro -! - call init_oro_gws( knob_ugwp_wvspec(1), knob_ugwp_azdir(1), & - knob_ugwp_stoch(1), knob_ugwp_effac(1), lonr, kxw, cdmvgwd ) -! -! call init-sources for "non-sationary" multi-wave spectra -! - do_physb_gwsrcs=.true. - - IF (do_physb_gwsrcs) THEN - - if (me == master) print *, ' do_physb_gwsrcs ', do_physb_gwsrcs, ' in cires_ugwp_init ' - if (knob_ugwp_wvspec(4) > 0) then -! okw - call init_okw_gws(knob_ugwp_wvspec(4), knob_ugwp_azdir(4), & - knob_ugwp_stoch(4), knob_ugwp_effac(4), lonr, kxw ) - if (me == master) print *, ' init_okw_gws ' - endif - - if (knob_ugwp_wvspec(3) > 0) then -! fronts - call init_fjet_gws(knob_ugwp_wvspec(3), knob_ugwp_azdir(3), & - knob_ugwp_stoch(3), knob_ugwp_effac(3), lonr, kxw ) - if (me == master) print *, ' init_fjet_gws ' - endif - - if (knob_ugwp_wvspec(2) > 0) then -! conv - call init_conv_gws(knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), lonr, kxw, cgwf ) - if (me == master) & - print *, ' init_convective GWs cgwf', knob_ugwp_wvspec(2), knob_ugwp_azdir(2) - - endif - - ENDIF !IF (do_physb_gwsrcs) - -!====================== -! Part-3 :init_SOLVERS -! ===================== -! -! call init-solvers for "broad" non-stationary multi-wave spectra -! - if (knob_ugwp_solver==1) then -! - call initsolv_lsatdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw ) - endif - if (knob_ugwp_solver==2) then - - call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & - knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) - endif -! -! other solvers not yet tested for fv3gfs -! -!< if (knob_ugwp_solver==3) call init_dspdis -!< if (knob_ugwp_solver==4) call init_adodis -! - -!====================== - module_is_initialized = .true. - if (me == master) print *, ' VAY-ugwp is initialized ', module_is_initialized - - end subroutine cires_ugwp_init - -! ----------------------------------------------------------------------- -! -! driver of cires_ugwp (_driver) -! called from GFS_physics_driver.F90 -! -! ----------------------------------------------------------------------- -! call cires_ugwp_driver & -! (im, levs, dtp, kdt, me, lprnt, Model%lonr, & -! Model%prslrd0, Model%ral_ts, Model%cdmbgwd, & -! Grid%xlat, Grid%xlat_d, Grid%sinlat, Grid%coslat, & -! Statein, delp_gws, Oro_stat, & -! dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & -! Diag%gwp_ax, Diag%gwp_axo, Diag%gwp_axc, Diag%gwp_axf, & -! Diag%gwp_ay, Diag%gwp_ayo, Diag%gwp_ayc, Diag%gwp_ayf, & -! Diag%gwp_dtdt, Diag%gwp_kdis, Diag%gwp_okw, Diag%gwp_fgf, & -! Diag%gwp_dcheat, Diag%gwp_precip, Diag%gwp_klevs, & -! Diag%zmtb, Diag%gwp_scheat, dlength, cldf, & -! Diag%tau_tofd, Diag%tau_mtb, Diag%tau_ogw, Diag%tau_ngw, & -! Diag%zmtb, Diag%zlwb, Diag%zogw, Diag%du3dt_mtb, & -! Diag%du3dt_ogw, Diag%du3dt_tms ) - - subroutine cires_ugwp_driver & - (im, levs, dtp, kdt, me, lprnt, lonr, & - pa_rf, tau_rf, cdmbgwd, xlat, xlatd, sinlat, coslat, & - ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & - delp, orostat, kpbl, & - dusfc, dvsfc, dudt, dvdt, dtdt, kdis, & - axtot, axo, axc, axf, aytot, ayo, ayc, ayf, & - eps_tot, ekdis, trig_okw, trig_fgf, & - dcheat, precip, cld_klevs, zmtb, scheat, dlength, cldf, & - taus_sso, taus_ogw, tauf_ogw, tauf_ngw, & - ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb, ugw_axlwb, ugw_axtms ) - -! - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd - use ugwp_common, only: omega2 -! -! - use ugwp_okw_init, only : & - eff_okw, nstokw, nwokw, ch_okwp, nazokw, spf_okwp, xaz_okwp, yaz_okwp - use ugwp_conv_init, only : & - eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv - use ugwp_fjet_init, only : & - eff_fj, nstfj, nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet - -! - implicit none -! - - logical :: lprnt - integer :: me, im, levs, kdt, lonr - real(kind_phys) :: dtp - real(kind_phys) :: pa_rf, tau_rf - real(kind_phys) :: cdmbgwd(2) - - integer, intent(in) :: kpbl(im) - real(kind_phys) :: hpbl(im) - real(kind_phys), intent(in) :: orostat(im, 14) - real(kind_phys), intent(in), dimension(im,levs) :: ugrs, vgrs, & - tgrs, qgrs, prsi, prsl, prslk, phii, phil, delp -! - real(kind_phys), dimension(im) :: xlat, xlatd, sinlat, coslat - real(kind_phys), dimension(im, levs) :: trig_okw, trig_fgf - real(kind_phys), dimension(im) :: precip ! precip-n rates and - integer , dimension(im, 3) :: cld_klevs ! indices fo cloud top/bot/? - real(kind_phys), dimension(im, levs) :: dcheat, scheat ! deep and shal conv heat tend. - - - real(kind_phys), dimension(im) :: dlength ! tail-grid box scale in meters - real(kind_phys), dimension(im) :: cldf ! "bizzard" old cgwd-tuning knobs dimensionless -!=================== -! tendency + kdis -!=================== - real(kind_phys), dimension(im, levs) :: dudt, dvdt, dtdt, kdis - real(kind_phys), dimension(im, levs) :: axtot, axo, axc, axf - real(kind_phys), dimension(im, levs) :: aytot, ayo, ayc, ayf - real(kind_phys), dimension(im, levs) :: eps_tot, ekdis - -! - real(kind_phys), dimension(im, levs) :: eds_o, kdis_o - real(kind_phys), dimension(im, levs) :: eds_c, kdis_c - real(kind_phys), dimension(im, levs) :: eds_f, kdis_f - real(kind_phys), dimension(im, levs) :: ax_rf, ay_rf, eps_rf -! -!================================================================================== -! diagnostics for OGW & NGW + SSO effects axmtb, axlwb, axtms -!================================================================================== - real(kind_phys), dimension(im) :: dusfc, dvsfc - real(kind_phys), dimension(im) :: taus_sso, taus_ogw, tauf_ogw, tauf_ngw - real(kind_phys), dimension(im) :: ugw_zmtb, ugw_zlwb, ugw_zogw - real(kind_phys), dimension(im, levs) :: ugw_axmtb,ugw_axlwb, ugw_axtms - real(kind_phys), dimension(im, levs) :: tauz_ogw, tauz_ngw, wtauz - -! -! knob_ugwp_source=[ 1, 1, 1, 0 ] -! oro conv nst imbal-okw -! locals -! - integer :: i, j, k, istype, ido -! -! internal diagnostics for oro-waves, lee waves, and mtb : -! - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw ! GW-launch levels in "meters" -! - real(kind_phys), dimension(im) :: fcor, c2f2 -! -! three sources with different: a) spectra-content/azimuth; b) efficiency ;c) spectral shape -! - real(kind_phys), dimension(im) :: taub_con, taub_fj, taub_okw - integer , dimension(im) :: klev_okw, klev_fj, klev_con - integer , dimension(im) :: if_okw, if_con, if_fj - integer :: nf_okw, nf_con, nf_fj -! - dudt = 0. - dvdt = 0. - dtdt = 0. - kdis = 0. - axo = 0. ; axc = 0. ; axf = 0. - ayo = 0. ; ayc = 0. ; ayf = 0. - eds_o = 0. ; kdis_o = 0. ; eds_f = 0. ; kdis_f = 0. ; eds_c = 0. ; kdis_c = 0. - ax_rf = 0. ; ay_rf = 0. ; eps_rf = 0 - - hpbl(:) = 2000. ! hpbl (1:im) = phil(1:im, kpbl(1:im)) -! - - do i=1, im - fcor(i) = omega2*sinlat(i) - c2f2(i) = fcor(i)*fcor(i)/(kxw*kxw) - enddo - -! i=im -! print *, i, fcor(i), 6.28e-3/kxw, sqrt(c2f2(i)) -! print *, maxval(statein%prsl/statein%tgrs)/287. , ' density ' - -! -! -! What can be computed for ALL types of GWs? => -! "Br-Vi frequency"with "limits" in case of "conv-unstable" layers -! Background dissipation: Molecular + Eddy -! Wind projections may differ from GW-sources/propagation azimuths -! - do istype=1, size(knob_ugwp_source) - - ido = knob_ugwp_source(istype) ! 0 or 1 off or active - - ugwp_azdir = knob_ugwp_azdir(istype) - ugwp_stoch = knob_ugwp_stoch(istype) - ugwp_nws = knob_ugwp_wvspec(istype) - ugwp_effac = knob_ugwp_effac(istype) - -! -! oro-gw effects -! - if (ido == 1 .and. istype ==1 ) then -! -! 1. solve for OGW effects on the mean flow -! 2. all parts of ORO effexra inside: MTB TOFD LeeWB OGW-drag -! - call ugwp_oro(im, levs, dtp, kdt, me, lprnt, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - orostat, hpbl, axo, ayo, eds_o, kdis_o, & - dusfc, dvsfc, dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, & - dusfc_lwb, dvsfc_lwb, zmtb, zlwb, zogw,tauf_ogw,tauz_ogw,& - ugw_axmtb,ugw_axlwb, ugw_axtms) -! -! taus_sso, taus_ogw, tauz_ogw, tauz_ngw, tauf_ogw, tauf_ngw, & -! ugw_zmtb, ugw_zlwb, ugw_zogw, ugw_axmtb,ugw_axlwb, ugw_axtms -! collect column-integrated "dusfc, dvsfc" only for oro-waves -! - taus_sso = dusfc_mb + dusfc_lwb + dusfc_ogw - taus_ogw = dusfc_ogw - ugw_zmtb = zmtb - ugw_zlwb = zlwb - ugw_zogw = zogw - -! tauz_ogw/tauf_ogw => output -! ugwp_azdir, ugwp_stoch, ugwp_nws ..... "multi-wave + stochastic" -! -! stationary gw-mode ch=0, with "gw_solver_linsat" -! compute column-integrated "dusfc, dvsfc" only for oro-waves -! - dudt = dudt + axo * ugwp_effac - dvdt = dvdt + ayo * ugwp_effac - dtdt = dtdt + eds_o * ugwp_effac - kdis = kdis + kdis_o* ugwp_effac -! print *, ' ido istype ORO=1 ', ido, istype, ' ugwp_oro as a solver ' - endif - - if (ido == 1 .and. istype ==2 ) then -! -! convective gw effects -! -! 1. specify spectra + forcing nstcon, nwcon, ch_conv, nazcon, spf_conv -! - call get_spectra_tau_convgw & - (nwcon, im, levs, dcheat, scheat, precip, cld_klevs, & - xlatd, sinlat, coslat, taub_con, klev_con, if_con, nf_con) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_con > 0) then - - klev_con(:) = 52 ! ~5 km -! -!eff_con, nstcon, nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwcon, ch_conv, nazcon, spf_conv, xaz_conv, yaz_conv, & - fcor, c2f2, ugrs, vgrs, tgrs, qgrs, prsi, delp, & - prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) - - - if (knob_ugwp_solver == 2) then -! print *, ' before CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_con, klev_con, if_con, nf_con, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axc, ayc, eds_c, kdis_c, wtauz) -! print *, ' after ido istype CONV-2 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - endif - - dudt = dudt + axc * ugwp_effac - dvdt = dvdt + ayc * ugwp_effac - dtdt = dtdt + eds_c * ugwp_effac - kdis = kdis + kdis_c * ugwp_effac - - tauz_ngw = wtauz - - endif - - endif - - if (ido == 1 .and. istype ==3 ) then -! -! nonstationary gw effects -! -! 1. specify spectra + forcing -! - call get_spectra_tau_nstgw (nwfj, im, levs, & - trig_fgf, xlatd, sinlat, coslat, taub_fj, klev_fj, if_fj, nf_fj) -! -! 2. solve for GW effects on the mean flow -! - print *, ' tau_nstgw nf_fj-GW triggers ', nf_fj, ' ugwp_solver = ', knob_ugwp_solver - if ( nf_fj > 0) then - - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_fj, klev_fj, if_fj, nf_fj, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - print *, ' ido istype for FJ 1-4 ', ido, istype, ' gw_solver_wmsdis ', knob_ugwp_solver - - endif - endif -! print *, ' ido istype for okw 1-4 ', ido, istype - if (ido == 1 .and. istype == 4 ) then -! -! nonstationary gw effects due to both "convection +fronts/jets " = imbalance of rs-flow -! -! 1. specify spectra + forcing -! - call get_spectra_tau_okw (nwokw, im, levs,& - trig_okw, xlatd, sinlat, coslat, taub_okw, klev_okw, if_okw, nf_okw) -! -! 2. solve for GW effects on the mean flow -! - if ( nf_okw > 0) then -! - if (knob_ugwp_solver == 1) call gw_solver_linsatdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - - if (knob_ugwp_solver == 2) call gw_solver_wmsdis & - (im, levs, dtp, kdt, me, taub_okw, klev_okw, if_okw, nf_okw, & - nwfj, ch_fjet, nazfj, spf_fjet, xaz_fjet, yaz_fjet, & - fcor, c2f2, ugrs, vgrs, tgrs, & - qgrs, prsi, delp, prsl, prslk, phii, phil, & - axf, ayf, eds_f, kdis_f, wtauz) - - dudt = dudt + axf * ugwp_effac - dvdt = dvdt + ayf * ugwp_effac - dtdt = dtdt + eds_f * ugwp_effac - kdis = kdis + kdis_f * ugwp_effac - tauz_ngw = wtauz - endif - endif -! -! broad gw-spectra -! - 356 continue - enddo -! -! gw-diag only -! - axtot = dudt - aytot = dvdt - eps_tot = dtdt - -! -! optional rf-damping -! - if (do_rfdamp) then -! -! - call rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, ugrs, vgrs, ax_rf, ay_rf, eps_rf) -! -! gw-diag only + rf-damping ..... now orchestrate it with FV3-dycore RF-damping -! - do k=levs_rf, levs - - dudt(:,k) = dudt(:,k) + ax_rf(:,k) - dvdt(:,k) = dvdt(:,k) + ay_rf(:,k) - dtdt(:,k) = dtdt(:,k) + eps_rf(:,k) - - enddo - - endif -!================================================================================ -! To update U-V-T STATE by [dudt dvdt dtdt kdis+rf] => Solve 3-diag VD-equation -!================================================================================ -! to do for fv3wam=> -! joint eddy+molecular viscosity/conductivity/diffusion -! requires "dqdt" + dudt_vis, dvdt_vis. dtdt_cond - -! print *, ' cires_ugwp_driver +++++++++++++++++ ' -! - end subroutine cires_ugwp_driver - - -!============================================= - - - subroutine cires_ugwp_advance -!----------------------------------------------------------------------- -! -! options for the day-to-day variable sources/spectra + diagnostics -! for stochastic "triggers" -! diagnose GW-source functions * FGF + OKWP + SGO/CONV from IAU-fields -! or use for stochastic GWP-sources "memory" -!----------------------------------------------------------------------- - implicit none -! -! update sources -! a) physics-based triggers for multi-wave -! b) stochastic-based spectra and amplitudes -! c) use "memory" on GW-spectra from previous time-step -! d) update "background" GW dissipation as needed -! - end subroutine cires_ugwp_advance - -! -! ----------------------------------------------------------------------- -! finalize of cires_ugwp (_finalize) -! ----------------------------------------------------------------------- - - - subroutine cires_ugwp_finalize -! -! deallocate sources/spectra & some diagnostics need to find where "deaalocate them" -! before "end" of the FV3GFS -! - implicit none -! -! deallocate arrays employed in: -! cires_ugwp_advance / cires_ugwp_driver / cires_ugwp_init -! - deallocate( kvg, ktg ) - deallocate( krad, kion ) - deallocate( zkm, pmb ) - deallocate( rfdis, rfdist) - - end subroutine cires_ugwp_finalize -! - end module cires_ugwp_module - diff --git a/gfsphysics/physics/cires_ugwp_solvers.F90 b/gfsphysics/physics/cires_ugwp_solvers.F90 deleted file mode 100644 index daba9b4c7..000000000 --- a/gfsphysics/physics/cires_ugwp_solvers.F90 +++ /dev/null @@ -1,664 +0,0 @@ -! GW SOLVERS: -!=========== SOLVER_ORODIS; SOLVER_WMSDIS, SOLVER_LSATDIS -! + RF_DAMP if it is needed along with ugwp_tofd -!=========== -! Note in contrast to dycore vertical indices: surface=1 top=levs -! -! Collection of main friction-GWD solvers -! -! subroutine ugwp_oro -! -! subroutine gw_solver_linsatdis -! subroutine gw_solver_wmsdis -! subroutine rf_damp -! -! =========== -! -! - subroutine ugwp_oro(im, levs, dtp, kdt,me, lprnt, fcor, c2f2, & - u, v, tkin, pint, delp, pmid, pexner, gzint, gzmid, orostat, & - hpbl, axz, ayz, edis, kdis, dusfc, dvsfc, & - dusfc_mb, dvsfc_mb, dusfc_ogw, dvsfc_ogw, dusfc_lwb, dvsfc_lwb, & - zmtb, zlwb, zogw, tauf_ogw, tauz_ogw, axmtb, axlwb, axtms ) -!---------------------------------------------------------------------- -! COORDE-output: 6-hour inst: U, V, T, PMSL, PS, HT (ounce) -! 3D 6-hr aver: DYN-U, SSO-U, PBL-U, AF-U1.... -! 2D 6-hr aver: tau_SSO, tau_GWD, tau_BL; & -! tau_sso = tau_mtb + tau_tofd + tau_lwb +tau_ogw -! ZM 6-hr aver: tau_RES = PS*dH/dx -zonal mean -! Experiments: Midlat 80-200km -! LR_CTL; ; LR_NOSSO with TOFD/TMS; -! LR_NOGWD (MTN+TOFD); LR_GWD4 --- 4 times taub -!---------------------------------------------------------------------- - use machine , only : kind_phys - use ugwp_oro_init, only : cdmb, cleff, sigfac, hncrit, hpmin, hminmt - use ugwp_oro_init, only : gamm_std, sigma_std - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - - - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - - implicit none - logical :: lprnt - integer :: im, levs - integer :: me - integer :: kdt - real(kind_phys) :: dtp - real(kind_phys), dimension(im) :: hpbl ! pbl-height in meters - real(kind_phys), dimension(im) :: fcor, c2f2 - real(kind_phys), dimension(im, 14) :: orostat - real(kind_phys), dimension(im, levs) :: u, v, tkin, q - - real(kind_phys), dimension(im, levs) :: pmid, pexner, gzmid, delp - real(kind_phys), dimension(im, levs+1) :: pint, gzint - - - real(kind_phys), dimension(im, levs) :: axz, ayz, edis, kdis ! total 6-hr averaged tendencies - real(kind_phys), dimension(im, levs) :: krf2d - real(kind_phys), dimension(im, levs) :: tauz_ogw, axmtb, axlwb, axtms ! 3-sub components axogw = axz-(axmtb+axlwb+axtms) - real(kind_phys), dimension(im) :: tauf_ogw ! total-source momentum flux - - real(kind_phys), dimension(im) :: zmtb, zlwb, zogw - - real(kind_phys), dimension(im) :: dusfc, dvsfc ! total tausfc_sso - real(kind_phys), dimension(im) :: dusfc_mb, dvsfc_mb ! integrated tau_mtb - real(kind_phys), dimension(im) :: dusfc_ogw, dvsfc_ogw ! integrated tau_ogw - real(kind_phys), dimension(im) :: dusfc_lwb, dvsfc_lwb ! integrated tau_lwb - real(kind_phys), dimension(im) :: dusfc_tofd, dvsfc_tofd ! integrated tau_tofd - -! -! mu=hprime gamm=a/b sigma theta -! which stand for the standard deviation, the anisotropy, the slope and the orientation of the orography. -! - real(kind_phys) :: elvmax(im) - real(kind_phys) :: hprime(im) - - real(kind_phys) :: theta !the orienatation, angle - real(kind_phys) :: sigma !the slope dh/dx - real(kind_phys) :: gamm !the anisotropy see ifs-oro - - real(kind_phys) :: oc, oa4(4), clx4(4) !kim & doyle 2005 .... attempt to do TOFD ..? -! - integer, allocatable :: k_elev(:), k_mtb(:), k_ogw(:), k_lee(:), k_tofd(:) - - real(kind_phys) wk(im) - - real(kind_phys) eng0, eng1 -! -! -! - real(kind_phys), dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid1, pex - - real(kind_phys), dimension(levs+1) :: taudz, rhoi, rim_z, pint1, zpi - real(kind_phys), dimension(levs) :: drtau, kdis_oro -! - real (kind_phys) :: elvp, elvpd, dtaux, dtauy - real(kind_phys) :: loss, mtb_fric, mbx, mby - real(kind_phys) :: sigflt - - real(kind_phys) :: zpbl = 2000. ! can be passed from PBL physics as in gwdps.f -! - logical icrilv(im) -! -!---- mountain/oro gravity wave drag +TOFD -! - real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1, epstofd1, krf_tofd1 -! - real(kind=kind_phys), dimension(levs) :: drlee, drmtb, drlow, drogw - real(kind_phys) :: r_cpdt, acc_lim - real(kind_phys), dimension(im) :: tautot, tauogw, taumtb, taulee, taurf - real(kind_phys) :: xn, yn, umag, kxridge, & - tx1, tx2 - real(kind=kind_phys),dimension(levs+1):: tau_src - - integer :: npt, krefj, kdswj, kotr, i, j, k - integer :: ipt(im) - -! -! copy 1D -! - do i=1, im - hprime(i) = orostat(i, 1) - elvmax(i) = orostat(i, 14) -! - tautot(i) = 0.0 - tauogw(i) = 0.0 - taumtb(i) = 0.0 - taulee(i) = 0.0 - taurf(i) = 0.0 -! - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - dusfc_mb(i) = 0.0 - dvsfc_mb(i) = 0.0 - dusfc_ogw(i) = 0.0 - dvsfc_ogw(i) = 0.0 - dusfc_lwb(i) = 0.0 - dvsfc_lwb(i) = 0.0 - dusfc_tofd(i) = 0.0 - dvsfc_tofd(i) = 0.0 - tauf_ogw(i) = 0.0 -! - zmtb(i) = -99. - zlwb(i) = -99. - zogw(i) = -99. - ipt(i) = 0 - enddo -! print *, maxval(hprime), maxval(elvmax), ' check hprime -elevmax ugwp_oro' -! -! 3-part of oro-effects + ked_oro -! - do k=1, levs - do i=1, im - axz(i,k) = 0.0 - ayz(i,k) = 0.0 - edis(i,k) = 0.0 - kdis(i,k) = 0.0 - krf2d(i,k) = 0.0 - tauz_ogw(i,k) = 0.0 - axmtb(i:,k) = 0.0 - axlwb(i,k) = 0.0 - axtms(i,k) = 0.0 - enddo - enddo - -! -! optional diag 3-parts of drag: [tx_ogw, tx_mtb, tx_lee] -! -! ----do we have orography for mtb and gwd calculation points ? -! - npt = 0 - do i = 1,im - if ( (elvmax(i) > hminmt) .and. (hprime(i) > hpmin) ) then - npt = npt + 1 - ipt(npt) = i - - endif - enddo - if (npt == 0) return ! no ororgraphy ====> gwd/mb calculation done - -! allocate(iwklm(npt), idxzb(npt), kreflm(npt)) - allocate( k_elev(npt), k_mtb(npt), k_ogw(npt), k_lee(npt), k_tofd(npt)) - do i=1,npt - k_ogw (i) = 2 - k_tofd(i) = 2 - k_lee (i) = 2 - k_mtb(i) = 0 - k_elev(i) = 2 - enddo -! -! controls through: use ugwp_oro_init -! main ORO-loop sigfac = n*sigma = [1.5, 2, 2.5, 4]*hprime -! - - - do i = 1, npt -! - j = ipt(i) - - elvpd = elvmax(j) - elvp = min (elvpd + sigfac * hprime(j), hncrit) - - sigma = orostat(j,13) - gamm = orostat(j,12) - theta = orostat(j,11)*deg_to_rad - - if (sigma == 0.0 ) then - sigma = sigma_std - gamm = gamm_std - theta = 0.0 - endif - - oc = orostat(j,2) - oa4(1) = orostat(j,3) - oa4(2) = orostat(j,4) - oa4(3) = orostat(j,5) - oa4(4) = orostat(j,6) - clx4(1) = orostat(j,7) - clx4(2) = orostat(j,8) - clx4(3) = orostat(j,9) - clx4(4) = orostat(j,10) -! -! do column-based diagnostics "more-efficient" for oro-places -! - - do k=1,levs - up(k) = u(j,k) - vp(k) = v(j,k) - tp(k) = tkin(j,k) - qp(k) = q(j,k) - dp(k) = delp(j,k) - - zpm(k) = gzmid(j,k) * rgrav - pmid1(k) = pmid(j,k) - pex(k) = pexner(j,k) - enddo - do k=1,levs+1 - zpi(k) = gzint(j,k) * rgrav - pint1(k) = pint(j,k) - enddo -! -! elvp- k-index: iwklm k_elvp = index for elvmax + 4*hprime, "elevation index" -! GFS-2017 - do k=1, levs-1 - if (elvp <= zpi(k+1) .and. elvp > zpi(k)) then - k_elev(i) = k+1 !......simply k+1 next interface level - exit - endif - enddo -! if (elvp .ge. 300. ) then -! write(6,333) elvp, zpi(1), elvpd, hprime(j), sigfac, hncrit -! pause -! endif -!333 format(6(3x, F10.3)) -! -! SSO effects: TOFD-drag/friction coefficients can be calculated -! - sigflt = hprime(j)*0.01 ! turb SSo(j) ...small-scale orography < 2-5 km .... - zpbl = hpbl(j) - - call ugwp_tofd1d(levs, sigflt, elvPd, zpi(1), zpbl, up, vp, zpm, & - utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1, levs - krf2d(j,k) = krf_tofd1(k) - axtms(j,k) = utofd1(k) -!------- -! nullify ORO-tendencies -! - drmtb(k) = 0.0 - drlee(k) = 0.0 - drtau(k) = 0.0 - drlow(k) = 0.0 - enddo - -!------- -! -! levels of k_mtb(i)/mtb + kdswj/dwlee + krefj/ogwd inside next "subs" -! zmtb, zlwb, zogw -! drmtb, drlow/drlee, drogw -!------- -! -! mtb : drmtb => 1-st order friction as well as TurbulentOro-Drag -! - call ugwp_drag_mtb( k_elev(i), levs, & - elvpd, elvp, hprime(j), sigma, theta, oc, oa4, clx4, gamm, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, k_mtb(i), drmtb, taumtb(j)) - - axmtb(j,1:levs) = drmtb(1:levs)*up(1:levs) -! -! print * , k_elev(i), k_mtb(i) , taumtb(j)*1.e3, ' k_elev, k_mtb , taumtb ' -! -! tautot = taulee+tauogw + rho*drlee = -d[taulee(z)]/dz -! - - - call ugwp_taub_oro(levs, k_mtb(i), kxw, taumtb(j), fcor(j), & - hprime(j) , sigma, theta, oc, oa4, clx4, gamm, elvp, & - up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, xn, yn, umag, & - tautot(j), tauogw(j), taulee(j), drlee, tau_src, & - kxridge, kdswj, krefj, kotr) - -! print *, k_mtb(i), kxw, taumtb(j), fcor(j),hprime(j), ' af ugwp_taub_oro ' -! print *, kdswj, krefj, kotr, ' kdswj, krefj, kotr ' - - - tauf_ogw(j) = tautot(j) - axlwb(j,1:levs) = drlee(1:levs) - - if ( k_mtb(i) > 0) zmtb(j) = zpi(k_mtb(i))- zpi(1) - if ( krefj > 0) zogw(j) = zpi(krefj) - zpi(1) - if ( kdswj > 0) zlwb(j) = zpi(kdswj) - zpi(1) -! if ( k_mtb(i) > 0 .and. zmtb(j) > zogw(j)) print *, ' zmtb > zogw ', zmtb(j), zogw(j) -! -! tau: tauogw, kxw/kxridge ATTENTION c2f2(j) = fcor(j)*fcor(j)/kxridge/kxridge -! - if ( (krefj > 1) .and. ( abs(tauogw(j)) > 0.) ) then -! - call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & - fcor(j), kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & - xn, yn, umag, drtau, kdis_oro) -! - else - drtau = 0. - endif - - tauz_ogw(j,1:levs) = tau_src(1:levs) - - r_cpdt = rcpd2/dtp -! -! - do k = 1,levs -! -! project to x-dir & y=dir and do diagnostics -! & apply limiters and output separate oro-effects -! - drlow(k) = drtau(k) + drlee(k) - acc_lim = min(abs(drlow(k)), max_axyz) - drlow(k) = sign(acc_lim, drlow(k)) - - dtaux = drlow(k) * xn + utofd1(k) - dtauy = drlow(k) * yn + vtofd1(k) - - eng0 = up(k)*up(k)+vp(k)*vp(k) - eng1 = 0.0 -! - if (k < k_mtb(i) .and. drmtb(k) /= 0 ) then - loss = 1.0 / (1.0+drmtb(k)*dtp) - mtb_fric = drmtb(k)*loss -! - mbx = mtb_fric * up(k) - mby = mtb_fric * vp(k) -! - ayz(j,k) = -mby !+ ayz(j,k) - axz(j,k) = -mbx !+ axz(j,k) -! - eng1 = eng0*loss*loss +eng1 - dusfc(j) = dusfc(j) - mbx * dp(k) - dvsfc(j) = dvsfc(j) - mby * dp(k) - endif -! - ayz(j,k) = dtauy + ayz(j,k) - axz(j,k) = dtaux + axz(j,k) -! - tx1 = u(j,k) + dtaux*dtp - tx2 = v(j,k) + dtauy*dtp - eng1 = tx1*tx1 + tx2*tx2 + eng1 - - dusfc(j) = dusfc(j) + dtaux * dp(k) - dvsfc(j) = dvsfc(j) + dtauy * dp(k) - - edis(j,k) = max(eng0-eng1, 0.0) * r_cpdt !+ epstofd1(k) - kdis(j,k) = min(kdis_oro(k), max_kdis ) - - enddo -! - dusfc(j) = -rgrav * dusfc(j) - dvsfc(j) = -rgrav * dvsfc(j) -! -! oro-locations -! - enddo ! ipt - oro-loop .... "fraction of Land" in the grid box - deallocate(k_elev, k_mtb, k_ogw, k_lee, k_tofd ) -! - end subroutine ugwp_oro -! -! - subroutine gw_solver_linsatdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs - integer :: me, kdt, nw, naz, nf_src - real :: dtp - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, & - q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, & - bn2i, bvi, rhoi - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real, dimension(levs+1) :: ked1, tau1 - real :: chm, ss - real, parameter :: dsp = 1./20. - logical :: pfirst=.true. - - save pfirst -128 Format (2x, I4, 4(2x, F10.3)) - -! do i=1, nw -! spf(i) = exp(-Ch(i)*dsp) -! enddo -! ss = sum(spf) -! spf(1:nw) = spf(1:nw)/ss - - if (pfirst ) then - j = 1 - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j) - print * - chm = 0. - do i=1, nw - write(6, 128) i, spf(i), taub_spect(i)*1.e3, ch(i), ch(i)-chm - chm = ch(i) - enddo - - print * - pause - endif - - do j=1,im - if (if_src(j) == 1) then -! -! compute GW-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! H2O-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) * rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k) * rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! - ksrc = klev(j) - taub_spect(1:nw) = spf(1:nw)*taub(j)/rhoi(ksrc) - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' tempi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(u1), minval(u1) , ' ++++ u1 ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(v1), minval(v1) , ' ++++ v1 ' - print *, maxval(pint), minval(pint) , ' pint ' - pause - endif -! - call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, & - ch, xaz, yaz, fcor(j), c2f2(j), dp, & - zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, & - ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - - if (pfirst .and. j ==1 ) then - - print *, maxval(taub_spect)/kxw*bvi(ksrc)/ch(1), ' Urms ' - print *, maxval(zmid), minval(zmid) , ' zmid ' - print *, maxval(zint), minval(zint) , ' zint ' - print *, maxval(rho), minval(rho) , ' rho ' - print *, maxval(rhoi), minval(rhoi) , ' rhoi ' - print *, maxval(ti), minval(ti) , ' rhoi ' - print *, maxval(ui), minval(ui) , ' ui ' - print *, maxval(vi), minval(vi) , ' vi ' - print *, maxval(pint), minval(pint) , ' pint ' - pause - endif -! -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - endif - - enddo - pfirst = .false. -! -! spectral solver for discrete spectra of GWs in N-azimiths -! Linear saturation with background dissipation -! - end subroutine gw_solver_linsatdis -! - subroutine gw_solver_wmsdis(im, levs, dtp, kdt, me, & - taub, klev, if_src, nf_src, nw, ch, naz, spf, xaz, yaz, & - fcor, c2f2, u, v, t, q, prsi, delp, prsl, prslk, phii, phil, & - ax, ay, eps, ked, tauz) -! use para_taub, only : tau_ex - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - use ugwp_common , only : pi, rad_to_deg, deg_to_rad, pi2 - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz, max_eps - use cires_ugwp_module, only : kvg, ktg, krad, kion - - implicit none - integer :: im, levs, me, kdt, nw, naz, nf_src - real :: dtp - - integer, dimension(im) :: klev, if_src - real, dimension(im) :: taub, fcor, c2f2 - - real, dimension(naz) :: xaz, yaz - real, dimension(nw ) :: ch, spf -!========================== - real, dimension(im, levs) :: u, v, t, delp, prsl, prslk, phil, q - real, dimension(im, levs+1) :: prsi , phii -!========================== - real, dimension(im, levs) :: ax, ay, eps, ked, tauz - - real, dimension(levs) :: u1, v1, t1, dp, pmid, zmid, pex1, q1, rho - real, dimension(levs+1) :: pint , zint, ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, ksrc - real, dimension(nw) :: taub_spect -! real, dimension(levs) :: ax1, ay1, eps1 -! real,dimension(levs+1) :: ked1, tau1 - real :: tau_ex - -! print *, nf_src, 'nf_src ... gw_solver_wmsdis ' -! print *, if_src, 'if_src ... gw_solver_wmsdis ' - - do j=1,im - if (if_src(j) == 1) then -! -! compute gw-effects -! prsi, delp, prsl, prslk, phii, phil -! - do k=1,levs - u1(k) = u(j,k) - v1(k) = v(j,k) - t1(k) = t(j,k) - q1(k) = q(j,k) ! h2o-index -1 in tracer-array - dp(k) = delp(j,k) - - zmid(k) = phil(j,k) *rgrav - pmid(k) = prsl(j,k) -! pex1(k) = prslk(j,k) - enddo - do k=1,levs+1 - zint(k) = phii(j,k)*rgrav - pint(k) = prsi(j,k) - enddo - - call mflow_tauz(levs, u1, v1, t1, q1, dp, zmid, zint, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -! -! any extras bkg-arrays -! - ksrc = klev(j) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! more work for spectral setup for different "slopes" -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tau_ex = taub(j) - taub_spect(1:nw) = spf(1:nw)/rhoi(ksrc) *tau_ex ! check it ....*tau_ex(j) - -! -! call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) -! -! print *, ' bf ugwp_wmsdis_naz ksrc', ksrc, zmid(ksrc) - - call ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, tau_ex, ch, xaz, yaz, & - fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, & - rho, ui, vi, ti, kvg, ktg, krad, kion, bn2i, bvi, & - rhoi, ax(j,1:levs), ay(j,1:levs), eps(j,1:levs), & - ked(j,1:levs), tauz(j,1:levs)) -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1, tau1) - -! print *, ' after ugwp_wmsdis_naz ksrc', ksrc, zint(ksrc) - -! subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & -! fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked) - -! ax(j,:) = ax1 -! ay(j,:) = ay1 -! eps(j,:) = eps1 -! ked(j,:) = ked1(1:levs) -! tauz(j,:) = tau1(1:levs) - - endif - - enddo -! -! ugwp_wmsdis_naz everything similar to linsat , except spectral saturation -! -! - return - end subroutine gw_solver_wmsdis -! -! - subroutine rf_damp(im, levs, levs_rf, dtp, rfdis, rfdist, u, v, ax, ay, eps) - use ugwp_common, only : rcpd2 - - implicit none - - integer :: im, levs, levs_rf - real :: dtp - real, dimension(levs) :: rfdis, rfdist - real, dimension(im, levs) :: u, v, ax, ay, eps - real :: ud, vd, rdtp - integer :: i, k - - rdtp = 1.0 / dtp - - do k= levs_rf, levs - do i=1,im - ud = rfdis(k)*u(i,k) - vd = rfdis(k)*u(i,k) - ax(i,k) = rfdist(k)*u(i,k) - ay(i,k) = rfdist(k)*v(i,k) - eps(i,k) = rcpd2*(u(i,k)*u(i,k) +v(i,k)*v(i,k) -ud*ud -vd*vd) - enddo - enddo - end subroutine rf_damp -! diff --git a/gfsphysics/physics/cires_ugwp_triggers.F90 b/gfsphysics/physics/cires_ugwp_triggers.F90 deleted file mode 100644 index 4c03d9c9d..000000000 --- a/gfsphysics/physics/cires_ugwp_triggers.F90 +++ /dev/null @@ -1,562 +0,0 @@ - subroutine ugwp_triggers - implicit none - write(6,*) ' physics-based triggers for UGWP ' - end subroutine ugwp_triggers -! - SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - use ugwp_common , only : deg_to_rad - - implicit none - integer :: nx, ny - real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - real :: earth_r, ra1, ra2, dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - integer :: j -! -! specify common constants and -! geometric factors to compute deriv-es etc ... -! coriolis coslat tan etc... -! - earth_r = 6370.e3 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 -! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) -! - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo -! - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos -! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) - - dlat = ra1 / (dy+dy) - - divJp = dlat*cosv - divJM = dlat*cosv -! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) -! - return - end SUBROUTINE subs_diag_geo -! - subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! compute for each Vert-column: grad(V) -! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Vx(nx, ny), Vy(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) - - end subroutine get_xy_pt - - subroutine get_xyd_wind( V, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) -! -! compute for each Vert-column: grad(V) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - implicit none - integer :: nx, ny - real :: V(nx, ny), dlam1(ny), dlat - real :: Divjp(ny), Divjm(ny) - real :: Vx(nx, ny), Vy(nx, ny), Vyd(nx, ny) - integer :: i, j - do i=2, nx-1 - Vx(i,:) = dlam1(:)*(V(i+1,:)-V(i-1,:)) - enddo - Vx(1,:) = dlam1(:)*(V(2,:)-V(nx,:)) - Vx(nx,:) = dlam1(:)*(V(1,:)-V(nx-1,:)) - - do j=2, ny-1 - Vy(:,j) = dlat*(V(:,j+1)-V(:, j-1)) - enddo - Vy(:, 1) = dlat*2.*(V(:,2)-V(:,1)) - Vy(:,ny) = dlat*2.*(V(:,ny)-V(:,ny-1)) -!~~~~~~~~~~~~~~~~~~~~ -! 1/cos*d(vcos)/dy -!~~~~~~~~~~~~~~~~~~~~ - do j=2, ny-1 - Vyd(:,j) = divJP(j)*V(:,j+1)-V(:, j-1)*divJM(j) - enddo - Vyd(:, 1) = Vyd(:,2) - Vyd(:,ny) = Vyd(:,ny-1) - - end subroutine get_xyd_wind - - subroutine trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_fgf -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_fgf(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - - enddo - end subroutine trig3d_fjets - - subroutine trig3d_okubo( nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_okw) - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_okw -! -! locals -! - real, dimension(nx, ny) :: ux, uy, uyd, vy, vx, vyd, ptx, pty - integer :: k, i, j - - real, parameter :: cappa=2./7., pref=1.e5 - real, dimension(nx, ny) :: pt, w1, w2, d1 - - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) - - real :: dx, dy, dlat - real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) - - call subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & - cosv, rlatc, brcos, brcos2, dlam1, dlam2, dlat, divJp, divJm) - - do k=1, nz - w1(:,:) = P3d(:,:,k) - w2(:,:) = T(:,:,k) - - pt = w2*(pref/w1)**cappa - call get_xy_pt(Pt, ptx, pty, nx, ny, dlam1, dlat) - w1(:,:) = V(:,:, K) - call get_xyd_wind( w1, Vx, Vy, Vyd, nx, ny, dlam1, dlat, divJp, divJm) - w1(:,:) = U(:,:, K) - call get_xyd_wind( w1, Ux, Uy, Uyd, nx, ny, dlam1, dlat, divJp, divJm) - - trig3d_okw(:,:,k) = -ptx*ptx*ux - pty*pty*vy -(vx+uyd)*ptx*pty - w1 = (Ux -Vy)*(Ux-Vy) + (Vx +Uy)*(Vx+Uy) ! S2 - W2 = (Vx - Uyd)*(Vx - Uyd) - D1 = Ux + Vyd - trig3d_okw(:,:,k) = W1 -W2 -! trig3d_okw(:, :, k) =S2 -W2 -! trig3d_okw(:, :, k) =D1*D1 + 4*(Vx*Uyd -Ux*Vyd) ! ocean -! trig3d_okw(:, :, k) = trig3d_okw(:,:,k) + D1*D1 + 2.*D1*sqrt(abs(W1-W2)) ! S2 =W1Ted-luk - enddo - end subroutine trig3d_okubo -! - subroutine trig3d_dconv(nx, ny, nz, U, V, T, Q, P3d, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS - real, dimension(nx, ny, nz) :: trig3d_conv - - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - integer :: k - end subroutine trig3d_dconv - - subroutine cires_3d_triggers( nx, ny, nz, lon, lat, pmid, & - U, V, W, T, Q, delp, delz, p3d, PS, HS, Hyam, Hybm, Hyai, Hybi, & - trig3d_okw, trig3d_fgf, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) - - implicit none - integer :: nx, ny, nz - real :: lon(nx), lat(ny) -! -! reversed ??? Hyai, Hybi , pmid -! - real, dimension(nz+2) :: Hyai, Hybi - real, dimension(nz+1) :: Hyam, Hybm -! - real, dimension(nz) :: pmid - real, dimension(nx, ny, nz) :: U, V, W, T, Q, delp, delz, p3d - real, dimension(nx, ny ) :: PS, HS - real, dimension(nx, ny, nz) :: trig3d_okw, trig3d_fgf, trig3d_conv - real, dimension(nx, ny, nz) :: dcheat3d, scheat3d - real, dimension(nx, ny ) :: precip2d - integer,dimension(nx, ny, 3 ):: cld_klevs2d - real :: dzkm, zkm - integer :: k -!================================================================================== -! fgf and OW-triggers -! read PRECIP + SH/DC conv heating + cloud-top-bot-middle from "separate" file !!! -! -!=================================================================================== - - call trig3d_fjets( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_fgf) - call trig3d_okubo( nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_okw) - call trig3d_dconv(nx, ny, nz, U, V, T, Q, P3D, PS, delp, delz, lon, lat, pmid, trig3d_conv, & - dcheat3d, precip2d, cld_klevs2d, scheat3d) -!===================================================================================================== -! output of triggers: trig3d_fgf, trig3d_okw, trig3d_conv, cheat3d, precip2d, cld_klevs2d, scheat3d -! -! Bulk momentum flux=/ 0 and levels for launches -! -!===================================================================================================== - 111 format(i6, 4(3x, F8.3), ' trigger-grid ') - - do k=1, nz-1 - zkm = -7.*alog(pmid(k)*1.e-3) - dzkm = zkm +7.*alog(pmid(k+1)*1.e-3) - write(6,111) k, hybi(k), pmid(k), zkm, dzkm !' triggers ' - enddo - - end subroutine cires_3d_triggers -!================================================================================== -! tot-flux launch 0 or 1 # of Launches -! specify time-dep bulk sources: taub, klev, if_src, nf_src -! -!================================================================================== - subroutine get_spectra_tau_convgw & - (nw, im, levs, dcheat, scheat, precip, icld, xlatd, sinlat, coslat,taub, klev, if_src, nf_src) -! -! temporarily can put GEOS-5/MERRA-2 GW-lat dependent function -! - integer :: nw, im, levs - integer,dimension(im,3) :: icld - real, dimension(im, levs) :: dcheat, scheat - real, dimension(im) :: precip, xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! -! locals - real, parameter :: precip_max = 100. ! mm/day - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - - integer :: i, k, klow, ktop, kmid - real :: dtot, dmax, daver -! - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - do i=1, im - klow = icld(i,1) - ktop = icld(i,2) - kmid= icld(i,3) - if (klow == -99 .and. ktop == -99) then - cycle - else - klev(i) = ktop - k = klow - klev(i) = k - dmax = abs(dcheat(i,k) + scheat(i,k)) - do k=klow+1, ktop - dtot =abs(dcheat(i,k) + scheat(i,k)) - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! -! klev as max( dcheat(i,k) + scheat) -! vertical width of conv-heating -! -! counts/triiger=1 & taub(i) -! - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_amp* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! 100 mb launch and MERRA-2 slat-forcing -! - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo - -! with info on precip/clouds/dc_heat create Bulk -! taub(im), klev(im) -! -! print *, ' get_spectra_tau_convgw ' - end subroutine get_spectra_tau_convgw -! - subroutine get_spectra_tau_nstgw(nw, im, levs, trig_fgf, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_fgf -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_fgf = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1.0 / float(kwidth) - tau_min = tau_amp*fnorm - do i=1, im -! -! only trop-c fjets so find max(trig_fgf) => klev -! use abs-values to scale tau_amp -! - - k = klow - klev(i) = k - dmax = abs(trig_fgf(i,k)) - kex = 0 - if (dmax >= tlim_fgf) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_fgf(i,k)) - if (dtot >= tlim_fgf) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo - - if (dmax .ge. tlim_fgf) then - nf_src = nf_src +1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo -! -! print *, ' get_spectra_tau_nstgw ' - call Slat_geos5(im, xlatd, taub) - nf_src =im - do i=1, im - if_src(i) = 1 - klev(i) = 127-45 - enddo -! - end subroutine get_spectra_tau_nstgw -! - subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, taub, klev, if_src, nf_src) - integer :: nw, im, levs - real, dimension(im, levs) :: trig_okw -! real, dimension(im, levs+1) :: pint - real, dimension(im) :: xlatd, sinlat, coslat - real, dimension(im) :: taub - integer, dimension(im) :: klev, if_src - integer :: nf_src -! locals - real, parameter :: tlim_okw = 100. ! trig_fgf > tlim_fgf, launch waves should scale-dependent - real, parameter :: tau_amp = 35.e-3 ! 35 mPa - real, parameter :: pmax = 750.e2, pmin = 100.e2 - integer, parameter :: klow =127-92, ktop=127-45 - integer, parameter :: kwidth = ktop-klow+1 - integer :: i, k, kex - real :: dtot, dmax, daver - real :: fnorm, tau_min - - nf_src = 0 - if_src(1:im) = 0 - taub(1:im) = 0.0 - fnorm = 1./float(kwidth) - tau_min = tau_amp*fnorm - print *, ' get_spectra_tau_okwgw ' - do i=1, im - k = klow - klev(i) = k - dmax = abs(trig_okw(i,k)) - kex = 0 - if (dmax >= tlim_okw) kex = kex+1 - do k=klow+1, ktop - dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 - if ( dtot > dmax) then - klev(i) = k - dmax = dtot - endif - enddo -! - if (dmax >= tlim_okw) then - nf_src = nf_src + 1 - if_src(i) = 1 - taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) - endif - - enddo - print *, ' get_spectra_tau_okwgw ' - end subroutine get_spectra_tau_okw -! -! -! - subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: tau_amp, xlatdeg(im), tau_gw(im) - real :: latdeg, flat_gw, tem - integer :: i - -! -! if-lat -! - do i=1, im - latdeg = abs(xlatdeg(i)) - if (latdeg < 15.3) then - tem = (latdeg-3.0) / 8.0 - flat_gw = 0.75 * exp(-tem * tem) - if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 - elseif (latdeg < 31.0 .and. latdeg >= 15.3) then - flat_gw = 0.10 - elseif (latdeg < 60.0 .and. latdeg >= 31.0) then - tem = (latdeg-60.0) / 23.0 - flat_gw = 0.50 * exp(- tem * tem) - elseif (latdeg >= 60.0) then - tem = (latdeg-60.0) / 70.0 - flat_gw = 0.50 * exp(- tem * tem) - endif - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5_tamp - - subroutine slat_geos5(im, xlatdeg, tau_gw) -!================= -! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* -!================= - implicit none - integer :: im - real :: xlatdeg(im) - real :: tau_gw(im) - real :: latdeg - real, parameter :: tau_amp = 100.e-3 - real :: trop_gw, flat_gw - integer :: i -! -! if-lat -! - trop_gw = 0.75 - do i=1, im - latdeg = xlatdeg(i) - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) - if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then - flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - tau_gw(i) = tau_amp*flat_gw - enddo -! - end subroutine slat_geos5 - subroutine init_nazdir(naz, xaz, yaz) - use ugwp_common , only : pi2 - implicit none - integer :: naz - real, dimension(naz) :: xaz, yaz - integer :: idir - real :: phic, drad - drad = pi2/float(naz) - if (naz.ne.4) then - do idir =1, naz - Phic = drad*(float(idir)-1.0) - xaz(idir) = cos(Phic) - yaz(idir) = sin(Phic) - enddo - else -! if (naz.eq.4) then - xaz(1) = 1.0 !E - yaz(1) = 0.0 - xaz(2) = 0.0 - yaz(2) = 1.0 !N - xaz(3) =-1.0 !W - yaz(3) = 0.0 - xaz(4) = 0.0 - yaz(4) =-1.0 !S - endif - end subroutine init_nazdir diff --git a/gfsphysics/physics/cires_ugwp_utils.F90 b/gfsphysics/physics/cires_ugwp_utils.F90 deleted file mode 100644 index 63a5b3238..000000000 --- a/gfsphysics/physics/cires_ugwp_utils.F90 +++ /dev/null @@ -1,152 +0,0 @@ -! - subroutine um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, bn2, uhm, vhm, bn2hm, rhohm) -! - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - implicit none -! -! mass-averaged variables between klow-ktop -! - integer, intent(in) :: nz, klow, ktop - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: pint, zpi - real, dimension(nz), intent(out) :: bn2 - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp, rhm,dphm - - real, intent(out) :: uhm, vhm, bn2hm, rhohm - - integer :: k -! - dphm = 0.0 !pint(k+1)-pint(k)) - - uhm = 0.0 ! dphm*u1(k) - vhm = 0.0 ! dphm*v1(k) - rhm = 0.0 ! - bn2hm = 0.0 ! -! - do k=klow, ktop - vtj = tp(k) * (1.+fv*qp(k)) - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rhok = rdi * pmid(k) / vtj ! density kg/m**3 - rdz = 1.0 / (zpm(k+1)-zpm(k)) -! dry -! bnv2 = grav * (rdz * ( tp(k+1)-tp(k)) +grcp) /tp(k) -! -! wet -! - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtk -! if (bnv2 < 0) print *, k, bnv2, ' bnv2 < 0 ', klow, ktop - bnv2 = max(bnv2, bnv2min ) - dzp = pint(k+1)-pint(k) - - dphm = dphm + dzp - uhm = uhm + up(k)*dzp - vhm = vhm + vp(k)*dzp - rhm = rhm + rhok*dzp - bn2hm = bn2hm + bnv2 * dzp - bn2(k) = bnv2 - enddo - - uhm = uhm/dphm - vhm = vhm/dphm - rhm = rhm/dphm - bn2hm = bn2hm/dphm - rhohm = rhm/dphm -! -! print *, ' MF-BV ', bn2hm, bn2(ktop), bn2(klow) -! - end subroutine um_flow -! -! - subroutine mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - use ugwp_common, only : bnv2min, grav, gocp, fv, rdi - - implicit none - - integer :: levs - real, dimension(levs) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(levs+1) :: pint, rho, zpi - real, dimension(levs) :: zdelpi, zdelpm - real :: zul, bvl - real, dimension(levs+1) :: ui, vi, bn2i, bvi, rhoi, ti, qi - - real :: vtj, rhok, bnv2, rdz - real :: vtkp, vtk, dzp - real :: vtji - integer :: k -! -! get interface values from surf to top -! - do k=2,levs - vi(k) = 0.5 *(vp(k-1) + vp(k)) - ui(k) = 0.5 *(up(k-1) + up(k)) - ti(k) = 0.5 *(tp(k-1) + tp(k)) - qi(k) = 0.5 *(qp(k-1) + qp(k)) - enddo - - k=1 - ti(k) = tp(k) - ui(k) = up(k) - vi(k) = vp(k) - qi(k) = qp(k) - k= levs - ti(k+1) = tp(k) - ui(k+1) = up(k) - vi(k+1) = vp(k) - qi(k+1)=qp(k) - - do k=1,levs-1 - vtj = tp(k) * (1.+fv*qp(k)) - vtji = ti(k) * (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj ! density kg/m**3 - rhoi(k) = rdi * pint(k) / vtji - vtk = vtj - vtkp = tp(k+1) * (1.+fv*qp(k+1)) - rdz = 1. / ( zpm(k+1)-zpm(k)) - bnv2 = grav * (rdz * ( vtkp- vtk) +gocp) /vtji - bn2i(k) = max(bnv2, bnv2min ) - bvi(k) = sqrt( bn2i(k) ) - vtk = vtkp - enddo - k = levs - vtj = tp(k) ! * (1.+fv*qp(k)) - vtji = ti(k) !* (1.+fv*qi(k)) - rho(k) = rdi * pmid(k) / vtj - rhoi(k) = rdi * pint(k) / vtji - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) - k = levs+1 - rhoi(k) = rdi * pint(k) / ti(k) - bn2i(k) = bn2i(k-1) - bvi(k) = sqrt( bn2i(k) ) -! do k=1,levs -! write(6, 121) k, zpm(k)*1.e-3, zpi(k)*1.e-3, bvi(k), rho(k), rhoi(k) -! enddo - 121 format(i5, 2x, 3(2x, F10.3), 2(2x, E10.3)) - - end subroutine mflow_tauz - -! - subroutine get_unit_vector(u, v, u_n, v_n, mag) - implicit none - real, intent(in) :: u, v - real, intent(out) :: u_n, v_n, mag -! - - mag = sqrt(u*u + v*v) - - if (mag > 0.0) then - u_n = u/mag - v_n = v/mag - else - u_n = 0. - v_n = 0. - end if - - end subroutine get_unit_vector -! diff --git a/gfsphysics/physics/cires_vert_lsatdis.F90 b/gfsphysics/physics/cires_vert_lsatdis.F90 deleted file mode 100644 index a44b8dde0..000000000 --- a/gfsphysics/physics/cires_vert_lsatdis.F90 +++ /dev/null @@ -1,524 +0,0 @@ - subroutine ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! call ugwp_lsatdis_naz(levs, ksrc, nw, naz, kxw, taub_spect, ch, xaz, yaz, & -! fcor(j), c2f2(j), dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & -! kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax1, ay1, eps1, ked1) - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs, nw, naz, ksrc - real :: kxw - real, dimension(nw) :: taub_spect, ch - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - - real, dimension(levs+1 ) :: uaz - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - real, dimension(levs+1 ) :: taux, tauy - real, dimension(levs ) :: dzirho , dzpi - real :: usrc -! - integer :: iaz, k -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - - do k=1,levs - dzpi(k) = -(pint(k+1)-pint(k))/rho(k)*rgrav - dzirho(k) = 1./rho(k)/dzpi(k) ! grav/abs(dp(k)) still hydrostatic "UGWP" - enddo - - LOOP_IAZ: do iaz =1, naz - usrc = ui(ksrc)*xaz(iaz) +vi(ksrc)*yaz(iaz) - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) -usrc - enddo -! -! if (nw .le. 4) call stochastic ..ugwp_lsatdis_az1 only 4-waves ch_ngw1, fuw_ngw1, eff_ngw1=1 -! -! multi-wave scheme -! - if (nw .gt. 4) then - call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & - fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - endif -! - ENDDO LOOP_IAZ ! Azimuth of GW propagation directions -! -! sum over azimuth and project aTau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum(kedd(k,:)) - enddo - - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) -! -! end solver: gw_azimuth_solver_LS81 -! sign Ax in rho*dU/dt = -d(rho*tau)/dz -! [(k) - (k+1)] - ax =0. ; ay = 0. - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - return - -! - print * - print *, ' Ax: ', maxval(Ax(ksrc:levs))*86400., minval(Ax(ksrc:levs))*86400. - print *, ' Ay: ', maxval(Ay(ksrc:levs))*86400., minval(Ay(ksrc:levs))*86400. - print *, 'Eps: ', maxval(Eps(ksrc:levs))*86400., minval(Eps(ksrc:levs))*86400. - print *, 'Ked: ', maxval(Ked(ksrc:levs))*1., minval(Ked(ksrc:levs))*1. -! print *, 'Atau ', maxval(atau(ksrc:levs, 1:Naz))*1.e3, minval(atau(ksrc:levs, 1:Naz))*1.e3 -! print *, 'taux_gw: ', maxval(taux( ksrc:levs))*1.e3, minval(taux( ksrc:levs))*1.e3 - print * -!----------------------------------------------------------------------- -! Here we can apply "ad-hoc" or/and "stability-based" limiters on -! (axy_gw, ked_gw and eps_gw) and check vert-inegrated conservation laws: -! energy and momentum and after that => final update gw-phys tendencies -!----------------------------------------------------------------------- - - end subroutine ugwp_lsatdis_naz -! - subroutine ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_sp, & - fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) - -! call ugwp_lsatdis_az1(levs, ksrc, nw, kxw, ch, taub_spect, & -! fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, dzirho, dzpi, & -! kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - - use cires_ugwp_module, only : F_coriol, F_nonhyd, F_kds, linsat, linsat2 - use cires_ugwp_module, only : iPr_ktgw, iPr_spgw, iPr_turb, iPr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! - implicit NONE -! - integer, intent(in) :: nw ! number of GW modes in given direction - integer, intent(in) :: levs ! vertical layers - integer, intent(in) :: ksrc ! level of GW-launch layer - - real , intent(in) :: kxw ! horizontal wavelength - real , intent(in) :: ch(nw) ! horizontal phase velocities - real , intent(in) :: taub_sp(nw) ! spectral distribution of the mom-flux -! - real, intent(in) :: fcor, c2f2 ! Corilois factors - - real , intent(in) :: um(levs+1) - real , intent(in) :: tm(levs+1) -!in - real, intent(in), dimension(levs) :: rho, zm - real, intent(in), dimension(levs+1) :: rhoi, zi - real, intent(in), dimension(levs+1) :: bn2, bn - real, intent(in), dimension(levs) :: dzpi, dzirho - real, intent(in), dimension(levs+1) :: kvg, ktg, krad, kion, kmol -!======================================================================== -!out - real, dimension(levs+1) :: tau, ked - real, dimension(levs) :: eps - -!========================================================================= -!local - real :: Fd1, Fd2 - real, dimension(levs) :: a_mkz - real, dimension(levs+1,nw) :: sp_tau, sp_ked, sp_kth - real, dimension(levs,nw) :: sp_eps - - real, dimension(levs,nw) :: sp_mkz, sp_etot - real, dimension(levs,nw) :: sp_ek, sp_ep - - - real, dimension(levs) :: swg_ep, swg_ek, swg_et, swg_kz - - real, dimension(nw) :: rtaus ! spectral distribution at ksrc - real :: sum_rtaus ! total flux in iaz-azimuth - real :: Chnorm, Cx, Cs, Cxs, Cx2sat - real :: Fdis, Fdisat - real :: Cdf2, Cdf1 ! (Cd*cd-f*f) and sqrt -! -! two-level => upward integration for wave-filtering (dissip + breaking) -! - real :: taus, tauk, tau_lin - real :: etws, etwk, etw_lin - real :: epss, epsk - real :: kds, kdk - real :: kzw, kzw2, kzw3, kzi, kzs - real :: wfd, wfi ! -! -! for GW dissipation on the rotational sphere -! - real :: Betadis ! Ep/Ek ratio - real :: BetaM, BetaT ! 0.5 or 1./1+b and 1-1/(1+b) - real :: wfdM, wfdT, wfiM, wfiT, wdop2 - - real :: dzi, keff, keff_m, keff_t, keffs - - real :: sf2k2, cf2 - real :: Lzkm, Lzsat - - integer :: i, k, igw - integer :: ksat1, ksat2 - - real :: zsat1, zsat2 - real :: kx2_nh - - real :: rab1, rab2, rab3, rab4, cd_ulim2 - - integer :: Ind_out(nw, levs+1) - -! - logical, parameter :: dbg_print = .false. -! -!=================================================================== -! Nullify arrays -! tau, eps, ked -!==================================================================== - - tau = 0.0 - eps = 0.0 - ked = 0.0 - Ind_out(1:nw,:) = 0 -! -! GW-spectral arrays ..... sp_etot ....sp_tau -! - sp_tau = 0. - sp_eps = 0. - sp_ked = 0. - sp_mkz = -99. - sp_etot = 0. - sp_ek = 0. - sp_ep = 0. - sp_kth = 0. -! - swg_et = 0. - swg_ep = 0. - swg_ek = 0. - swg_kz = 0. - cd_ulim2 = cd_ulim*cd_ulim - cf2 = F_coriol*c2f2 - kx2_nh = F_nonhyd*kxw*kxw - - if (dbg_print) then - write(6,*) linsat , ' eff-linsat & kx ', kxw - write(6,*) maxval(ch), minval(ch), ' ch ' - write(6,*) - write(6,*) maxval(rhoi), minval(rhoi), 'rhoi ' - write(6,*) zi(ksrc) , ' zi(ksrc) ' - write(6,*) cd_ulim, ' crit-level cd_ulim ' - write(6,*) F_coriol, ' F_coriol' - write(6,*) F_nonhyd, ' F_nonhyd ' - write(6,*) maxval(Bn), minval(BN), ' BN-BV ' - write(6,*) Um(ksrc), ' Um-ksrc ', cd_ulim2 , 'cd_ulim2 ', c2f2, ' c2f2 ' - pause - endif - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Loop_GW: over GW-spectra -! of individual non-interactive modes -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - Loop_GW: do i=1, nw -! - Kds = 0.0 -! -! src-level -! - Cx = ch(i) - Um(ksrc) - Cdf2 = Cx*Cx - cf2 - taus = taub_sp(i) ! momentum flux for i-mode w/o rhoi(ksrc) - kzw = Bn(ksrc) / Ch(i) ! ch(i) > 0. Cx(i) < 0. critica - etws = taus*kzw / kxw - rtaus(i) = taus*rhoi(ksrc) -! - IF( Cx <= cd_ulim .or. Cdf2 <= cd_ulim2) THEN - Ind_out(i, ksrc) =-1 ! -1 - diagnostic index for critical levels - cycle Loop_GW ! got to the next mode of GW-spectra - ELSE -! - kzw2 = Bn2(ksrc)/Cdf2 - rhp4 - kx2_nh -! - if (kzw2 <= 0.) then - Ind_out(i, ksrc) =-2 ! -2 - diagnostic index for reflected waves - cycle Loop_GW ! no wave reflection in GW-LSD scheme - endif - - kzw = sqrt(kzw2) - kzw3 = kzw2*kzw - etws = taus*kzw/kxw -! -! Here Linsat == Fr_critical -! - Cx2sat = Linsat2*Cdf2 - if (etws >= cx2sat) then - Kds = kxw*Cx*rhp2/kzw3 - etws = cx2sat - taus = etws*kxw/kzw - Ind_out(i, ksrc) =-3 ! -3 - dignostic index for saturated waves - endif -! - betadis = cdf2/(Cx*Cx+cf2) - betaM = 1.0 /(1.0+betadis) - betaT = 1.0 - BetaM -! - Cxs = Cx - kzs = kzw -! keffs = (kvg(ksrc)+kds)*iPr_turb*.5*khp -! sp_kth(ksrc, i) = rhoi(ksrc)*keffs*(Tm(ksrc)+Tm(ksrc-1)) - rtaus(i) = taus*rhoi(ksrc) - sp_tau(ksrc, i) = rtaus(i) - sp_etot(ksrc, i) = etws - sp_mkz(ksrc, i) = kzw - sp_ek(ksrc, i) = etws*betam - sp_ep(ksrc, i) = etws*betaT ! can be transferred to (T'**2) T-rms - -! - ENDIF ! vertical propagation of i-mode to the next upper layer = (ksrc+1) -! -! Loop_Zint .................................. VERTICAL "INTERFACE" LOOP from ksrc => ktop_GW -! - Loop_Zi: do k=ksrc+1, levs -! - Cx = ch(i)-Um(k) ! Um(k) is defined at the interface pressure levels - Cdf2 = Cx*Cx -cf2 - if( Cx <= cd_ulim .or. Cdf2 <= 0.) then - Ind_out(i, k) =-1 ! 1 - diagnostic index for critical levels - ! print*,'crit level C-U ',int(Cx),int(sqrt(cf2)),' Um ',Um(k) - cycle Loop_GW - endif - - cdf1 =sqrt(Cdf2) - wdop2 = (kxw*Cx)* (kxw*Cx) - kzw2 = (Bn2(k)-wdop2)/Cdf2 - rhp4 - kx2_nh ! full lin DS-NIGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) - - if (kzw2 < 0.) then - Ind_out(i, k) =-2 ! 2 - diagnostic index for reflected waves - cycle Loop_GW - endif - kzw = sqrt(kzw2) - kzw3 =kzw2*kzw -! - keff_m = kvg(k)*kzw2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*kzw2 + krad(k) -! -! - betadis = cdf2 / (Cx*Cx+cf2) - betaM = 1.0 / (1.0+betadis) - betaT = 1.0 - BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*kzw2*F_kds + keff_m - wfiT = kds*iPr_ktgw*F_kds * kzw2 + keff_t -! - wfdM = wfiM/(kxw*Cdf1)*BetaM - wfdT = wfiT/(kxw*Cx)*BetaT -! exp-l: "kzi*dz" - kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) ! 2-factor energy-momentum (U')^2 -!------------------------------------------------------- -! dissipative factor: Fdis -! we can replace WKB-solver by Numerical integration of -! tau_gw == etot_gw/kzw*kxw -! d(rho*tau_gw) = -kdis*rho*tau_gw -! |tau_gw| <= |tau_gwsat| -! linear limit for single mode -! generalization for the "broad" spectra -! or treating single mode breaking -! over finite "vertical"-depth with "efficiency" -! Now: time-step + hor-l scale -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Fdis = exp(-kzi) -! -! -! dissipative "wave rms" by WKB -! - etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*kzw/kzs -! - Cx2sat = Linsat2*Cdf2 -! -! Linear saturation -! - if (etwk.ge.cx2sat) then - - Ind_out(i, k) =-3 ! 3 - dignostic index for saturated waves -! ! saturate energy and "trigger" keddy - etw_lin = etwk - etwk = cx2sat - Kds = kxw*Cdf1*rhp2/kzw3 - tauk = etwk*kxw/kzw - -!=================================================================================== -! WAM/case with high Kds tau_lin = (etw_lin-etwk)*kxw/kzw !tau_loss by sat theory -! Lzsat = 6,28/kzw Zsat1 = Zi(k)-.5*Lzsat -! Zsat2 = Zi(k)+.5*Lzsat -! in WAM triggering from "kds = 0 m2/s" => "200 m2/s" for Lzw ~ 10 km -! -! call sat_domain(zi, Zsat1, Zsat2, pver, ksat1, ksat2) -! -! to avoid it do the new diss-n factor with eddy "kds" added to the -! background keff_m and keff_t -! -! can be taken out for the strato-mesosphere in GFS -! wfiM = kds*kzw2 + keff_m -! wfiT = kds*iPr_ktgw * kzw2 +keff_t -! wfdM = wfiM/(kxw*Cdf1)*BetaM -! wfdT = wfiT/(kxw*Cx)*BetaT -! kzi = 2.*kzw*(wfdM+wfdT)*dzpi(k) -! Fdisat = exp(-kzi) -! etwk = etws*rhoi(k-1)/rhoi(k)*Fdis*(kzw/Kzs) -! updated breaking in the Lzsat-domain: zsat1 < zi < zsat2 -! ================================================================================= - else - kds = 0.0 - tauk = etwk*kxw/kzw ! = Ekin*kx/kz - ENDIF -!-------------------------------------- -! -! Fill in spectral arrays(levs, nw) -! -!-------------------------------------- - sp_ked(k,i) = kds ! defined at interfaces - sp_tau(k, i) = tauk*rhoi(k) ! defined at interfaces - -! keff = (kds + kvg(k))*iPr_turb*0.5*KHP -! sp_kth(k, i) = rhoi(k)*keff*(Tm(k)+Tm(k-1)) ! defined at mid-layers - - sp_etot(k, i) = etwk ! defined at interfaces - sp_mkz(k, i) = kzw ! defined at interfaces - sp_ek(k, i) = etwk*betam ! defined at interfaces - sp_ep(k, i) = etwk*betaT ! can be transferred to (T'**2) -! -! - if (sp_tau(k,i) > sp_tau(k-1,i)) then - sp_tau(k,i) = sp_tau(k-1,i) ! prevent "possible" numerical "noise" - endif -! -! updates for "eps and keff" from -! - rab1 =.5*(cx+cxs)*dzirho(k) -! heating -! due to wave dissipation -! - sp_eps(k,i) = rab1*(sp_tau(k-1,i)- sp_tau(k,i)) ! defined at mid-layers -! -! cooling term due to eddy heat conduction =0 if Keff_cond =>0, -! usually updated by 1D-heat implict tridiagonal solver -! explicit local solver ---->sp_kth(k,i) = Kt*(dT/dz+ R/Cp*T/Hp~>g/cp) -! -! sp_eps(k,i)=sp_eps(k,i)+dzirho(k)*(sp_kth(k,i)- sp_kth(k-1,i)) -! - kzs = kzw - cxs = cX - taus = tauk - etws = etwk -! keffs = keff - - enddo Loop_Zi ! ++++++++++++++ vertical layer -! -! ................................! stop ' in solver single-mode' -! - enddo Loop_GW ! i-mode of GW-spectra -! - sum_rtaus =sum(rtaus) ! total momentum flux at k=ksrc - -! print *, sum_rtaus, ' tau-src ', nint(zi(ksrc)*1.e-3) -! print *, maxval(ch), minval(ch), ' Ch ', ngwv, ' N-modes ' -! -!============================================================================== -! Perform spectral integartion (sum) & apply "efficiency/inremittency" factors -! -! eff_factor: ~ 1./[number of modes in 1-direction of model columns] -! -!============================================================================== - do k=ksrc, levs - - ked(k) =0. - Eps(k) = 0. - Tau(k) = 0. - swg_et(k) =0. - swg_ep(k) =0. - swg_ek(k) =0. - - do i=1,nw - Ked(k) = Ked(k)+sp_ked(k,i) - Eps(k) = Eps(k)+sp_eps(k,i) - Tau(k) = Tau(k)+sp_tau(k,i) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! GW-energy + GW-en flux ~ Cgz*E, diagnostics-only -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - swg_et(k) = swg_et(k)+sp_etot(k,i) !*eff_fact - swg_ep(k) = swg_ep(k)+sp_ep(k,i) !*eff_fact - swg_ek(k) = swg_ek(k)+sp_ek(k,i) !*eff_fact - enddo - - enddo -! fill in below the "source" level ..... [1:ksrc-1] -! - do k=1, ksrc-1 -! no loss of the total momentum flux - ked(k) =0. - eps(k) = 0. - tau(k) = tau(ksrc) -! lin-theory diagnostics-only - swg_et(k) =swg_et(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ep(k) =swg_ep(ksrc)*rhoi(ksrc)/rhoi(k) - swg_ek(k) =swg_ek(ksrc)*rhoi(ksrc)/rhoi(k) - enddo -! - RETURN -! -! diagnostics below -! -345 FORMAT(2x, F8.2, 4(2x, F10.3), 2x, F8.2) - if (dbg_print) then - print * - print *, ' Zkm EK m2/s2 Ked m2/s Eps m2/s3 tau-Mpa ' - do k=ksrc, levs -! Fd1 = maxval(Fdis_modes(1:nw,k)) -! Fd2 = minval(Fdis_modes(1:nw,k)) - write(6, 345) Zi(k)*1.e-3, sqrt(swg_ek(k)), Ked(k), Eps(k), Tau(k)*1.e3, Um(k) !, Fd1, Fd2 - enddo - print * - write(6,*) nw , ' nwaves-linsat ' - write(6,*) maxval(sp_ked), minval(sp_ked), 'ked ' - write(6,*) maxval(sp_tau), minval(sp_tau), 'sp_tau ' - pause - endif - -! - end subroutine ugwp_lsatdis_az1 -! - subroutine ugwp_limit_1d(ax, ay,eps, ked, levs) - use cires_ugwp_module, only : max_kdis, max_eps, max_axyz - implicit none - integer :: levs - real, dimension(levs) :: ax, ay,eps - real, dimension(levs+1) :: ked - real, parameter :: xtiny = 1.e-30 - where (abs(ax) > max_axyz ) ax = ax/abs(ax+xtiny)*max_axyz - where (abs(ay) > max_axyz ) ay = ay/abs(ay+xtiny)*max_axyz - where (abs(eps) > max_eps ) eps = eps/abs(eps+xtiny)*max_eps - where (ked > max_kdis ) ked = max_kdis - end subroutine ugwp_limit_1d diff --git a/gfsphysics/physics/cires_vert_orodis.F90 b/gfsphysics/physics/cires_vert_orodis.F90 deleted file mode 100644 index 0d3cce194..000000000 --- a/gfsphysics/physics/cires_vert_orodis.F90 +++ /dev/null @@ -1,1018 +0,0 @@ -! subroutine ugwp_drag_mtb -! subroutine ugwp_taub_oro -! subroutine ugwp_oro_lsatdis -! - subroutine ugwp_drag_mtb( iemax, nz, & - elvpd, elvp, hprime , sigma, theta, oc, oa4, clx4, gam, zpbl, & - up, vp, tp, qp, dp, zpm, zpi, pmid, pint, idxzb, drmtb,taumtb) - - use ugwp_common, only : bnv2min, grav, grcp, fv, rad_to_deg, dw2min, velmin, rdi - use ugwp_oro_init,only : nridge, cdmb, fcrit_mtb, frmax, frmin, strver - - implicit none -!======================== -! several versions for drmtb => high froude mountain blocking -! version 1 => vay_2018 ; -! version 2 => kdn_2005 ; Kim & Doyle in NRL-2005 -! version 3 => ncep/gfs-2017 -gfs_2017 with lm1997 -!======================== - -! character(len=8) :: strver = 'vay_2018' -! real, parameter :: Fcrit_mtb = 0.7 - - integer, intent(in) :: nz - integer, intent(in) :: iemax ! standard ktop z=elvpd + 4 * hprime - real , intent(out) :: taumtb - - integer , intent(out) :: idxzb - real, dimension(nz), intent(out) :: drmtb - - real, intent(in) :: elvp, elvpd !elvp = min (elvpd + sigfac * hprime(j), hncrit=10000meters) - real, intent(in) :: hprime , sigma, theta, oc, oa4(4), clx4(4), gam - real, intent(in) :: zpbl - - real, dimension(nz), intent(in) :: up, vp, tp, qp, dp, zpm, pmid - real, dimension(nz+1), intent(in) :: zpi, pint -! - real, dimension(nz+1) :: zpi_zero - real, dimension(nz) :: zpm_zero - real :: vtj, rhok, bnv2, rdz, vtkp, vtk, dzp - - real, dimension(nz) :: bn2, uds, umf, cosang, sinang - - integer :: k, klow, ktop, kpbl - real :: uhm, vhm, bn2hm, rhohm, & - mtb_fix, umag, bnmag, frd_src, & - zblk, who_iz_normal, rlm97, & - phiang, ang, pe, ek, & - cang, sang, ss2, cs2, zlen, dbtmp, & - hamp, bgamm, cgamm - -!================================================== -! -! elvp + hprime <=>elvp + nridge*hprime, ns =2 -! ns = sigfac -! tau_parel & tau_normal along major "axes" -! -! options to block the "flow", choices for [klow, ktop] -! -! 1-directional (normal) & 2-directional "blocking" -! -!================================================== -! no - blocking: drmtb(1:nz) = 0.0 -!================= - idxzb = -1 - drmtb(1:nz) = 0.0 - taumtb = 0.0 - klow = 2 - - ktop = iemax - hamp = nridge*hprime - -! reminder: cdmb = 4.0 * 192.0/float(imx)*cdmbgwd(1) Lellipse= a/2=sigma/hprime - - mtb_fix = cdmb*sigma/hamp !hamp ~ 2*hprime and 1/sigfac = 0.25 is inside 1/hamp - - if (mtb_fix == 0.) then - print *, cdmb, sigma, hamp - print *, ' MTB == 0' - stop - endif - - if (strver == 'vay_2018') then - - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - - do k=1, nz-1 - if (hamp .le. zpi_zero(k+1) .and. (hamp .gt. zpi_zero(k) ) ) then - ktop = k+1 !......simply k+1 next interface level - exit - endif - enddo -! print *, klow, ktop, ' klow-ktop ' - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - umag = max(sqrt(uhm*uhm + vhm*vhm), velmin) !velmin=dw2min =1.0 m/s - if (bn2hm .le. 0.0) then - print *, ' unstable MF for MTB -RETURN ' - RETURN ! unstable PBL - endif - bnmag =sqrt(bn2hm) - - frd_src = min(hamp*bnmag/umag, frmax) ! frmax =10. - -! print *, frd_src, Fcrit_mtb/frd_src, ' no-Blocking > 1 ' -! - if ( frd_src .le. Fcrit_mtb) RETURN ! no-blocking, although on small ridges with weak winds can be blocking -! -! zblk > 0 -! Fcrit_mtb > Fcrit_ogw h_clip = Fr_mtb*U/N ! h_hill minus h_clip = zblk -! - zblk = hamp*(1. - Fcrit_mtb/frd_src) - idxzb =1 - do k = 2, ktop - - if ( zblk < zpm_zero(k) .and. zblk >= zpm_zero(k-1)) then - idxzb = k - exit - endif - enddo -! - if (idxzb == 1) RETURN ! first surface level block is not "important" - - if (idxzb > 1) then ! let start with idxzb = 2....and up with LM1997 -! -! several options to compute MTB-drag: a) IFS_1997 ; b) WRF_KD05 ; c) SJM_2000 -! - bgamm = 1.0 - 0.18*gam -0.04*gam*gam - cgamm = 0.48*gam +0.3*gam*gam - - do k = 1, idxzb-1 - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - - umag = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - - phiang = atan(vp(k)/umag) -! theta -90/90 - ang = theta - phiang - cang = cos(ang) ; sang = sin(ang) - - who_iz_normal = max(cang, gam*sang ) !gfs-2018 - - cs2 = cang* cang ; ss2 = 1.-cs2 - - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! ... (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it -! - if (rlm97 > 2.0 ) rlm97 = 2.0 ! zero mtb-friction at this level -! - - who_iz_normal = bgamm*cs2 + cgamm*ss2 ! LM1997/IFS - - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - if (dbtmp < 0) dbtmp = 0.0 -! -! several approximation can be made to implement MTB-drag -! as a "nonlinear level dependent"-drag or "constant"-drag -! uds(k) == umag = const between the 1-layer and idxzb -! - - drmtb(k) = dbtmp * abs(umag) ! full mtb-drag = -drmtb(k) * uds = -kr*u - taumtb = taumtb - drmtb(k)*umag *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! -! 2-wave appr for anisotropic drmtb_Bellipse(k) and drmtb_Aell(k) can be used -! with Umag-projections on A & B ellipse axes -! mtb_fix =0.25*cdmb*sigma/hprime, -! in SM-2000 mtb_fix~ 1/8*[cdmb_A, cdmb_B]*sigma/hprimesum ( A+B) = 1/4. -! -!333 format(i4, 7(2x, F10.3)) -! write(6,333) , k, zpm_zero(k), zblk, hamp*Fcrit_mtb/frd_src, taumtb*1.e3, drmtb(k) , -drmtb(k)*up(k)*1.e5 - enddo -! - endif - endif ! strver=='vay_2018' -! -! -! - if (strver == 'kdn_2005' .or. strver == 'wrf_2018' ) then - - print *, ' kdn_2005 with # of hills ' -! -! compute flow-blocking stress based on WRF 'gwdo2d' -! - endif -! -! - if (strver == 'gfs_2018') then - - ktop = iemax; klow = 2 - - call um_flow(nz, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - if (bn2hm <= 0.0) RETURN ! unstable PBL -!--------------------------------------------- -! -!'gfs_2018' .... does not rely on Fr_crit -! and Fr-regimes -!----gfs17 for mtn ignores "averaging of the flow" -! for MTB-part it is only works with "angles" -! no projections on [uhm, vhm] -direction -! kpbl can be used for getting high values of iemax-hill -!----------------------------------------------------------- - zpm_zero = zpm - zpi(1) - zpi_zero = zpi - zpi(1) - do k=1, nz-1 - if (zpbl .le. zpm_zero(k+1) .and. (zpbl .ge. zpm_zero(k) ) ) then - kpbl = k+1 - exit - endif - enddo - - do k = iemax, 1, -1 - - uds(k) = max(sqrt(up(k)*up(k) + vp(k)*vp(k)), velmin) - phiang = atan(vp(k)/uds(k)) - ang = theta - phiang - cosang(k) = cos(ang) - sinang(k) = sin(ang) - - if (idxzb == 0) then - pe = pe + bn2(k) * (elvp - zpm(k)) *(zpi(k+1) - zpi(k)) - umf(k) = uds(k) * cosang(k) ! normal to main axis - ek = 0.5 * umf(k) * umf(k) -! -! --- dividing stream lime is found when pe =>exceeds ek first from the "top" -! - if (pe >= ek) idxzb = k - exit - endif - enddo - -! idxzb = min(kpbl, idxzb) -! -! -! -! last: mtb-drag -! - if (idxzb > 1) then - zblk = zpm(idxzb) - print *, zpm(idxzb)*1.e-3, ' mtb-gfs18 block-lev km ', idxzb, iemax, int(elvp) - do k = idxzb-1, 1, -1 -! - zlen = sqrt( (zblk - zpm_zero(k) ) / ( zpm_zero(k) +hprime )) - cs2 = cosang(k)* cosang(k) - ss2 = 1.-cs2 - rlm97 =(gam * cs2 + ss2)/ (cs2 + gam * ss2) ! (cs2 + gam * ss2) / (gam * cs2 + ss2) ! check it - - who_iz_normal = max(cosang(k), gam*sinang(k)) -! -! high res-n higher mtb 0.125 => 3.5 ; (negative of db -- see sign at tendency) -! - dbtmp = mtb_fix* max(0., 2.- rlm97)*zlen*who_iz_normal - - drmtb(k) = dbtmp * abs(uds(k)) ! full mtb-drag = -drmtb(k) * uds = -kr*u -! - taumtb = taumtb - drmtb(k) * uds(k) *rdi * pmid(k)/tp(k)*(zpi(k+1)-zpi(k)) -! - enddo - endif - endif ! strver=='gfs17' -! -! - end subroutine ugwp_drag_mtb -! -! -! ugwp_taub_oro - Computes [taulin, taufrb, drlee(levs) ] -! -! - subroutine ugwp_taub_oro(levs, izb, kxw, tau_izb, fcor, & - hprime , sigma, theta, oc, oa4, clx4, gamm, & - elvp, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, xn, yn, umag, & - tautot, tauogw, taulee, drlee, tau_src, kxridge, kdswj, krefj, kotr) -! - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin - use cires_ugwp_module, only : frcrit, ricrit, linsat - use ugwp_oro_init, only : hpmax, cleff, frmax - use ugwp_oro_init, only : nwdir, mdir, fdir - use ugwp_oro_init, only : efmin, efmax , gmax, cg, ceofrc - use ugwp_oro_init, only : fcrit_sm, fcrit_gfs, frmin, frmax - use ugwp_oro_init, only : coro, nridge, odmin, odmax - use ugwp_oro_init, only : strver -! - use ugwp_oro_init, only : mkz2min, lzmax, zbr_pi -! --- -! -! define oro-GW fluxes: taulin, taufrb amd if kdswj > 0 (LWB-lee wave breaking) -! approximate for drlee-momentum tendency -! --- - implicit none -! - integer, intent(in) :: levs, izb - real , intent(in) :: tau_izb ! integrated (1:izb) drag -Kr_mtb*U, or Zero - integer, intent(out) :: kdswj, krefj, kotr - integer :: klwb - real, intent(in) :: kxw, fcor - real, intent(in) :: hprime, sigma, theta, oc, gamm, elvp - -! - real, intent(in) :: oa4(4), clx4(4) - - real, dimension(levs), intent(in) :: up, vp, tp, qp, dp - real, dimension(levs+1), intent(in) :: zpi, pint - real, dimension(levs ), intent(in) :: zpm, pmid -! - real,dimension(levs), intent(out) :: drlee - real,dimension(levs+1), intent(out) :: tau_src -! - real, intent(out) :: tauogw, tautot, taulee - real :: taulin, tauhcr, taumtb - real, intent(out) :: xn, yn, umag, kxridge -! -! -! locals -! four possible versions to compute "taubase as a function of Fr-number" -! character :: strver='smc_2000' ! 'kd_2005', 'gfs_2017', 'vay_2018' -! - real, dimension(levs+1) :: zpi_zero - - real :: oa, clx, odir, cl4p(4), clxp - - real :: uhm, vhm, bn2hm, rhohm, bnv - - real :: elvpMTB, wdir - real :: tem, efact, coefm, kxlinv, gfobnv - - real :: fr, frlin, frlin2, frlin3, frlocal, dfr - real :: betamax, betaf, frlwb, frmtb - integer :: klow, ktop, kph - - integer :: i, j, k, nwd, ind4, idir - - real :: sg_ridge, kx2, umd2 - real :: mkz, mkz2, zbr_mkz, mkzi - - real :: hamp ! clipped hprime*elvmax/elv_clip > hprime - real :: hogw ! hprime or hamp for free-prop OGWs z > z(krefj) - real :: hdsw ! empirical like DNS amplitudes for Lee-dsw trapped waves - real :: hcrit - real :: hblk ! blocking div-stream height - - real :: coef_h2, frnorm - - - real, dimension(levs) :: bn2 - real :: rho(levs) - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - real, dimension(levs+1) :: umd, phmkz - real :: c2f2, umag2, dzwidth, udir - real :: hogwi, hdswi, hogwz, hdswz ! height*height wave-amp - real :: uogwi, udswi, uogwz, udswz ! wind2 wave-rms - real, dimension(levs+1) :: dtrans, deff - real :: pdtrans - logical :: do_klwb_phase = .false. ! phase-crireria for LLWB of SM00 - logical :: do_dtrans = .true. ! dissipative saturation to deposit momentum - ! between ZMTB => ZHILL -!----------------------------------------------------------------------------- -! -! downslope/lee/GW wave regimes kdswj: between ZMTB and ZOGW(krefj) -! ZMTB < ZOGW = ns*HPRIME < ELVP -! define krefj as a level for OGWs above ZMTB and "2-3-4*hprime" + ZMTB -! we rely on the concept of the "CLIPPED-SG" mountain above ZMTB & new -! inverse Froude number for the "mean flow" averaged from ZMTB to ZOGW -! here we can use "elvp" as only for hprime adjustment ...elvp/elvp_MTB -! -!"empirical" specification of tauwave = taulee+tauogw in [ZMTB : ns*HPRIME] -! can be based on numerical runs like WRF-model -! for Frc < Fr< [Frc : 2.5-3 Frc] -! see suggestions proposed in SM-2000 and Eckermann et al. (2010) -!----------------------------------------------------------------------------- - tautot = 0. ; taulin = 0. ; taulee = 0. ; drlee(1:levs) = 0. ; tau_src = 0.0 - krefj = 1 ; kotr = levs+1; kdswj = 1 - xn = 1.0 ; yn = 0. ; umag = velmin; kxridge = kxw - - dtrans = 0. ; deff =0. - klow = 2 - elvpMTB = elvp -! -! clipped mountain H-zmtb for estimating wave-regimes new Fr and MF above ZMTB -! - if (izb > 0 ) then - klow = izb - elvpMTB = max(elvp - zpi(izb), 0.0) - endif - if (elvpMTB <=0 ) print *, ' blocked flow ' - if (elvpMTB <=0 ) return ! "blocked flow" from the surface to elvMAX - - zpi_zero(:) = zpi(:) - zpi(1) - hblk = zpi_zero(klow) - - sg_ridge = max( nridge*hprime * (elvp/elvpMTB), hblk+hprime*0.333) - -! -! enhance sg_ridge by elvp/elvpMTB >1 and H_clip = H-hiilnew - zblk later for hamp -! - sg_ridge = min(sg_ridge, hpmax) - -! print *, 'sg_ridge ', sg_ridge - - do k=1, levs - if (sg_ridge .gt. zpi_zero(k) .and. ( sg_ridge .le. zpi_zero(k+1) ) ) then - ktop = k+1 - exit - endif - enddo - - krefj = ktop ! the mountain top index for sg_ridge = ns*hprime - -! if ( izb > 0 .and. krefj .le. izb) then -! print *, izb, krefj, sg_ridge, zpi_zero(izb), ' izb >ktop ' -! endif - -! -! here ktop displays sg_ridge-position not elvP !!!! klow =2 to avoid for 127-126L -! instability due to extreme "thin" layer...128L-model needs cruder vertical resolution -! - call um_flow(levs, klow, ktop, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - bn2, uhm, vhm, bn2hm, rhohm) - - call get_unit_vector(uhm, vhm, xn, yn, umag) - - if (bn2hm <= 0.0) RETURN ! "unstable/neutral" hill need different treatment - bnv = sqrt(bn2hm) - hamp = sg_ridge-zpi_zero(klow) ! hamp >= nridge*hprime due higher SG-elevations - zblk or first layer - hogw = hamp - hdsw = hamp - - - fr = bnv * hamp /umag - fr = min(fr, frmax) - kxridge = max(sigma/hamp, kxw) ! to get rid from "SSO-errors" kxw-provides max-value for kx - kx2 = kxridge*kxridge - umag = max( umag, velmin) - c2f2 = fcor*fcor/kx2 - umag2 = umag*umag - c2f2 - - if (umag2 <= 0.0) RETURN ! Coriolis cut-off at high-mid latitudes for low kx - - mkz2 = bn2hm/umag2 - kx2 ! we add Coriolis corrections for crude model resolutions "low-kx" - ! and non-stationary waves coro, fcor for small umag - ! bn2hm/[(coro-umag)^2 -fc2/kx2] - kx2, cf = fc/kx => 2 m/s to 11 m/s for 60deg - IF (mkz2 < mkz2min .or. krefj <= 2 ) THEN -! -! case then no effects of wave-orography -! - krefj = 1 ; kdswj = 1; kotr = levs ; klwb = 1 - tautot = 0. - tauogw = 0. - taulee = 0. - drlee = 0. ; tau_src(1:levs+1) = 0. - return - ENDIF -!========================================================================= -! find orographic asymmetry and convexity :'oa/clx' for clipped SG-hill -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! make sure that SM_00 and KD_05 oro-characteristics can match each other -! OD-KDO5 = Gamma=a/b [0:2] ; hsg = 2.*hprime -! OC-KD05 mount sharpness sigma^4 "height to half-width"[0:1] -! alph-SM00 fraction of h2d contributed to hprime [0:1] -! -! OA-KDO5 OA > dwstream OA=0 sym OA < 0 upstram [-1. 0. 1] -! delt-SM00 dw/up asymmetry -1 < delta < 1 -! Gamma-LM97 anisotropy of the orography g2 =(dh/dx)^2/(dh/dy)^2 -!.. -!A parametrization of low-level wave breaking which includes a dependence on -!the degree of 2-dimensionality of SG; it is active over a finite range of Fr -!========================================================================= - wdir = atan2(uhm,vhm) + pi - idir = mod( int(fdir*wdir),mdir) + 1 - - nwd = nwdir(idir) - ind4 = mod(nwd-1,4) + 1 - if (ind4 < 1 ) ind4 = 1 - if (ind4 > 4 ) ind4 = 4 - - oa = ( 1-2*int( (nwd-1)/4 )) * oa4(ind4) - clx = clx4(ind4) - cl4p(1) = clx4(2) - cl4p(2) = clx4(1) - cl4p(3) = clx4(4) - cl4p(4) = clx4(3) - clxp = cl4p(ind4) - - odir = clxp/max(clx, 1.e-5) ! WRF-based definition for "odir" - - odir = min(odmax, odir) - odir = max(odmin, odir) - - - if (strver == 'smc_2000' .or. strver == 'vay_2018') then -!========================================================================= -! -! thrree-piece def-n for tautot(Fr): 0-Fr_lin - Fr_lee -Fr_mtb -! taulin/tauogw taulee taumtb -! here tau_src(levs+1): approximate wave flux from surface to LLWB -! Following attempts of Scinocca +McFarlane, 2000 & Eckermann etal.(2010) -!========================================================================= -! -! if (mkz2 < 0)... mkzi = sqrt(-mkz2) trapped wave regime don't a case in UGWP-V1 -! wave flux ~ rho_src*kx_src/mkz_src*wind_rms -! bn2, uhm, vhm, bn2hm, rhohm -! -! IF (mkz2.ge. mkz2min .and. krefj > 2 ) THEN -! -! wave regimes -! - mkz = sqrt(mkz2) - frlwb = fcrit_sm ! should be higher than LOGW to get zblk < zlwb - frlin = fcrit_sm - frlin2 = 1.5*fcrit_sm - frlin3 = 3.0*fcrit_sm - - hcrit = fcrit_sm*umag/bnv - hogw = min(hamp, hcrit) - hdsw = min(hamp, frlwb*umag/bnv) ! no trapped-wave solution - - coef_h2 = kxridge * rhohm * bnv * umag - - taulin = coef_h2 * hamp*hamp - tauhcr = coef_h2 * hcrit*hcrit - - IF (fr < frlin ) then - tauogw = taulin - taulee = 0.0 - taumtb = 0.0 - else if (fr .ge. frlin ) then - tauogw = tauhcr - taulin = coef_h2 * hamp*hamp - taumtb = tau_izb ! integrated form MTB -! -! SM-2000 approach for taulee, shall we put limits on BetaMax_max ~ 20 or Betaf ?? -! - frnorm = fr/fcrit_sm ! frnorm below [1.0 to 3.0] - BetaMax = 1.0 + 2.0*OC ! alpha of SM00 or OC-mountain sharphess KD05 OC=[10, 0] - - if ( fr <= frlin2 ) then - Betaf= 2.*BetaMax*(frNorm-1.0) - taulee = (1. + Betaf )*taulin - tauhcr - else if ( (fr > frlin2).and.(fr <= frlin3))then - Betaf=-1.+ 1./frnorm/frnorm + & - (BetaMax + 0.555556)*(2.0 - 0.666*frnorm)* (2.0 - 0.666*frnorm) - taulee = (1. + Betaf )*taulin - tauhcr -!============== -! Eck-2010 WRF-alternatve through Dp_surf = P'*grad(h(x,y)) -! 1 < Fr < 2.5 tauwave = taulee+tauogw = tau_dp*(fr)**(-0.9) -! Fr > 2.5 tauwave = tau_dp*(2.5)**(-0.9) -! to apply it need tabulated Dp(fr, Dlin) Dp=function(Dlin, U, N, h) -! -!============== - else - taulee = 0.0 - hdsw = 0.0 - endif - ENDIF - - tautot = tauogw + taulee + taumtb*0. - - IF (taulee > 0.0 ) THEN - - hdsw = sqrt(tautot/coef_h2) ! averaged value for hdsw - mixture of lee+ogw with mkz/kxridge -! -! compute vertical profile "drlee" with the low-level wave breaking & "locally" trapped waves -! make "empirical" height above elvp that may represent DSW-wave breaking & trapping -! here we will assign tau_sso(z) profile between: zblk(zsurf) - zlwb - ztop_sso = ns*sridge -! - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) ! kph marks the low-level of wave solutions - klwb = kph ! klwb above blocking marks wave-breaking - kotr = levs+1 ! kotr marks mkz2(z) <= 0., reflection level - - if (do_dtrans) pdtrans = log(tautot/tauogw)/(zpi(krefj) - zpi(kph)) - - udir = max(ui(krefj)*xn +vi(krefj)*yn, velmin) - hogwi = hogw*hogw* rhohm/rhoi(krefj) * umag/udir * bnv/bvi(krefj) - umd(krefj) = udir - - udir = max(ui(kph)*xn +vi(kph)*yn, velmin) - hdswi = hdsw*hdsw* rhohm/rhoi(kph) * umag/udir * bnv/bvi(kph) - umd(kph) = udir - ! what we can put between k =[kph:krefj] - phmkz(:) = 0.0 ! - phmkz(kph-1) = fr ! initial Phase of the low-level wave -! -! now transfer tau_layer => tau_level assuming tau_layer = tau_level -! kx*rho_layer*bn_layer*u_layer* HL*HL = kx*rho_top*bn_top*u_top * HT*HT -! apply it for both hdsw & hogw with linear saturation-solver for Cx =0 -! - loop_lwb_otr: do k=kph+1, krefj ! levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, dw2min) -c2f2 - - - if (umd2 <= 0.0) then -! -! critical layer -! - klwb = k - kotr = k - exit loop_lwb_otr - endif - - mkz2 = bn2i(k)/umd2 - kx2 - - if ( mkz2 >= mkz2min ) then -! -! find klwb having some "kinematic" phase "break-down" crireria SM00 or LM97 -! at finest vertical resolution we can meet "abrupt" mkz -! mkzmax = 6.28/(2*dz), mkzmin = 6.28/ztrop=18km -! to regularize SG-solution mkz = max(mkzmax, min(mkz,in, mkz)) -! - mkz = sqrt(mkz2) - hdswz = hdswi* rhoi(k-1)/rhoi(k) * umd(k-1)/umd(k) * bvi(k-1)/bvi(k) - udswz = hdswz *bn2i(k) -!=========================================================================================== -!linsat wave ampl.: mkz*sqrt(hdswz) <= 1.0 or udswz <= linsat2*umd2 -! -! tautot = tausat = rhoi(k) *udswz_sat * kxridge/mkz -! by k = krefj tautot = tauogw(krefj) -!=========================================================================================== - if (do_klwb_phase) then - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) .ge. zbr_pi).and.(klwb == kph)) then - klwb = min(k, krefj) - exit loop_lwb_otr - endif - endif - else ! mkz2 < mkz2min - kotr = k ! trapped/reflected waves / - exit loop_lwb_otr - endif - enddo loop_lwb_otr -! -! define tau_src(1:zblk:klwb) = sum(tau_oro+tau_dsw+tau_ogw) and define drlee -! tau_trapped ??? -! - if (do_klwb_phase) then - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = (tautot -tauogw)/(zpi(kph) - zpi(klwb)) ! negative Ax*rho - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif -! -! simplest exponential transmittance d(tau)/dz = - pdtrans *tau(z) -! more complicated is dissipative saturation pdtrans =/= constant -! - if (do_dtrans) then - do k=kph, krefj - tau_src(k)= tautot*exp(-pdtrans*(zpi(k)-zpi(kph))) - drlee(k) = -tau_src(k)/rho(k) * pdtrans - enddo - endif - - - ENDIF !taulee > 0.0 - - - endif !strver -! - -!========================================================================= - if (strver == 'gfs_2018' .or. strver == 'kd_2005') then -!========================================================================= -! -! orowaves: OGW+DSW/Lee -! - efact = (oa + 2.0) ** (ceofrc*fr) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + clx) ** (oa+1.) - - kxlinv = min (kxw, coefm * cleff) ! does not exceed 42km ~4*dx - kxlinv = coefm * cleff - tem = fr * fr * oc - gfobnv = gmax * tem / ((tem + cg)*bnv) ! g/n0 -!========================================================================= -! source fluxes: taulin, taufrb -!========================================================================= - tautot = kxlinv * rhohm * umag * umag *umag* gfobnv * efact - - coef_h2 = kxlinv *rhohm * bnv*umag - taulin = coef_h2 *hamp*hamp - hcrit = fcrit_gfs*umag/bnv - tauhcr = coef_h2 *hcrit*hcrit - - IF (fr <= fcrit_gfs) then - tauogw = taulin - tautot = taulin - taulee = 0. - drlee(:) = 0. - ELSE !fr > fcrit_gfs - tauogw = tauhcr - taulee = max(tautot - tauogw, 0.0) - if (taulee > 0.0 ) hdsw = sqrt(taulee/coef_h2) -! approximate drlee(k) between [izb, klwb] -! find klwb and decrease taulee(izb) => taulee(klwb) = 0. -! above izb tau - if (mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0) then - - mkz = sqrt(mkz2) - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) - - kph = max(izb, 2) - phmkz(:) = 0.0 - klwb = max(izb, 1) - kotr = levs+1 - phmkz(kph-1) = fr ! initial Phase of the Lee-OGW - - loop_lwb_gfs18: do k=kph, levs - - umd(k) = max(ui(k)*xn +vi(k)*yn, velmin) - umd2 =(coro- umd(k))*(coro- umd(k)) - umd2 = max(umd2, velmin*velmin) - mkz2 = bn2i(k)/umd2 - kx2 - if ( mkz2 > mkz2min ) then - mkz = sqrt(mkz2) - frlocal = max(hdsw*bvi(k)/umd(k), frlwb) - phmkz(k) = phmkz(k-1) + mkz*(zpm(k)-zpm(k-1)) - if( ( phmkz(k) >= zbr_pi ) .and. (frlocal > frlin)) klwb = k - else - kotr = k - exit loop_lwb_gfs18 - endif - enddo loop_lwb_gfs18 -! -! - do k=kph, kotr-1 - - if (klwb > kph .and. k < klwb) then - drlee(k) = -(tautot -tauogw)/(zpi(kph) - zpi(klwb)) - tau_src(k) = tautot + (zpi(k) - zpi(klwb))*drlee(k) - drlee(k) = drlee(k)/rho(k) - else if ( k >= klwb .and. k < kotr) then - tau_src(k) = tauogw - drlee(k) = 0.0 - endif - enddo - kdswj = klwb ! assign to the "low-level" wave breaking - endif ! mkz2 > mkz2min.and. krefj > 2 .and. taulee > 0.0 - ENDIF !fr > fcrit_gfs - - - ENDIF !strbase='gfs2017' .or. strbase='kd_2005' - - -! output : taulin, taufrb, taulee, xn, yn, umag, kxw/kxridge -! print *, krefj, levs, tauogw, tautot , ' ugwp_taub_oro ' -! - end subroutine ugwp_taub_oro -! -!-------------------------------------- -! -! call ugwp_oro_lsatdis( krefj, levs, tauogw(j), tautot(j), tau_src, kxw, & -! fcor(j), c2f2(j), up, vp, tp, qp, dp, zpm, zpi, pmid1, pint1, & -! xn, yn, umag, drtau, kdis_oro) - - subroutine ugwp_oro_lsatdis( krefj, levs, tauogw, tautot, tau_src, & - kxw, fcor, kxridge, up, vp, tp, qp, dp, zpm, zpi, pmid, pint, & - xn, yn, umag, drtau, kdis) - - use ugwp_common, only : bnv2min, grav, pi, pi2, dw2min, velmin, rgrav - use cires_ugwp_module, only : frcrit, ricrit, linsat, hps, rhp1, rhp2 - use cires_ugwp_module, only : kvg, ktg, krad, kion - use ugwp_oro_init, only : coro , fcrit_sm , fcrit_sm2 - implicit none -! - integer, intent(in) :: krefj, levs - real , intent(in) :: tauogw, tautot, kxw - real , intent(in) :: fcor - - real , dimension(levs+1) :: tau_src - - real, dimension(levs) , intent(in) :: up, vp, tp, qp, dp, zpm - real, dimension(levs+1), intent(in) :: zpi, pmid, pint - real , intent(in) :: xn, yn, umag - real , intent(in) :: kxridge - - - real, dimension(levs), intent(out) :: drtau, kdis -! -! locals -! - real :: uref, udir, uf2, ufd, uf2p - real, dimension(levs+1) :: tauz - real, dimension(levs) :: rho - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi - - integer :: i, j, k, kcrit, kref - real :: kx2, kx2w, kxs - real :: mkzm, mkz, dkz, mkz2, ch, kzw3 - real :: wfdM, wfdT, wfiM, wfiT - real :: fdis, mkzi, keff_m, keff_t - real :: betadis, betam, betat, cdfm, cdft - real :: fsat, hsat, hsat2, kds , c2f2 - - drtau(1:levs) = 0.0 - kdis (1:levs) = 0.0 - - ch = coro - - kx2w = kxw*kxw - kx2 = kxridge*kxridge - if( kx2 < kx2w ) kx2 = kx2w - kxs = sqrt(kx2) - c2f2 = fcor*fcor/kx2 -! -! non-hydrostatic LinSatDis for Ch = 0 (with set of horizontal wavenumber kxw) -! -! print *, krefj, levs, tauogw, tautot , ' orolsatdis ' - call mflow_tauz(levs, up, vp, tp, qp, dp, zpm, zpi, & - pmid, pint, rho, ui, vi, ti, bn2i, bvi, rhoi) -!=============================================================================== -! for stationary oro-GWs only "single"-azimuth cd = 0 -(-Udir) = Udir > 0 -! rotational/non-hyrostatic effects are important only for high-res runs -! Udir = 0, Udir < 0 are not -! future"revisions" shear effects for d mkz /dt = -kxw*dU/dz -! horizontal wavelength spectra mkz2 = l2 -kxw(n)*kxw(n) -! stochastic "tauogw'-setup+ sigma_tau ; -! 3D-wave effects 1+ (k/l)^2 and NS vs EW orowaves -! target is to get "multiple"-saturation levels for OGWs -!=============================================================================== - tauz(1:krefj) = tauogw ! constant flux for OGW-packet or single mode - ! sign of tauz > 0...and its attenuate with Z - k = krefj - uref = ui(k)*xn +vi(k)*yn - ch ! stationary waves - uf2 = uref*uref - c2f2 - if (uf2 > 0) then - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2.gt.0) then - mkzm = sqrt(mkz2) - else - return ! wave reflection mkz2 <=0. - endif - else - return ! wave absorption uf2 <= 0. - endif -! -! upward solver for single "mode" with tauz(levs+1) =0. at the top -! - kds = 0.1* kvg(krefj) ! eddy wave diffusion from the previous layer - kcrit = levs - do k= krefj+1, levs -! -! 2D-wave propagation along reference-wind direction -! udir = 0 critical wind for coro =0 -! cdop = -uref .... upwind waves travel against MF -! - udir = ui(k)*xn +vi(k)*yn - uf2 = udir*udir - c2f2 - - - if (uf2 < dw2min .or. udir <= 0.0) then - kcrit =K - tauz(kcrit:levs) = 0. - exit ! vert-level loop - endif -! -! wave-based solution -! - mkz2 = bn2i(k)/uf2 -kx2 - if (mkz2 > 0) then - mkzm = sqrt(mkz2) -! -! do dissipative flux vs saturation: kvg, ktg, krad, kion -! - kzw3 = mkzm*mkz2 -! - keff_m = kvg(k)*mkz2 + kion(k) -! keff_t = kturb(k)*iPr_turb + kmol(k)*iPr_mol - keff_t = ktg(k)*mkz2 + krad(k) -! -! - uf2p = uf2 + 2.0*c2f2 - betadis = uf2/uf2p - betaM = 1.0 / (1.0+betadis) ! if c2f2 = 0. betaM = betaT =0.5 ekw = epw - betaT = 1.0- BetaM - -! -!imaginary frequencies of momentum and heat with "kds at (k-1) level" -! - wfiM = kds*mkz2 + keff_m - wfiT = kds*mkz2 + keff_t -! - cdfm = sqrt(uf2)*kxs - cdft = abs(udir)*kxs - wfdM = wfiM/cdfm *BetaM - wfdT = wfiT/Cdft *BetaT - mkzi = 2.0*mkzm*(wfdM+wfdT) - - fdis = tauz(k-1)*exp(-mkzi*(zpi(k)-zpi(k-1)) ) - tauz(k) = fdis - hsat2 = fcrit_sm2 * uf2 *bn2i(k) - fsat = rhoi(k)* hsat2 * sqrt(uf2) * bvi(k) - if (fdis > fsat) then - tauz(k) = min(fsat, tauz(k-1)) -!================================================================= -! two definitions for eddy mixing of MF: -! a) wave damping-Lindzen : Ked ~ kx/(2H)*(u-c)^4/N^3 -! b) heat-based turbulence: 4/3 Richardson Ked ~eps^1/3 *Lt^4/3 -!================================================================= - kds = rhp2*kxs*uf2*uf2/bn2i(k)/bvi(k) - kdis(k) = kds - endif - else - tauz(k:levs) = 0. ! wave is reflected above - kds = 0. - endif - enddo - - do k=krefj+1, kcrit - drtau(k) = rgrav*(tauz(k+1)-tauz(k))/dp(k) - enddo -! -! - end subroutine ugwp_oro_lsatdis -! -! - subroutine ugwp_tofd(im, levs, sigflt, elvmax, zpbl, u, v, zmid, & - utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none -! - integer :: im, levs - real(kind_phys), dimension(im, levs) :: u, v, zmid - real(kind_phys), dimension(im) :: sigflt, elvmax, zpbl - real(kind_phys), dimension(im, levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sgh = 30. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, zexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - - do i=1, im - - zdec = max(n_tofd*sigflt(i), zpbl(i)) - zdec = min(ze_tofd, zdec) - rzdec = 1.0/zdec - sgh2 = max(sigflt(i)*sigflt(i), sgh*sgh) - - do k=1, levs - zmet = zmid(i,k) - if (zmet > ztop_tofd) cycle - ekin = u(i,k)*u(i,k) + v(i,k)*v(i,k) - umag = sqrt(ekin) - zarg = zmet*rzdec - zexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *zexp - utofd(i,k) = -krf*u(i,k) - vtofd(i,k) = -krf*v(i,k) - epstofd(i,k)= rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re - krf_tofd(i,k) = krf - enddo - enddo -! - end subroutine ugwp_tofd -! -! - subroutine ugwp_tofd1d(levs, sigflt, elvmax, zsurf, zpbl, u, v, & - zmid, utofd, vtofd, epstofd, krf_tofd) - use machine , only : kind_phys - use ugwp_common , only : rcpd2 - use ugwp_oro_init, only : n_tofd, const_tofd, ze_tofd, a12_tofd, ztop_tofd -! - implicit none - integer :: levs - real(kind_phys), dimension(levs) :: u, v, zmid - real(kind_phys) :: sigflt, elvmax, zpbl, zsurf - real(kind_phys), dimension(levs) :: utofd, vtofd, epstofd, krf_tofd -! -! locals -! - integer :: i, k - real :: sghmax = 5. - real :: sgh2, ekin, zdec, rzdec, umag, zmet, zarg, ztexp, krf -! - utofd =0.0 ; vtofd = 0.0 ; epstofd =0.0 ; krf_tofd =0.0 -! - zdec = max(n_tofd*sigflt, zpbl) ! ntimes*sgh_turb or Zpbl - zdec = min(ze_tofd, zdec) ! cannot exceed 18 km - rzdec = 1.0/zdec - sgh2 = max(sigflt*sigflt, sghmax*sghmax) ! 25 meters dz-of the first layer - - do k=1, levs - zmet = zmid(k)-zsurf - if (zmet > ztop_tofd) cycle - ekin = u(k)*u(k) + v(k)*v(k) - umag = sqrt(ekin) - zarg = zmet*rzdec - ztexp = exp(-zarg*sqrt(zarg)) - krf = const_tofd* a12_tofd *sgh2* zmet ** (-1.2) *ztexp - - utofd(k) = -krf*u(k) - vtofd(k) = -krf*v(k) - epstofd(k) = rcpd2*krf*ekin ! more accurate heat/mom form using "implicit tend-solver" - ! to update momentum and temp-re; epstofd(k) can be skipped - krf_tofd(k) = krf - enddo -! - end subroutine ugwp_tofd1d diff --git a/gfsphysics/physics/cires_vert_wmsdis.F90 b/gfsphysics/physics/cires_vert_wmsdis.F90 deleted file mode 100644 index 9e0bbf37c..000000000 --- a/gfsphysics/physics/cires_vert_wmsdis.F90 +++ /dev/null @@ -1,425 +0,0 @@ - subroutine ugwp_wmsdis_naz(levs, ksrc, nw, naz, kxw, taub_lat, ch, xaz, yaz, & - fcor, c2f2, dp, zmid, zint, pmid, pint, rho, ui, vi, ti, & - kvg, ktg, krad, kion, bn2i, bvi, rhoi, ax, ay, eps, ked, tau1) -! -! -! use para_taub, only : tau_ex - use ugwp_common, only : rcpd, grav, rgrav - implicit none -! - integer :: levs - integer :: nw, naz ! # - waves for each azimuth (naz) - integer :: ksrc ! source level - real :: kxw ! horizontal wn - real :: taub_lat ! lat-dep tau_bulk N/m2 -! - real, dimension(nw) :: ch, dch, taub_spect - real, dimension(naz) :: xaz, yaz - real, dimension(levs+1) :: ui, vi, ti, bn2i, bvi, rhoi, zint, pint - real, dimension(levs ) :: dp, rho, pmid, zmid - real :: fcor, c2f2 - real, dimension(levs+1) :: kvg, ktg, kion, krad, kmol - -! output/locals - real, dimension(levs ) :: ax, ay, eps - real, dimension(levs+1) :: ked , tau1 - real, dimension(levs+1 ) :: uaz - - real, dimension(levs, naz ) :: epsd - real, dimension(levs+1, naz ) :: atau, kedd - - real, dimension(levs+1 ) :: taux, tauy, bnrho - real, dimension(levs ) :: dzirho , dzpi - -! - integer :: iaz, k , inc - real, parameter :: gcstar=1.0 - integer , parameter :: nslope=1 - real :: spnorm ! source level normalization factor for the Broad Spectra - real :: bnrhos ! sum(taub_spect*dc) = spnorm taub_sect_norm = taub_spect/spnorm -! - atau=0.0 ; epsd=0.0 ; kedd=0.0 - bnrhos = bvi(ksrc)/rhoi(ksrc) - do k=1,levs - dzpi(k) = zint(k+1)-zint(k) - dzirho(k) = 1.0 / (rho(k)*dzpi(k)) ! grav/abs(dp(k)) still hydrostatic "ugwp" - bnrho(k) = (rhoi(k)/bvi(k)) !*bnrhos * gcstar ! gcstar=1.0 and bnrho(k=ksrc) =1. - enddo - k = levs+1 - bnrho(k) = (rhoi(k)/bvi(k))*bnrhos -! -! re-define ch, dch, taub_spect, this portion can be moved to "ugwp_init" -! -! -! - call FVS93_ugwps(nw, ch, dch, taub_spect, spnorm, nslope, bn2i(ksrc), bvi(ksrc), bnrho(ksrc)) - - -! print *, ' after FVS93_ugwp ', nw, maxval(ch), minval(ch) -! -! do normaalization for the spectral element of the saturated flux -! - bnrho = bnrho *spnorm - -! print * -! do inc=1, nw -! write(6,221) inc, ch(INC),taub_lat*taub_spect(inc), spnorm, dch(inc) -!221 FORMAT( i6, 2x, F8.2, 3(2x, E10.3)) -! enddo -! pause - - loop_iaz: do iaz =1, naz - - do k=1,levs+1 - uaz(k) =ui(k)*xaz(iaz) +vi(k)*yaz(iaz) - enddo -! -! -! multi-wave broad spectrum of FVS-93 with ~scheme of WMS-IFS 2010 -! -! print *, ' iaz before ugwp_wmsdis_az1 ', iaz -! - - call ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_spect, taub_lat, & - spnorm, fcor, c2f2, zmid, zint, rho, uaz, ti, bn2i, bvi, rhoi, bnrho, dzirho, dzpi, & - kvg, ktg, krad, kion, kmol, epsd(:, iaz), kedd(:,iaz), atau(:, iaz) ) - -! print *, ' iaz after ugwp_wmsdis_az1 ', iaz - -! - enddo loop_iaz ! azimuth of gw propagation directions -! -! sum over azimuth and project atau(z, iza) =>(taux and tauy) -! for scalars for "wave-drag vector" -! - eps =0. ; ked =0. - do k=ksrc, levs - eps(k) = sum(epsd(k,:))*rcpd - enddo - - do k=ksrc, levs+1 - taux(k) = sum( atau(k,:)*xaz(:)) - tauy(k) = sum( atau(k,:)*yaz(:)) - ked(k) = sum( kedd(k,:)) - enddo -! - tau1(ksrc:levs) = taux(ksrc:levs) - tau1(1:ksrc-1) = tau1(ksrc) - -! end solver: gw_azimuth_solver_ls81 -! sign ax in rho*du/dt = -d(rho*tau)/dz -! [(k) - (k+1)] -! du/dt = ax = -1/rho*d( tau) /dz -! - ax =0. ; ay = 0. - - do k=ksrc, levs - ax(k) = dzirho(k)*(taux(k)-taux(k+1)) - ay(k) = dzirho(k)*(tauy(k)-tauy(k+1)) - enddo - call ugwp_limit_1d(ax, ay, eps, ked, levs) - - return - end subroutine ugwp_wmsdis_naz - - -! ======================================================================= - subroutine ugwp_wmsdis_az1(levs, ksrc, nw, kxw, ch, dch, taub_sp, tau_bulk, & - spnorm, fcor, c2f2, zm, zi, rho, um, tm, bn2, bn, rhoi, bnrho, & - dzirho, dzpi, kvg, ktg, krad, kion, kmol, eps, ked, tau ) -! -! use para_taub, only : tau_ex, xlatdeg !for exchange src-tau -! - use cires_ugwp_module, only : f_coriol, f_nonhyd, f_kds, linsat - use cires_ugwp_module, only : ipr_ktgw, ipr_spgw, ipr_turb, ipr_mol - use cires_ugwp_module, only : rhp4, rhp2, rhp1, khp, cd_ulim -! ======================================================================= - integer :: levs, ksrc, nw - real :: fcor, c2f2, kxw -! - real, dimension(nw) :: taub_sp, ch, dch - real :: tau_bulk, spnorm - real, dimension(levs) :: zm, rho, dzirho, dzpi - real, dimension(levs+1) :: zi, um, tm, bn2, bn, rhoi, bnrho - real, dimension(levs+1) :: kvg, ktg, krad, kion, kmol - real, dimension(levs+1) :: ked, tau - real, dimension(levs ) :: eps -! -!locals - integer :: k, inc - real, dimension(levs+1) :: umi - real :: zcin, zci_min, ztmp, zcinc - real :: zcimin=0.5 ! crit-level precision, 0.5 and start of Ch_MIN - real, parameter :: Keff = 0.2 - - real, dimension(nw) :: zflux ! - real, dimension(nw) :: wzact, zacc ! =1 ..crit level change it - - real, dimension(levs) :: zcrt ! - real, dimension(nw, levs) :: zflux_z, zact - - real :: zdelp, kxw2 - real :: vu_eff, vu_lin, v_kzw, v_cdp, v_wdp, v_kzi - real :: dfsat, fdis, fsat, fmode, expdis - real :: vc_zflx_mode, vm_zflx_mode - real :: tau_g5 -! ======================================================================= -!eps, ked, tau - - eps (:) =0; ked = 0.0 ; - kxw2 = kxw*kxw -! - zcrt(1:levs) = 0.0 - umi(1:levs+1) = um -! umi(1:levs+1) = um(1:levs+1) -um(ksrc) - - zci_min = zcimin - -! CALL slat_geos5(1, xlatdeg(1), tau_g5) -! tau_bulk = tau_g5 !tau_bulk*0.75 !3.75e-2 -! - zflux(:) = taub_sp(:)*tau_bulk ! includes tau_bulk(x,y) and spectral normalization - - zflux_z(1:nw,ksrc)=zflux(:) - - tau(1:levs+1) = tau_bulk ! constant flux for all layers k0.0 ) then -! ztmp = sum( ch(:)*zacc(:)*zflux(:)*dch(:) ) -! zcrt(k)=ztmp/tau(k) -! else -! zcrt( k )=zcrt(k-1) -! endif -! --------------------------------------------------------- -! do saturation (eq. (26) and (27) of scinocca 2003) -! + add molecular/eddy dissipation od gw-spectra vay-2015 -! for each mode & direction -! x by exp(-mi*zdelp) x introduce ....... mi(nw) -! -! mode-loop + add molecular/eddy dissipation od gw-spectra vay-2015 -! - do inc=1,nw - if (zact(inc,k) == 0.0) then - zflux(inc) = 0.0 - zflux_z(inc,k) = zflux(inc) - else - vu_eff = kvg(k) ! + ktg (k) !* ipr_ktgw - vu_lin = kion(k) ! + krad(k) !* ipr_ktgw - vu_eff = 2.e-5*exp(zi(k)/7000.)+.01 - zcin= ch(inc) - -!======================================================================= -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= - v_cdp = zcin-umi(k) - v_wdp = kxw*v_cdp - if (v_wdp.gt.0) then - v_kzw = bn(k)/v_cdp !can be non-hydrostatic - v_kzi = abs(( v_kzw*v_kzw*vu_eff + vu_lin) /v_wdp*v_kzw) - expdis = exp(-2.*v_kzi*dzpi(k) ) - else - v_kzi = 0. - expdis = 1.0 - endif - fmode = zflux(inc) - fdis = fmode*expdis ! only dissipation/crit_lev degrades it -!------------------------ -! includes rho/bn /(rhos/bns) *spnorm -!------------------------ - fsat = bnrho(k)* v_cdp*v_cdp /zcin ! expression for saturated flux - ! zfluxs=gcstar*zfct( k)*(zcin-zui( k ))**2/zcin -! flux_tot - sat.flux -! - dfsat= fdis-fsat - if( dfsat > 0.0 ) then -! put sat-n limit - zflux(inc) = fsat - else -! assign dis-ve flux - zflux(inc) =fdis - endif - zflux_z(inc,k)=zflux(inc) - - if (zflux_z(inc,k) > zflux_z(inc,k-1) ) zflux_z(inc,k) = zflux_z(inc,k-1) - - endif - - enddo -! -! integrate over spectral modes zpu(y, z, azimuth) zact( inc, )*zflux( inc, )*[d("zcinc")] -! - tau(k) = sum( zflux_z(:,k)*dch(:)) -!------------------------------------------------------------------------------ -! define expressions for eps-heat + Ked, needs more work for the broad spectra -! formulation especially for Ked -! after defining Ked .....GW-eddy cooling needs to be added -! for now "only" heating here -!============================================================================== - eps(k) =0. - do inc=1, nw - if (zact(inc,k) == 0.0) cycle ! dc-integration + dtau/dz - vc_zflx_mode = zflux(inc) - - zdelp= abs(ch(inc)-umi(k)) * dch(inc) /dzpi(k) - vm_zflx_mode=zflux_z(inc,k-1) - eps(k) =eps( k ) + (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 - - - enddo !inc=1, nw - ked(k) = Keff*eps(k)/bn2(k) -! -! -------------- -! - enddo ! end k do-loop vertical loop do k=ksrc+1, levs - -!top lid - k =levs+1 - ked(k) = ked(k-1) -! eps(k) = eps(k-1) - tau(k) =tau(k-1)*0.933 - -! from surface to ksrc-1 -! tau(1:ksrc) = tau(ksrc) - ked(1:ksrc) = 0. - eps( 1:ksrc) = 0. - -! -! output: eps, ked, tau for given azimuth -! - end subroutine ugwp_wmsdis_az1 -! -! - subroutine FVS93_ugwps(nw, ch, dch, taub_sp, spnorm, nslope, bn2, bn, bnrhos) - implicit none - integer :: nw, nslope - real :: bn2, bn, bnrhos -!! real :: taub_lat ! bulk - lat-dep momentum flux - real, dimension (nw) :: ch, dch, taub_sp -! locals - integer :: i, inc - real, parameter :: zcimin = 0.5, zcimax = 95.0, zgam =1./4. - real, parameter :: zms = 6.28e-3/2. ! mstar Lz ~ 2km - real :: zxran, zxmax, zxmin, zx1, zx2, zdx, ztx, rch - real :: bn3, bn4, zcin, tn4, tn3, tn2, cstar - real :: spnorm ! needs to be passed for saturation flux norm-n - real :: tau_bulk -!-------------------------------------------------------------------- -! -! transforms ch -uniform => 1/ch and back to non-uniform ch, dch -! -!------------------------------------------------------------------- -! note that this is expresed in terms of the intrinsic ch or vertical wn=N/cd -! at launch cd=ch-um(ksrc), the transformation is identical for all -! levels, azimuths and horizontal pixels -! see eq. 28-30 of scinocca 2003. x = 1/c stretching transform -! - zxmax=1.0 /zcimin - zxmin=1.0 /zcimax - zxran=zxmax-zxmin - zdx=zxran/float(nw-1) ! d_kz or d_mi -! -! - zx1=zxran/(exp(zxran/zgam)-1.0 ) !zgam =1./4. - zx2=zxmin-zx1 -! -! add idl computations for zci =1/zx -! x = 1/c stretching transform to look at final ch(i), dch(i) -! - - do i=1, nw - ztx=float(i-1)*zdx+zxmin - rch=zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 - ch(i)=1.0 /rch !eq. 28 of scinocca 2003 - dch(i)=ch(i)*ch(i)*(zx1/zgam)*exp((ztx-zxmin)/zgam)*zdx !eq. 30 of scinocca 2003 - enddo -! -! nslope-dependent flux taub_spect(nw) momentum flux spectral density -! need to check math....expressions -! eq. (25) of scinocca 2003 with u-uo=0 it is identical to all azimuths -! -! - cstar=bn/zms - bn4=bn2*bn2 ! four times - bn3=bn2*bn - if(nslope==1) then -! s=1 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc) =bnrhos * zcin*bn4/(bn4+tn4) - enddo -! - elseif(nslope==2) then -! s=2 case - do inc=1, nw - zcin=ch(inc) - tn4=(zms*zcin)**4 - taub_sp(inc)= bnrhos*zcin*bn4/(bn4+tn4*zcin/cstar) - enddo -! - elseif(nslope==-1) then -! s=-1 case - do inc=1, nw - zcin=ch(inc) - tn2=(zms*zcin)**2 - taub_sp(inc)=bnrhos*zcin*bn2/(bn2+tn2) - enddo -! s=0 case - elseif(nslope==0) then - - do inc=1, nw - zcin=ch(inc) - tn3=(zms*zcin)**3 - taub_sp(inc)=bnrhos*zcin*bn3/(bn3+tn3) - enddo - endif ! for n-slopes -!============================================= -! normalize launch momentum flux -! ------------------------------------ -! (rho x f^h = rho_o x f_p^total) integrate (zflux x dx) - - tau_bulk= sum(taub_sp(:)*dch(:)) - spnorm= 1./tau_bulk - - do inc=1, nw - taub_sp(inc)=spnorm*taub_sp(inc) - enddo - - end subroutine FVS93_ugwps - diff --git a/gfsphysics/physics/cldmacro.F b/gfsphysics/physics/cldmacro.F deleted file mode 100644 index bc28d0606..000000000 --- a/gfsphysics/physics/cldmacro.F +++ /dev/null @@ -1,2371 +0,0 @@ - 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 - integer :: NSMAX, DISABLE_RAD, ICEFRPWR - &, 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 :: maxrhcritland - real :: turnrhcrit - real :: turnrhcrit_upper - real :: MIN_RI, MAX_RI, MIN_RL, MAX_RL, RI_ANV - - - 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, t_ice_denom - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - contains - - - subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev -! &, RMFDTR_dev -! &, FRLAND_dev, RMFDTR_dev - &, QLWDTR_dev -! &, QLWDTR_dev, QRN_CU_dev, CNV_UPDFRC_dev -! &, U_dev, V_dev, TH_dev, Q_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 -! &, 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 -! &, ALPHT_dev, CFPDF_dev, DQRL_dev -! &, VFALLSN_CN_dev -! &, VFALLRN_CN_dev, CNV_FICE_dev - &, CNV_FICE_dev - &, CNV_NDROP_dev, CNV_NICE_dev, SCICE_dev - &, NCPL_dev, NCPI_dev, PFRZ_dev -! &, QRAIN_CN, QSNOW_CN - &, lprnt, ipr, rhc, pdfflag, qc_min ) -! &, KCBL, lprnt, ipr, rhc ) - - integer, intent(in ) :: IRUN, LM, pdfflag - real, intent(in ) :: DT, alf_fac, qc_min(2) - real, intent(in ), dimension(IRUN, LM) :: PP_dev - real, intent(in ), dimension(IRUN,0:LM) :: PPE_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(in ), dimension(IRUN, LM) :: rhc - 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, TEMP, ALPHA - &, dti, tx1, tend, fqi - -! 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 -! &, PRN_CU_above, PSN_CU_above -! &, 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, psinv, pops - - logical :: use_autoconv_timescale -! - real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 -! - - omeps = 1.0 - epsqs - trinv = 1.0 / ttrice - dti = 1.0 / dt - - 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) * 0.001 -! 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) * 0.001 - - use_autoconv_timescale = .false. - - t_ice_denom = 1.0 / (T_ICE_MAX-T_ICE_ALL) - - 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. -! psinv = 1.0 / ppe_dev(i,lm) - - 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 = TH_dev(I,K) -! FRZ_PP_dev(I,K) = 0.00 - - ALPHT_dev(I,K) = 0.0 - MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) * (100./MAPL_GRAV) - iMASS = 1.0 / MASS - TEMP = TH_dev(I,K) - - -! 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) ) -! pops = PP_dev(I,K) * psinv - -! call pdf_spread (K, LM, PP_dev(I,K), ALPHA, ALPHT_dev(I,K), -! call pdf_spread (K, LM, pops, ALPHA, ALPHT_dev(I,K), -! & FRLAND_dev(I), rhc(i) ) - -! ALPHA = max(1.0e-4, 1.0-rhc(i,k)) -! ALPHT_dev(I,K) = ALPHA * alf_fac -! - ALPHA = max(1.0e-4, 1.0-rhc(i,k)) * alf_fac - ALPHT_dev(I,K) = ALPHA - -! 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), pdfflag) - - -!=============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)******************************** -! if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', -! & CLDFRC_dev(I,K) ,' k=',k - - 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), qc_min) - -! if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', -! & CLDFRC_dev(I,K) , ' k=',k - - TH_dev(I,K) = TEMP - - 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, PP, ALPHA, ALPHT_DIAG, FRLAND, rhc) - - integer, intent(in) :: k,lm - real, intent(in) :: PP, FRLAND, rhc - - real, intent(out) :: ALPHA, ALPHT_DIAG - -! real, parameter :: slope = 20.0, slope_up = 20.0 - real, parameter :: slope = 0.02, slope_up = 0.02 - - real :: aux1, aux2, maxalpha - -! maxalpha = 1.0 - minrhcrit - maxalpha = 1.0 - rhc - - aux1 = min(max((pp - turnrhcrit)/slope, -20.0), 20.0) - aux2 = min(max((turnrhcrit_upper - pp)/slope_up, -20.0), 20.0) - - if (frland > 0.05) then -! aux1 = 1.0 - aux1 = 1.0 / (1.0+exp(aux1+aux1)) - else - aux1 = 2.0 / (1.0+exp(aux1+aux1)) - end if - - aux2 = 1.0 / (1.0+exp(aux2)) - - alpha = max(1.0e-4, min(0.3, maxalpha*aux1*aux2)) -! alpha = min(0.3, maxalpha*aux1*aux2) !Anning - - ALPHT_DIAG = ALPHA - - end subroutine pdf_spread - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine fix_up_clouds_2M(QV, TE, QLC, QIC, CF, QLA, QIA, AF, - & NL, NI, qc_min) - - real, intent(in) :: qc_min(2) - real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA, NL, NI - -! real, parameter :: qmin = 1.0e-8, qmini = 1.0e-7 -! real, parameter :: nmin = 1.0e-3, cfmin = 1.0e-5 - real, parameter :: nmin = 1.0, cfmin = 1.0e-5 - &, RI_cub = 6.4e-14, RL_cub = 1.0e-15 - &, fourb3 = 4.0/3.0 - - if (AF <= cfmin) then ! Fix if Anvil cloud fraction too small - QV = QV + QLA + QIA - TE = TE - ALHLbCP*QLA - ALHSbCP*QIA - AF = 0. - QLA = 0. - QIA = 0. - - if ( CF <= cfmin) then ! Fix if LS cloud fraction too small - QV = QV + QLC + QIC - TE = TE - ALHLbCP*QLC - ALHSbCP*QIC - CF = 0. - QLC = 0. - QIC = 0. - endif - endif - - if (QLC <= qc_min(1)) then ! LS LIQUID too small - QV = QV + QLC - TE = TE - ALHLbCP*QLC - QLC = 0. - endif - - if (QIC <= qc_min(2)) then ! LS ICE too small - QV = QV + QIC - TE = TE - ALHSbCP*QIC - QIC = 0. - endif - - if (QLA <= qc_min(1)) then ! Anvil LIQUID too small - QV = QV + QLA - TE = TE - ALHLbCP*QLA - QLA = 0. - endif - - if (QIA <= qc_min(2)) then ! Anvil ICE too small - QV = QV + QIA - TE = TE - ALHSbCP*QIA - QIA = 0. - endif - - if (QLA+QIA <= qc_min(1)) then ! Fix ALL cloud quants if Anvil cloud LIQUID+ICE too small - QV = QV + QLA + QIA - TE = TE - ALHLbCP*QLA - ALHSbCP*QIA - AF = 0. - QLA = 0. - QIA = 0. - endif - - if (QLC+QIC <= qc_min(1)) then ! Ditto if LS cloud LIQUID+ICE too small - QV = QV + QLC + QIC - TE = TE - ALHLbCP*QLC - ALHSbCP*QIC - CF = 0. - QLC = 0. - QIC = 0. - endif - - if (QLA+QLC <= qc_min(1)) then - NL = 0.0 - elseif (NL <= nmin) then ! make sure NL > 0 if Q >0 - NL = max((QLA+QLC)/( fourb3 * MAPL_PI *RL_cub*997.0), nmin) - endif - - if (QIA+QIC <= qc_min(2)) then - NI = 0.0 - elseif (NI <= nmin) then ! make sure NI > 0 if Q >0 - NI = max((QIA+QIC)/( fourb3 * MAPL_PI *RI_cub*500.0), nmin) - endif - - end subroutine fix_up_clouds_2M - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine update_cld( irun, lm, DT, ALPHA, qc_min, - & PDFSHAPE, PL, QV, QCl, QAl, - & QCi, QAi, TE, CF, AF, - & SCICE, NI, NL) -! & SCICE, NI, NL, NCnuc) - - integer, intent(in) :: irun, lm, pdfshape - real, intent(in) :: DT, qc_min(2) - real, intent(in), dimension(irun,lm) :: ALPHA, PL -! real, intent(in), dimension(irun,lm) :: ALPHA, PL, NCnuc - real, intent(inout), dimension(irun,lm) :: te, qv, qcl, qci - &, CF, QAl, QAi, AF, NI, NL, SCICE - -! real :: CFO, pl100, QT, DQ, QSx, DQsx, QCx, QC, QA - real :: CFO, pl100, QT, DQ, QSx, QCx, QC, QA - &, QX, QSLIQ, QSICE, CFALL, DQx, FQA, tem - - real :: esl, esi, esn !temp use only Anning - - integer :: i,k - - do k=1,lm - do i=1,irun - if (qv(i,k) > 1.0e-6) then - QC = QCl(i,k) + QCi(i,k) - QA = QAl(i,k) + QAi(i,k) - !Anning do not let empty cloud exist - if(QC <= 0.) CF(i,k) = 0. - if(QA <= 0.) AF(i,k) = 0. - QCx = QC + QA - QT = QCx + QV(i,k) - CFALL = AF(i,k) + CF(i,k) - -!================================================ -! Find the cloud fraction that would correspond to the current condensate - - pl100 = pl(i,k)*100 - - if (QCx > 0.0) then - tem = 1.0 / QCx - FQA = QA *tem - 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.) - - QSx = ( (QCl(i,k)+QAl(i,k))*QSLIQ - & + (QCi(i,k)+QAi(i,k))*QSICE ) *tem - else - FQA = 0.0 - esn = min(fpvs(TE(i,k)), pl100) - QSx = min(epsqs*esn/(pl100-omeps*esn), 1.) - endif - -! if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 - - QX = QT - QSx*SCICE(i,k) - -! recalculate QX if too low and SCICE qc_min(1)) then - if (QX <= QCx) then - CFo = 1.0 / (1.0 + SQRT(1.0-QX/QCx) ) -! DQ = (Qcx+QCx) / (CFo*CFo) - else - CFo = 1.0 !Outside of distribution but still with condensate -! DQ = (QSx+QSx) * ALPHA(i,k) - endif - else - CFo = 0. - endif - - CFALL = min(1.0, max(CFo, 0.0)) - - AF(i,k) = CFALL * FQA - CF(i,k) = CFALL - AF(i,k) - -! if (TE(i,k) > T_ICE_ALL) then ! don't do anything else for cirrus - - call hystpdf( DT, ALPHA(i,k), PDFSHAPE, qc_min, 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)) - -! endif - !Anning do not let empty cloud exist - if(QCl(i,k)+QCi(i,k) <= 0.0) CF(i,k) = 0.0 - if(QAl(i,k)+QAi(i,k) <= 0.0) AF(i,k) = 0.0 - else - CF(i,k) = 0.0 - AF(i,k) = 0.0 - endif - enddo - enddo - - - end subroutine update_cld - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine hystpdf( DT, ALPHA, PDFSHAPE, qc_min, PL, QV, QCl, QAl - &, QCi, QAi, TE, CF, AF, SCICE, NI, NL) -! &, QCi, QAi, TE, CF, AF, SCICE, NI, NL, i, k) - - real, intent(in) :: DT, ALPHA, PL, qc_min(2) - integer, intent(in) :: pdfshape - real, intent(inout) :: TE, QV, QCl, QCi, CF, QAl, QAi, AF, - & NI, NL, SCICE - - integer, parameter :: nmax=10 - - real :: QCO, QVO, CFO, QAO, TAU - real :: QT, QMX, QMN, DQ, QVtop, sigmaqt1, sigmaqt2, qsnx - -! real :: TEO, QSx, DQsx, QS, DQs - real :: QSx, DQSx, QS, DQs - &, TEp, QSp, CFp, QVp, QCp - &, TEn, QSn, CFn, QVn, QCn - -! real :: QCx, QVx, CFx, QAx, QC, QA, fQi, fQi_A - real :: QCx, QVx, CFx, QAx, QC, QA, fQi - &, dQAi, dQAl, dQCi, dQCl - -! real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, pl100, tmpARR - real :: QX, QSLIQ, QSICE, DQx, pl100, tmpARR - &, ALHX, DQCALL, esn, desdt, tc, hltalt, tterm - -! integer :: N, i, k - integer :: N - - QC = QCl + QCi - QA = QAl + QAi - -! QT = QC + QA + QV -! CFALL = AF + CF -! FQA = 0.0 -! fQi = 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 - -! TEo = TE -! - if (TE <= t_ice_all) then - fqi = 1.0 - elseif (TE >= t_ice_max) then - fqi = 0.0 - else - fqi = (1.0 - (te-t_ice_all)*t_ice_denom) ** ICEFRPWR - endif - - pl100 = pl*100 - - esn = min(fpvs(TE), pl100) - QSx = min(epsqs*esn/(pl100-omeps*esn), 1.) - - if (qsx < 1.0) then - tc = TE - MAPL_TICE - if (TE < MAPL_TICE) then - hltalt = hlatv + hlatf * min(-tc*trinv,1.0) - else - hltalt = hlatv - 2369.0*tc - end if - if (tc >= -ttrice .and. tc < 0.0) then - tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) - & + tc*(pcf(4) + tc*pcf(5)))) - else - tterm = 0.0 - endif - desdt = hltalt*esn/(rgasv*TE*TE) + tterm*trinv - dqsx = qsx*pl100*desdt/(esn*(pl100-omeps*esn)) - else - DQSx = 0.0 - endif - - if (AF < 1.0) then - tmpARR = 1.0 / (1.0-AF) - else - tmpARR = 0.0 - endif - - CFx = CF*tmpARR - QCx = QC*tmpARR - QVx = (QV - QSx*AF) * tmpARR - -! if ( AF >= 1.0 ) QVx = QSx*1.e-4 - if (AF > 0.0) then - QAx = QA/AF - else - QAx = 0.0 - endif - - QT = QCx + QVx - -! TEp = TEo - QSn = QSx - TEn = TE - CFn = CFx - QVn = QVx - QCn = QCx - DQS = DQSx - - do n=1,nmax - - QVp = QVn - QCp = QCn - CFp = CFn - TEp = TEn - - if(pdfshape < 2) then - sigmaqt1 = ALPHA*QSn -! sigmaqt1 = ALPHA*QSn - sigmaqt2 = sigmaqt1 - elseif(pdfshape == 2) then - sigmaqt1 = ALPHA*QSn - sigmaqt2 = sigmaqt1 - elseif(pdfshape == 4) then - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - else - write(0,*)' Aborting : invalid pdfshape=',pdfshape - stop - 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.0-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(pdfshape == 1) then - QCn = QCp + (QCn- QCp) - & / (1.0 - (CFn*(ALPHA-1.0) - QCn/QSn) *DQS*ALHX) - elseif(pdfshape == 2) then - if (n < nmax) QCn = QCp + ( QCn - QCp ) * 0.5 - endif - - QVn = QVp - (QCn - QCp) - TEn = TEp + ALHX * ((QCn-QCp)*(1.0-AF) + (QAo-QAx)*AF) - - if (abs(Ten-Tep) < 0.00001) exit - - if (TEn <= t_ice_all) then - fqi = 1.0 - elseif (TEn >= t_ice_max) then - fqi = 0.0 - else - fqi = (1.0 - (te-t_ice_all)*t_ice_denom) ** ICEFRPWR - endif - - DQS = 0.0 - - if (n < nmax) then - esn = min(fpvs(TEn), pl100) - QSn = min(epsqs*esn/(pl100-omeps*esn), 1.0) - - if (qsn < 1.0) then - tc = TEn - MAPL_TICE - if (TEn < MAPL_TICE) then - hltalt = hlatv + hlatf * min(-tc*trinv,1.0) - else - hltalt = hlatv - 2369.0*tc - end if - if (tc >= -ttrice .and. tc < 0.0) then - tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) - & + tc*(pcf(4) + tc*pcf(5)))) - else - tterm = 0.0 - end if - desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv - dqs = QSn*pl100*desdt / (esn*(pl100-omeps*esn)) -! else -! DQS = 0.0 - endif - endif - - enddo - - CFo = CFn - CF = CFn - QCo = QCn -! QVo = QVn -! TEo = TEn -! TE = TEn - -! Update prognostic variables. Deal with special case of AF=1 -! Temporary variables QCo, QAo become updated grid means. - - if (AF < 1.0) then - CF = CFo * (1.0-AF) - QCo = QCo * (1.0-AF) - QAo = QAo * AF - else -! Special case AF=1, i.e., box filled with anvil. -! - Note: no guarantee QV_box > QS_box - - CF = 0. ! Remove any other cloud - QAo = QA + QC ! Add any LS condensate to anvil type - QCo = 0. ! Remove same from LS - QT = QAo + QV ! Total water - -! Now set anvil condensate to any excess of total water -! over QSx (saturation value at top) - QAo = MAX(QT-QSx, 0.) - endif - - 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 - dQCi = QCx * fQi - dQCl = QCx - dQCi - 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 - dQAi = QAx * fQi - dQAl = QAx - dQAi - end if - -! if(.false.) then !Anning turn it off causing unstable - if ( AF < 1.e-5 ) then - dQAi = -QAi - dQAl = -QAl - af = 0.0 - end if - if ( CF < 1.e-5 ) then - dQCi = -QCi - dQCl = -QCl - cf = 0.0 - 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 - &, qc_min) - - end subroutine hystpdf - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine pdffrac (flag,qtmean,sigmaqt1,sigmaqt2,qstar,clfrac) - implicit none - - integer flag - - real :: qtmean, sigmaqt1, sigmaqt2, qstar, clfrac - - real :: qtmode, qtmin, qtmax, qtmedian, aux - - if(flag == 1) then - aux = qtmean + sigmaqt1 - qstar - if (aux < 0.0) then - clfrac = 0. - else - if(sigmaqt1 > 0.0) then - clfrac = min(0.5*aux/sigmaqt1, 1.0) - else - clfrac = 1. - endif - endif - elseif(flag == 2) then - qtmode = qtmean + (sigmaqt1-sigmaqt2)/3. - qtmin = min(qtmode-sigmaqt1,0.) - qtmax = qtmode + sigmaqt2 - if(qtmax < qstar) then - clfrac = 0. - elseif ( (qtmode <= qstar).and.(qstar < qtmax) ) then - clfrac = (qtmax-qstar)*(qtmax-qstar) / - & ((qtmax-qtmin)*(qtmax-qtmode)) - elseif ( (qtmin <= qstar).and.(qstar < qtmode) ) then - clfrac = 1. - ((qstar-qtmin)*(qstar-qtmin) - & /( (qtmax-qtmin)*(qtmode-qtmin))) - elseif ( qstar <= qtmin ) then - clfrac = 1. - endif - elseif(flag == 4) then - if (qtmean > 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, pdfflag) - - integer, intent(in) :: pdfflag - 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, sigmaqt1, sigmaqt2, qsnx, 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 = max(min(epsqs*esi/(pl100-omeps*esi), 1.0), 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 < 2) then - sigmaqt1 = max(ALPHA, 0.1) * QSn - sigmaqt2 = max(ALPHA, 0.1) * QSn - elseif(pdfflag == 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 == 4) then - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - else - write(0,*)' Aborting : invalid pdfflag=',pdfflag - stop - endif - - call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) - - PF = min(max(CFio*(1.0-CFALL), 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/gfsphysics/physics/cldwat2m_micro.F b/gfsphysics/physics/cldwat2m_micro.F deleted file mode 100644 index 56aa06a18..000000000 --- a/gfsphysics/physics/cldwat2m_micro.F +++ /dev/null @@ -1,5509 +0,0 @@ - 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, & - & pi => con_pi - 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,dsout2,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, rhc) -! & 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(in) :: rhc(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), dimension(pcols,pver) :: drout2, dsout2 - -!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 ! big loop1 - k loop - -! 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 ! big i loop1 - -#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 loop1 - 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 - tx1 = one / lcldm(i,k) - qric(i,k) = min(qrn(i,k)*tx1, 10.e-3_r8) - nric(i,k) = max(nrn(i,k)*tx1, 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 - tx1 = one / icldm(i,k) - qniic(i,k) = min(qsnw(i,k)*tx1, 10.e-3_r8) - nsic(i,k) = max(nsnw(i,k)*tx1, 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-7_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-7_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 = deltat / lcldm(i,k) -! tx2 = deltat / icldm(i,k) -! dumc(i,k) = max(qrn(i,k)+qrtend(i,k)*tx1, zero) -! dumi(i,k) = max(qsnw(i,k)+qnitend(i,k)*tx2,zero) -! dumnc(i,k) = max(nrn(i,k)+nrtend(i,k)*tx1, zero) -! dumni(i,k) = max(nsnw(i,k)+nstend(i,k)*tx2, zero) - - 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) - - qrout(i,k) = qrout(i,k) + qrn(i,k) - qsout(i,k) = qsout(i,k) + qsnw(i,k) - nrout(i,k) = nrout(i,k) + nrn(i,k)*rho(i,k) - nsout(i,k) = nsout(i,k) + nsnw(i,k)*rho(i,k) -!....................................................................... - 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/gfsphysics/physics/cnvc90.f b/gfsphysics/physics/cnvc90.f deleted file mode 100644 index 82e755530..000000000 --- a/gfsphysics/physics/cnvc90.f +++ /dev/null @@ -1,90 +0,0 @@ - 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/gfsphysics/physics/co2hc.f b/gfsphysics/physics/co2hc.f deleted file mode 100644 index 073b999ff..000000000 --- a/gfsphysics/physics/co2hc.f +++ /dev/null @@ -1,1738 +0,0 @@ -!*********************************************************************** -! 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/gfsphysics/physics/cs_conv.F90 b/gfsphysics/physics/cs_conv.F90 deleted file mode 100644 index 8f3b41082..000000000 --- a/gfsphysics/physics/cs_conv.F90 +++ /dev/null @@ -1,3935 +0,0 @@ -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 -! April 2017 : S. moorthi - many changes including removing elam and making gcym -! a function of cloud type. This makes it possible for -! AW affect propagate to other routines such as CUMUPR -! Apr 12, 2017 : S. Moorthi Added flx_form logical and relevant code to compute AW -! without flux form when false. -! May 17, 2017 : S. Moorthi - Added routine CUMSBW for just momentum change -! in advective form -! Sep 08, 2017 : D. Dazlich - tracers in flux form for AW -! Nov -- 2017 : S. Moorthi - fix some bugs and fix fluxform for tracers -! Nov 22 2017 : S. Moorthi - add kcnv array to identify points where deep convection -! operates - 0 - no convection 1 - with convection -! Jan 30 2018 : S, Moorthi - fixed sigmad dimension error in CUMDWN and an error when adjustp=.true. -! -! May -- 2018 : S. Moorthi - modified cumup to compute total workfunction (positive plus negative) -! and negative part only and to let a particular ensemble exist only if -! the ratio of negative to total is less than some prescribed percent. -! Also, added an extra iteration in this k loop. Reduced some memory. -! June 2018 : S. Moorthi - the output mass fluxes ud_mf, dd_mf and dt_mf are over time step delta -! -! 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, epsln=1.e-10_r8 - - real(r8), parameter :: fact1=(cvap-cliq)/rvap, fact2=el/rvap-fact1*t0c ! to calculate d(qs)/dT - - logical, parameter :: adjustp=.true. -! logical, parameter :: adjustp=.false. - -! Tuning parameters set from namelist -! -! real(r8), parameter, public :: CLMD = 0.60, & ! entrainment efficiency (now thru argument) - real(r8), parameter, public :: & - PA=0.15, & ! factor for buoyancy to affect updraft velocity - CPRES = 0.55, & ! pressure factor for momentum transport - ALP0 = 5.0e7, & ! alpha parameter in prognostic closure -! ALP0 = 8.0e7, & ! alpha parameter in prognostic closure -! CLMP = (one-CLMD)*(PA+PA), & -! CLMDPA = CLMD*PA, & - spblmin=0.05, & ! minimum cloudbase height in p/ps - spblmax=0.30, & ! maximum cloudbase height in p/ps -! spblcrit=0.03, & ! minimum cloudbase height in p/ps -! spblcrit=0.035,& ! minimum cloudbase height in p/ps -! spblcrit=0.025,& ! minimum cloudbase height in p/ps - cincrit= -150.0 -! cincrit= -120.0 -! cincrit= -100.0 - -!DD precz0 and preczh control partitioning of water between detrainment -!DD and precipitation. Decrease for more precip - - real(r8), public :: precz0, preczh, clmd, clmp, clmdpa -! -! 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 - - 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 - -! PUBLIC: interfaces -! - public cs_convr ! CS scheme main driver - - contains - -!--------------------------------------------------------------------------------- - subroutine cs_convr(IM , IJSDIM , KMAX , ntracp1 , NN, & - 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, & - clmdin , sigma , do_aw , do_awdd , flx_form, & - lprnt , ipr, kcnv, & -! for coupling to MG microphysics - 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) - -!--------------------------------------------------------------------------------- -! Purpose: -! -! Main driver for Chikira-Sugiyama convective scheme -! -! Author: Minoru Chikira -! -!--------------------------------------------------------------------------------- - - implicit none -! -! input arguments -! - INTEGER, INTENT(IN) :: IM,IJSDIM, KMAX, ntracp1, nn, NTR, mype, nctp, mp_phys, kdt,lat !! DD, for GFS, pass in - logical, intent(in) :: otspt(1:ntracp1,1:2)! otspt(:,1) - on/off switch for tracer transport by updraft and - ! downdraft. should not include subgrid PDF and turbulence - ! otspt(:,2) - on/off switch for tracer transport by subsidence - ! should include subgrid PDF and turbulence - - 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,nn) ! 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, clmdin -! 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, flx_form -! -! 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, & -! 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 - integer, intent(inout) :: kcnv(im) ! zero if no deep convection and 1 otherwise - -!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), dimension(IM,KMAX,nctp) :: vverti - - 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] - - 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) ! pressure difference between layers [Pa] - real(r8) delpi(IJSDIM,KMAX) ! grav/delp -! -! 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 - -!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 - -! lprnt = kdt == 1 .and. mype == 38 -! ipr = 43 - - precz0 = precz0in - preczh = preczhin - clmd = clmdin - CLMP = (one-CLMD)*(PA+PA) - CLMDPA = CLMD*PA -! - if (first) then - 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) - delpi(i,k) = grav / delp(i,k) - 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 -! if (lprnt) write(0,*)'in cs clw1b=',clw(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)'in cs clw2b=',clw(ipr,:,2),' kdt=',kdt - - do n=2,NTR - do k=1,KMAX - do i=1,IJSDIM - GDQ(i,k,n) = clw(i,k,n-1) - enddo - enddo - enddo -! if (lprnt) write(0,*)' incs tke=',gdq(ipr,1:25,ntr) -! -!*************************************************************************************** -! -! calculate temperature at interfaces -! - - 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 - vverti(i,k,n) = zero - enddo - enddo - enddo - do k=1,kmax - do i=ists,iens - sigma(i,k) = zero - enddo - enddo -! -!*************************************************************************************** - call CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions - otspt(1:ntr,1), otspt(1:ntr,2), & - lprnt , ipr , & - GTT , GTQ , GTU , GTV , & ! 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 - delp , delpi , & - DELTA , DELTI , ISTS , IENS, mype,& ! input - fscav, fswtr, wcbmaxm, nctp, & - sigma, vverti, & ! input/output !DDsigma - do_aw, do_awdd, flx_form) -! -! -!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) = max(zero, GDQ(i,k,n) + GTQ(i,k,n) * delta) - enddo - enddo - enddo -! if (lprnt) write(0,*)' aftcs_cum tkein=',gdq(ipr,1:25,ntr),' delta=',delta -! if (lprnt) write(0,*)' aftcs_cum tke=',clw(ipr,1:25,ntr-1) -! if (lprnt) write(0,*)'in cs clw1a=',clw(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)'in cs clw2a=',clw(ipr,:,2),' kdt=',kdt -! - do k=1,KMAX - do i=1,IJSDIM - q(i,k) = max(zero, 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 - enddo - enddo - - - if (mp_phys == 10) 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)) - - - wrk = qicn(i,k) + qlcn(i,k) - if (wrk > 1.0e-12) then - cnv_fice(i,k) = qicn(i,k) / wrk - else - cnv_fice(i,k) = 0.0 - endif -! -! CNV_MFD(i,k) = dt_mf(i,k) * (1.0/delta) - CNV_MFD(i,k) = dt_mf(i,k) - CNV_DQLDT(i,k) = wrk / 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(1.0, 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 k=1,KMAX - do i=1,ijsdim - do n=1,nctp - w_upi(i,k) = w_upi(i,k) + vverti(i,k,n) - enddo - if (sigma(i,k) > 1.0e-10) then - w_upi(i,k) = w_upi(i,k) / sigma(i,k) - else - w_upi(i,k) = 0.0 - endif - 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)) - 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_MFD(i,k) = dt_mf(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)),0.25)) -! & 500*ud_mf(i,k)),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 & - / (max(cf_upi(i,k),1.e-12)*gdp(i,k)) - enddo - enddo - endif - endif - -!**************************************************************************** - - KTMAX = 1 - do n=1,nctp - do i=1,IJSDIM - KTMAX(i) = max(KTMAX(i), KT(i,n)) - enddo - enddo -! - do i=1,IJSDIM - prec(i) = GTPRP(i,1) - snow(i) = GSNWP(i,1) - if (prec(i)+snow(i) > 0.0) then - kcnv(i) = 1 - else - kcnv(i) = 0 - endif - enddo - -! multiplying mass fluxes by the time step - - do k=1,kmax - do i=1,ijsdim - ud_mf(i,k) = ud_mf(i,k) * delta - dd_mf(i,k) = dd_mf(i,k) * delta - dt_mf(i,k) = dt_mf(i,k) * delta - enddo - enddo - -! if (lprnt) then -! write(0,*)' aft cs_cum prec=',prec(ipr),'GTPRP=',GTPRP(ipr,1) -! 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 , & ! output - GTPRP , GSNWP , GMFX0 , & ! output - GMFX1 , CAPE , KT , & ! output - CBMFX , & ! modified - GDT , GDQ , GDU , GDV , & ! input - GDTM , & ! input - GDP , GDPM , GDZ , GDZM , & ! input - delp , delpi , & - DELTA , DELTI , ISTS , IENS, mype,& ! input - fscav, fswtr, wcbmaxm, nctp, & ! - sigma, vverti, & ! input/output !DDsigma - do_aw, do_awdd, flx_form ) -! - IMPLICIT NONE - - Integer, parameter :: ntrq=4 ! starting index for tracers - INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, mype, nctp, ipr !! DD, for GFS, pass in - logical, intent(in) :: do_aw, do_awdd, flx_form ! 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 - -! 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) :: sigma !DDsigma sigma totaled over cloud type - on interfaces (1=sfc) - real(r8), intent(out), dimension(IM,KMAX,nctp) :: vverti - -! for computing AW flux form of tendencies -! The tendencies are summed over all cloud types -! real(r8), intent(out), dimension(IM,KMAX) :: & !DDsigmadiag - real(r8), allocatable, dimension(:,:) :: sfluxterm, qvfluxterm,& ! tendencies of DSE and water vapor due to eddy mass flux - 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 - condtermt, condtermq, frzterm, & - prectermq, prectermfrz - real(r8), allocatable, dimension(:,:,:) :: trfluxterm ! tendencies of tracers due to eddy mass flux -! -! [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), allocatable :: GPRCC (:, :) ! rainfall -! 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) GDCFRC(IJSDIM, KMAX) ! cloud fraction -! - REAL(r8) GDW (IJSDIM, KMAX) ! total water - REAL(r8) DELP (IJSDIM, KMAX) - REAL(r8) DELPI (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, NCTP)! 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) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracer - 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) GCtrT (IJSDIM, ntrq:ntr, NCTP) ! cloud top tracer - 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) ACWF (IJSDIM ) ! 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 -! -! 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 vapor - REAL(r8) gdtrm(ntrq:ntr) ! tracer - -! 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 - REAL(r8) GCtrM (IJSDIM, KMAX, ntrq:ntr) ! cloud tracer (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 - REAL(r8), dimension(Kmax+1,ntrq:ntr) :: trfluxtem ! tracer - -! 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 - real(r8), dimension(ijsdim,kmax,ntrq:ntr) :: gctrbl !DDsigmadiag tracer updraft profiles below cloud Base -! 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, sigmai, 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), allocatable, dimension(:,:) :: dtdwn, & ! t tendency downdraft detrainment - dqvdwn, & ! qv tendency downdraft detrainment - dqldwn, & ! ql tendency downdraft detrainment - dqidwn ! qi tendency downdraft detrainment - REAL(r8), allocatable, dimension(:,:,:) :: dtrdwn ! tracer 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, l, l1 -! - LOGICAL, SAVE :: OFIRST = .TRUE. ! called first time? -! - - IF (OFIRST) THEN - OFIRST = .FALSE. - IF (OINICB) THEN - CBMFX = zero - ENDIF - ENDIF -! - 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 - 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 - sigma(i,k) = zero - enddo - enddo - if (flx_form) then - allocate(sfluxterm(ijsdim,kmax), qvfluxterm(ijsdim,kmax), qlfluxterm(ijsdim,kmax), & - qifluxterm(ijsdim,kmax), condtermt(ijsdim,kmax), condtermq(ijsdim,kmax), & - frzterm(ijsdim,kmax), prectermq(ijsdim,kmax), prectermfrz(ijsdim,kmax), & - dtdwn(ijsdim,kmax), dqvdwn(ijsdim,kmax), dqldwn(ijsdim,kmax), & - dqidwn(ijsdim,kmax), trfluxterm(ijsdim,kmax,ntrq:ntr), & - dtrdwn(ijsdim,kmax,ntrq:ntr)) - do k=1,kmax - do i=1,ijsdim - 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 - dqldwn(i,k) = zero - dqidwn(i,k) = zero - cmdet(i,k) = zero - enddo - enddo - do n = ntrq,ntr - do k=1,kmax - do i=1,ijsdim - trfluxterm(i,k,n) = zero - dtrdwn(i,k,n) = zero - enddo - enddo - enddo - endif - 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 - 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 - esat = min(gdp(i,k), fpvs(gdt(i,k))) - GDQS(I,K) = min(EPSV*esat/max(gdp(i,k)+epsvm1*esat, 1.0e-10), 0.1) - tem = one / GDT(I,K) - FDQS(I,K) = GDQS(I,K) * tem * (fact1 + fact2*tem) ! calculate d(qs)/dT - 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(1,1,1) , KBMX , & ! output - ntr , ntrq , & - GCHB , GCWB , GCUB , GCVB , & ! output - GCIB , gctrb, & ! output - GDH , GDW , GDHS , GDQS , & ! input - GDQ(1,1,iti) , GDU , GDV , GDZM , & ! input - GDPM , FDQS , GAM , & ! input - lprnt, ipr, & - ISTS , IENS , & !) ! input - gctbl, gcqbl,gdq,gcwbl, gcqlbl, gcqibl, gctrbl) ! sub cloud tendencies -! -! Compute CAPE and CIN -! - DO I=ISTS,IENS - CAPE(i) = zero - CIN(i) = zero - JBUOY(i) = 0 - enddo - DO K=2,KMAX - DO I=ISTS,IENS - if (kb(i) > 0) then - 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 - IF (BUOY > zero .AND. JBUOY(I) >= -1) THEN - CAPE(I) = CAPE(I) + BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) - JBUOY(I) = 2 - ELSEIF (BUOY < zero .AND. JBUOY(I) /= 2) THEN - CIN(I) = CIN(I) - BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) - JBUOY(I) = -1 - ENDIF - endif - ENDDO - ENDDO - DO I=ISTS,IENS - IF (JBUOY(I) /= 2) CIN(I) = -999.D0 - if (cin(i) < cincrit) kb(i) = -1 - ENDDO - -!DDsigma some initialization before summing over cloud type - do k=1,kmax ! Moorthi - do i=1,ijsdim - lamdaprod(i,k) = one - enddo - enddo - - do ctp=2,nctp - do k=1,kmax - do i=1,ijsdim - gcym(i,k,ctp) = gcym(i,k,1) - enddo - 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 - - do k=1,kmax ! Moorthi - do i=1,ijsdim - dqcondtem(i,k) = zero - dqprectem(i,k) = zero - dfrzprectem(i,k) = zero - dtfrztem(i,k) = zero - dtcondtem(i,k) = zero - enddo - enddo -! getting more incloud profiles of variables to compute eddy flux tendencies -! and condensation rates - -!! CUMUP computes In-cloud Properties - -! DH* GNU crashes - check all arguments to CUMUP for their dimensions -! before and after CUMUP (i.e. here), and inside the routine, in -! particular: gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim,gctrm -! also, inside, check that no reads/writes out of bounds occur *DH - CALL CUMUP(IJSDIM, KMAX, NTR, ntrq, & !DD dimensions - ACWF , & ! 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) , gctrt(1,ntrq:ntr,ctp), & ! output - KT (1,CTP) , KTMX(CTP) , & ! output - GCYM(1,1,CTP) , & ! modified - wcv , & ! !DD-sigma new output - GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag - GCIB , gctrb , & ! 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 - KB , CTP , ISTS , IENS , & ! input - gctm , gcqm, gcwm, gchm, gcwt, gclm, gcim, gctrm, & ! additional incloud profiles and cloud top total water - lprnt , ipr ) -! -!! CUMBMX computes Cloud Base Mass Flux - - CALL CUMBMX(IJSDIM, KMAX, & !DD dimensions - CBMFX(1,CTP), & ! modified - ACWF , 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 - - do i=ISTS,IENS - if (flx_form) then -! initialize eddy fluxes for cloud type ctp - do k=1,kmax+1 - sfluxtem(k) = zero - qvfluxtem(k) = zero - qlfluxtem(k) = zero - qifluxtem(k) = zero - enddo - do n=ntrq,ntr ! tracers - do k=1,kmax+1 - trfluxtem(k,n) = zero - enddo - enddo - endif - - 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 base index - 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)) - do n = ntrq,NTR - GDtrM(n) = half * (GDQ(I,K,n) + GDQ(I,KM1,n)) ! as computed in cumup - enddo - mflx_e = gcym(i,k,ctp) * cbmfl ! mass flux at level k for cloud ctp - - if (do_aw) then - -! this is the computation of lamda for a cloud type, and then updraft area fraction -! (sigmai for a single cloud type) - - 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) = max(zero, min(one, sigma(i,k) + sigmai(i,k,ctp))) - - sigmai = lamdai / lamdaprod(i,k) - sigma(i,k) = max(zero, min(one, sigma(i,k) + sigmai)) - vverti(i,k,ctp) = sigmai * wcv(i,k) - else - sigma(i,k) = 0.0 - endif - - if (flx_form) then - -! fsigma = 1.0 ! no aw effect, comment following lines to undo AW - fsigma = one - sigma(i,k) - -! compute tendencies based on mass flux, and tendencies based on condensation -! fsigma is the AW reduction of flux tendencies - - if(k == kbi) then - do l=2,kbi ! compute eddy fluxes below cloud base - tem = - fsigma * gcym(i,l,ctp) * cbmfl - -! first get environment variables at layer interface - l1 = l - 1 - GDQM = half * (GDQ(I,l,1) + GDQ(I,l1,1)) - GDlM = half * (GDQ(I,l,3) + GDQ(I,l1,3)) - GDiM = half * (GDQ(I,l,2) + GDQ(I,l1,2)) -!! GDwM = half * (GDw(I,l) + GDw(I,l1)) - do n = ntrq,NTR - GDtrM(n) = half * (GDQ(I,l,n) + GDQ(I,l1,n)) ! as computed in cumup - enddo - -! flux = mass flux * (updraft variable minus environment variable) -!centered differences - sfluxtem(l) = tem * (gdtm(i,l)-gctbl(i,l)) - qvfluxtem(l) = tem * (gdqm-gcqbl(i,l)) - qlfluxtem(l) = tem * (gdlm-gcqlbl(i,l)) - qifluxtem(l) = tem * (gdim-gcqibl(i,l)) - do n = ntrq,NTR - trfluxtem(l,n) = tem * (gdtrm(n)-gctrbl(i,l,n)) - enddo -! if(lprnt .and. i == ipr) write(0,*)' l=',l,' kbi=',kbi,' tem =', tem,' trfluxtem=',trfluxtem(l,ntr),& -! ' gdtrm=',gdtrm(ntr),' gctrbl=',gctrbl(i,l,ntr),' gq=',GDQ(I,l,ntr),GDQ(I,l1,ntr),' l1=',l1,' ctp=',ctp,& -! ' fsigma=',fsigma,' gcym=',gcym(i,l,ctp),' cbmfl=',cbmfl,' sigma=',sigma(i,k) - -! The following commented out by Moorthi on April 13, 2018 because tke below -! cloud base becomes too large otherwise when shoc is used - -!upstream - This better matches what the original CS tendencies do -! sfluxtem(l) = tem * (gdt(i,l)+gocp*(gdz(i,l)-gdzm(i,l))-gctbl(i,l)) -! qvfluxtem(l) = tem * (gdq(i,l,1)-gcqbl(i,l)) -! qlfluxtem(l) = tem * (gdq(i,l,3)-gcqlbl(i,l)) -! qifluxtem(l) = tem * (gdq(i,l,2)-gcqibl(i,l)) -! do n = ntrq,NTR -! trfluxtem(l,n) = tem * (gdq(i,l,n)-gctrbl(i,l,n)) -! enddo - - enddo - else -! 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)) - do n = ntrq,NTR - trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) - enddo - -!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)) -! do n = ntrq,NTR -! trfluxtem(k,n) = tem * (gdq(i,k,n)-gctrm(i,k,n)) -! enddo -! if(lprnt .and. i == ipr) write(0,*)' k=',k,' kbi=',kbi,' tem =', tem,' kk=',kk,& -! ' gctrm=',gctrm(i,k,ntr),' gdq=',gdq(I,k,ntr),' gctrm=',gctrm(I,k,ntr),' ctp=',ctp,& -! ' fsigma=',fsigma,' mflx_e=',mflx_e,' trfluxtemk=',trfluxtem(k,ntr),' sigma=',sigma(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)) -! do n = ntrq,NTR -! trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) -! enddo -! endif - -! if(lprnt .and. i == ipr) write(0,*)' k=',k,' kbi=',kbi,' tem =', tem,' kk=',kk,& -! ' gctrm=',gctrm(i,k,ntr),' gdtrm=',gdtrm(ntr),' gctrm=',gctrm(I,k,ntr),' ctp=',ctp,& -! ' fsigma=',fsigma,' mflx_e=',mflx_e,' trfluxtemk=',trfluxtem(k,ntr),' sigma=',sigma(i,k) - - -! 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)) - tem = cbmfl * (one - 0.5*(sigma(i,k)+sigma(i,km1))) - tem1 = gcym(i,k,ctp) * (one - sigma(i,k)) - tem2 = gcym(i,km1,ctp) * (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 - endif ! if (flx_form) - enddo ! end of k=kbi,kk loop - - endif ! end of if(cbmfl > zero) - - -! get tendencies by difference of fluxes, sum over cloud type - - if (flx_form) then - do k = 1,kk - delpinv = delpi(i,k) -! sum single cloud microphysical tendencies over all cloud types - condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) * delpinv - condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) * delpinv - prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) * delpinv - prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) * delpinv - frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) * delpinv - -! 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 - do n = ntrq,ntr - trfluxterm(i,k,n) = trfluxterm(i,k,n) - (trfluxtem(k+1,n) - trfluxtem(k,n)) * delpinv - enddo -! if (lprnt .and. i == ipr) write(0,*)' k=',k,' trfluxtem=',trfluxtem(k+1,ntr),trfluxtem(k,ntr),& -! ' ctp=',ctp,' trfluxterm=',trfluxterm(i,k,ntr) - enddo - endif ! if (flx_form) - - enddo ! end of i loop -! - do i=ists,iens - if (cbmfx(i,ctp) > zero) then - tem = one - sigma(i,kt(i,ctp)) - gcyt(i,ctp) = tem * gcyt(i,ctp) - gtprt(i,ctp) = tem * gtprt(i,ctp) - gclt(i,ctp) = tem * gclt(i,ctp) - gcht(i,ctp) = tem * gcht(i,ctp) - gcqt(i,ctp) = tem * gcqt(i,ctp) - gcit(i,ctp) = tem * gcit(i,ctp) - if (.not. flx_form) then - do n = ntrq,ntr - gctrt(i,n,ctp) = tem * gctrt(i,n,ctp) - enddo - end if - gcut(i,ctp) = tem * gcut(i,ctp) - gcvt(i,ctp) = tem * gcvt(i,ctp) - do k=1,kmax - kk = kb(i) - if (k < kk) then - tem = one - sigma(i,kk) - tem1 = tem - else - tem = one - sigma(i,k) - tem1 = one - 0.5*(sigma(i,k)+sigma(i,k-1)) - endif - gcym(i,k,ctp) = tem * gcym(i,k,ctp) - gprciz(i,k) = tem1 * gprciz(i,k) - gsnwiz(i,k) = tem1 * gsnwiz(i,k) - gclz(i,k) = tem1 * gclz(i,k) - gciz(i,k) = tem1 * gciz(i,k) - enddo - endif - enddo - -! -! Cloud Mass Flux & Precip. - CALL CUMFLX(IM , IJSDIM, KMAX , & !DD dimensions - GMFX0 , GPRCI , GSNWI , CMDET, & ! output - QLIQ , QICE , GTPRC0, & ! output - CBMFX(1,CTP) , GCYM(1,1,ctp), GPRCIZ , GSNWIZ , & ! input - GTPRT(1,CTP) , GCLZ , GCIZ , GCYT(1,ctp),& ! input - KB , KT(1,CTP) , KTMX(CTP) , & ! input - ISTS , IENS ) ! 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) -! 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 - if (.not. flx_form) then - CALL CUMDET(im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - GTT , GTQ , GTU , GTV , & ! modified - GDH , GDQ , GDU , GDV , & ! input -! GTT , GTQ , GTCFRC, GTU , GTV , & ! modified -! GDH , GDQ , GDCFRC, GDU , GDV , & ! input - CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input - GCLT , GCIT , GCUT , GCVT , GDQ(1,1,iti),& ! input - gctrt , & - KT , ISTS , IENS, nctp ) ! input - endif - -!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 , ntrq , & ! DD dimensions - GTT , GTQ , GTU , GTV , & ! modified - GMFLX , & ! modified updraft+downdraft flux - 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 , FDQS , DELP , DELPI , & ! input - sigmad, do_aw , do_awdd, flx_form, & ! DDsigma input - dtmelt, dtevap, dtsubl, & ! DDsigma input - dtdwn , dqvdwn, dqldwn, dqidwn, & ! DDsigma input - dtrdwn, & - KB , KTMXT , ISTS , IENS ) ! input - -! 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 - - if (.not. flx_form) then -! Cloud Subsidence Heating -! -----------------------= - CALL CUMSBH(IM , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - GTT , GTQ , & ! modified - GTU , GTV , & ! modified - GDH , GDQ , GDQ(1,1,iti) , & ! input - GDU , GDV , & ! input - DELPI , GMFLX , GMFX0 , & ! input - KTMXT , CPRES , kb, ISTS , IENS ) ! input - else - CALL CUMSBW(IM , IJSDIM, KMAX , & !DD dimensions - GTU , GTV , & ! modified - GDU , GDV , & ! input - DELPI , GMFLX , GMFX0 , & ! input - KTMXT , CPRES , kb, ISTS , IENS ) ! input - - endif -! -! for now the following routines appear to be of no consequence to AW - DD -! - if (.not. flx_form) then -! Tracer Updraft properties -! ------------- - allocate (gprcc(ijsdim,ntr)) - do n=1,ntr - do i=1,ijsdim - gprcc(i,n) = zero - enddo - enddo - CALL CUMUPR(im , IJSDIM, KMAX , NTR , & !DD dimensions - GTQ , GPRCC , & ! modified - GDQ , CBMFX , & ! input - GCYM , GCYT , GCQT , GCLT , GCIT , & ! input - GTPRT , GTEVP , GTPRC0, & ! input - KB , KBMX , KT , KTMX , KTMXT , & ! input - DELPI , OTSPT1, ISTS , IENS, & ! input - fscav , fswtr, nctp) -! -! Tracer Change due to Downdraft -! --------------- - CALL CUMDNR(im ,IJSDIM , KMAX , NTR , & !DD dimensions - GTQ , & ! modified - GDQ , GMDD , DELPI , & ! input - KTMXT , OTSPT1, ISTS , IENS ) ! input -!! -!! Tracer change due to Subsidence -!! --------------- -!! This will be done by cumsbh, now DD 20170907 -! CALL CUMSBR(im , IJSDIM, KMAX , NTR , & !DD dimensions -! GTQ , & ! modified -! GDQ , DELPI , & ! input -! GMFLX , KTMXT , OTSPT2, & ! input -! ISTS , IENS ) ! input - - endif - -! if this tracer not advected zero it out - DO n = ntrq,NTR - if (.not. OTSPT2(n)) then - DO K=1,KMAX - DO I=ISTS,IENS - gtq(i,k,n) = 0.0 - ENDDO - ENDDO - endif - ENDDO - -! if(do_aw .and. flx_form) then ! compute AW tendencies - if(flx_form) then ! compute AW tendencies - ! 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 - 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) * gravi - ENDDO - ENDDO - -! replace tracer tendency only if to be advected. - DO n = ntrq,NTR - if (OTSPT2(n)) then - DO K=1,KMAX - DO I=ISTS,IENS - gtq(i,k,n) = dtrdwn(i,k,n) + trfluxterm(i,k,n) - ENDDO - ENDDO - endif - ENDDO -! if (lprnt) write(0,*)' endcs_cum gtq=',gtq(ipr,1:25,ntr) -! if (lprnt) write(0,*)' endcs_cum trfluxterm=',trfluxterm(ipr,1:25,ntr) - - endif ! if (flx_form) - -!!!! this section may need adjustment for cloud ice and water with flux_form -! -! 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 -! -!!!!! end fixer section - -! 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 - - -! -! 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(flx_form .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)) - else - moistening_aw(i) = 1.0 - endif - ENDDO - do k=1,kmax - DO I = ISTS, IENS - gprcp(i,k) = max(0.0, gprcp(i,k) * moistening_aw(i)) - gsnwp(i,k) = max(0.0, gsnwp(i,k) * moistening_aw(i)) - ENDDO - enddo - - endif -! -! 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 -! -!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 -! - if (flx_form) then - deallocate(sfluxterm, qvfluxterm, qlfluxterm, qifluxterm,& - condtermt, condtermq, frzterm, prectermq, & - prectermfrz, dtdwn, dqvdwn, dqldwn, & - dqidwn, trfluxterm, dtrdwn) - endif - if (allocated(gprcc)) deallocate(gprcc) - -! - END SUBROUTINE CS_CUMLUS -!*********************************************************************** - SUBROUTINE CUMBAS & !! cloud base - ( IJSDIM, KMAX , & !DD dimensions - KB , GCYM , KBMX , & ! output - ntr , ntrq , & - GCHB , GCWB , GCUB , GCVB , & ! output - GCIB , gctrb, & ! output - GDH , GDW , GDHS , GDQS , & ! input - GDQI , GDU , GDV , GDZM , & ! input - GDPM , FDQS , GAM , & ! input - lprnt, ipr, & - ISTS , IENS , gctbl, gcqbl ,gdq, & - gcwbl, gcqlbl, gcqibl, gctrbl ) ! input !DDsigmadiag add updraft profiles below cloud base -! -! - IMPLICIT NONE -! integer, parameter :: crtrh=0.80 - integer, parameter :: crtrh=0.70 - INTEGER, INTENT(IN) :: IJSDIM, KMAX , ntr, ntrq ! DD, for GFS, pass in - integer ipr - logical lprnt -! -! [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 - REAL(r8) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracer - -!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 - REAL(r8), dimension(ijsdim,kmax,ntrq:ntr) :: gctrbl !DDsigmadiag -! -! [INPUT] - REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy - REAL(r8) GDW (IJSDIM, KMAX) ! total water - REAL(r8) GDq (IJSDIM, KMAX, ntr) ! water vapor and tracer - 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, GAMX, wrk -! REAL(r8) DELZ, QSL, GAMX, wrk -! REAL(r8), dimension(ijsdim,kmax) :: gchbl !DDsigmadiag - real(r8), dimension(ijsdim) :: gcqb, tx1, spbl, qsl - INTEGER I, K, kp1, n -! -! [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 - KBMAX = KMAX/2 ! 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 - KB(I) = -1 - tx1(i) = one / gdpm(i,1) - ENDDO - DO K=KLCLB+1,KBMAX-1 - DO I=ISTS,IENS - GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp - QSL(i) = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) - spbl(i) = one - gdpm(i,k) * tx1(i) - IF (GDW(I,KLCLB) >= QSL(i) .and. kb(i) < 0 & - .and. spbl(i) >= spblmin) THEN -! .and. spbl(i) >= spblcrit .and. spbl(i) < spblcrit*10.0) THEN - KB(I) = K + KBOFS - ENDIF - ENDDO - ENDDO - DO K=KLCLB+1,KBMAX-1 - DO I=ISTS,IENS - spbl(i) = one - gdpm(i,k) * tx1(i) - IF (kb(i) > k .and. spbl(i) > spblmax) THEN - KB(I) = K - ENDIF - ENDDO - ENDDO -! DO K=KBMAX-1,KLCLB+1,-1 -! DO I=ISTS,IENS -! GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp -! QSL(i) = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) -! spbl(i) = one - gdpm(i,k) * tx1(i) -! IF (GDW(I,KLCLB) >= QSL(i) .and. spbl(i) >= spblcrit & -! .and. spbl(i) < spblcrit*6.0) THEN -! .and. spbl(i) < spblcrit*8.0) THEN -! KB(I) = K + KBOFS -! ENDIF -! ENDDO -! if(lprnt) write(0,*)' k=',k,' gdh1=',gdh(ipr,klclb),' gdhs=',gdhs(ipr,k),' kb=',kb(ipr) & -! ,' GDQS=',GDQS(ipr,k),' GDW=',GDW(ipr,KLCLB),' gdpm=',gdpm(ipr,k),' spbl=',spbl(ipr),' qsl=',qsl(ipr) -! ENDDO - ENDIF -! - do i=ists,iens - tx1(i) = zero - qsl(i) = zero - enddo - do k=1,kbmax - do i=ists,iens - if (k < kb(i)) then - tx1(i) = tx1(i) + gdw(i,k) * (GDZM(i,k+1)-GDZM(i,k)) - qsl(i) = qsl(i) + gdqs(i,k) * (GDZM(i,k+1)-GDZM(i,k)) - endif - enddo - enddo - do i=ists,iens - if (qsl(i) > zero) tx1(i) = tx1(i) / qsl(i) - if (tx1(i) < crtrh) kb(i) = -1 - enddo - -! - KBMX = 1 - DO I=ISTS,IENS - KBMX = MAX(KBMX, KB(I)) - if (kb(i) > 0) then - CBASE (I) = one / (GDZM(I,KB(I)) - GDZM(I,1)) -! CBASEP(I) = GDPM(I,KB(I)) - endif - ENDDO -! - DO K=2,KBMX - DO I=ISTS,IENS - IF (K <= KB(I)) THEN -! GCYM(I,K) = sqrt((GDZM(I,K)-GDZM(I,1))*CBASE(i)) - GCYM(I,K) = (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 n = ntrq,ntr - DO I=ISTS,IENS - GCtrB(I,n) = zero - enddo - 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 n=ntrq,ntr -! do k=1,kmax -! do i=ists,iens -! gtrqbl(i,k,n) = zero -! enddo -! 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,1) -! do n = ntrq,ntr -! GCtrB(I,n) = GCtrB(I,n) + DELZ * GDQ (I,K,n) -! enddo -! 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 - gctbl(i,kp1) = (gchb(i)*wrk - grav*gdzm(i,kp1) - el*gcqbl(i,kp1)) * oneocp -! tracers - do n=ntrq,ntr - GCtrB(I,n) = GCtrB(I,n) + DELZ * GDQ (I,K,n) - GCtrBl(I,kp1,n) = gctrb(i,n) * wrk - enddo - ENDIF - ENDDO - ENDDO -! - END SUBROUTINE CUMBAS -!*********************************************************************** - SUBROUTINE CUMUP & !! in-cloud properties - ( IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - ACWF , & ! output - GCLZ , GCIZ , GPRCIZ, GSNWIZ, & ! output - GCYT , GCHT , GCQT , & ! output - GCLT , GCIT , GTPRT , & ! output - GCUT , GCVT , gctrt , & ! output - KT , KTMX , & ! output - GCYM , & ! modified - wcv , & ! !DDsigma new output - GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag - GCIB , gctrb , & ! 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 , gctrm , lprnt, ipr ) -! -!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, ipr , ntrq ! DD, for GFS, pass in - logical :: lprnt -! -! [OUTPUT] - REAL(r8) ACWF (IJSDIM) ! cloud work function - 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) GCtrT (IJSDIM, ntrq:ntr) ! cloud top tracer*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) ! cloud base Moist Static Energy - 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) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracers - 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) ! cloud base updraft velocity**2 -! REAL(r8) ERMR ! entrainment rate (ASMODE) - INTEGER KB (IJSDIM) - INTEGER CTP, ISTS, IENS -! -! [INTERNAL WORK] - REAL(r8) ACWFK (IJSDIM,KMAX) ! cloud work function - REAL(r8) ACWFN (IJSDIM,KMAX) ! negative part of cloud work function - 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) GCUMZ (IJSDIM, KMAX) ! cloud U *eta (half lev) - REAL(r8) GCVMZ (IJSDIM, KMAX) ! cloud V *eta (half lev) - REAL(r8) GCqMZ (IJSDIM ) ! cloud qv*eta (half lev) - REAL(r8) GCIMZ (IJSDIM, KMAX) ! cloud Qi*eta (half lev) - REAL(r8) GCtrMZ(IJSDIM, KMAX,ntrq:ntr)! cloud tracer*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 ) ! updraft velocity**2 (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) ELAR ! entrainment rate at mid layer -! - 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) 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) GCtrM (IJSDIM, KMAX,ntrq:ntr) ! cloud tracer (half lev) -! - REAL(r8), dimension(IJSDIM) :: WCM_, ELARM1, GDZMKB - REAL(r8) GDQSM, GDHSM, GDQM, GDSM, GDCM, FDQSM, GCCM, & - DELZ, ELADZ, DCTM , CPGMI, DELC, FICE, ELARM2,GCCMZ, & - PRECR, GTPRIZ, DELZL, GCCT, DCT, WCVX, PRCZH, wrk - INTEGER K, I, kk, km1, kp1, n - -! 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), parameter :: ZTREF = 1._r8, ztrefi = one/ztref, & - ELAMIN = zero, ELAMAX = 4.e-3 ! min and max entrainment rate - REAL(r8) :: PB = 1.0_r8 -!m REAL(r8) :: TAUZ = 5.0e3_r8 - REAL(r8) :: TAUZ = 1.0e4_r8 -!m REAL(r8) :: ELMD = 2.4e-3 ! for Neggers and Siebesma (2002) -!m REAL(r8) :: ELAMAX = 5.e-3 ! max. of entrainment rate -! REAL(r8) :: WCCRT = zero -!m REAL(r8) :: WCCRT = 0.01 - REAL(r8) :: WCCRT = 1.0e-6_r8, wvcrt=1.0e-3_r8 - REAL(r8) :: TSICE = 268.15_r8 ! compatible with macrop_driver - REAL(r8) :: TWICE = 238.15_r8 ! compatible with macrop_driver - -! REAL(r8) :: wfn_neg = 0.1 - REAL(r8) :: wfn_neg = 0.15 -! REAL(r8) :: wfn_neg = 0.25 -! REAL(r8) :: wfn_neg = 0.30 -! REAL(r8) :: wfn_neg = 0.35 - - REAL(r8) :: esat, tem -! REAL(r8) :: esat, tem, rhs_h, rhs_q -! - REAL(r8) Z ! altitude - REAL(r8) ZH ! scale height - REAL(r8) T ! temperature -! -! -! Note: iteration is not made to diagnose cloud ice for simplicity -! - 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 - ACWFK (I,k) = unset_r8 - ACWFN (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 - GCIMZ (I,k) = zero - GCUMZ (I,k) = zero - GCVMZ (I,k) = zero - GTPRMZ(I,k) = zero -! - BUOY (I,k) = unset_r8 - BUOYM (I,k) = unset_r8 - WCV (I,k) = unset_r8 - GCY (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 - do i=ists,iens - GCqMZ(I) = zero - WCM(I) = unset_r8 - WCM_(I) = zero - enddo -! tracers - do n=ntrq,ntr - do i=ists,iens - GCtrT(I,n) = zero - enddo - do k=1,kmax - do i=ists,iens - GCTRM(I,k,n) = unset_r8 - enddo - enddo - enddo - -! DO I=ISTS,IENS -! if (kb(i) > 0) then -! GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height -! endif -! ENDDO -! -! < cloud base properties > -! - DO I=ISTS,IENS - K = KB(I) - if (k > 0) then - GDZMKB(I) = GDZM(I,K) ! cloud base height - GCHM(I,K) = GCHB(I) - GCWM(I,K) = GCWB(I) - WCM_(I) = WCB(i) - GCUM(I,K) = GCUB(I) - GCVM(I,K) = GCVB(I) - do n = ntrq,ntr - GCtrM(I,K,n) = GCtrB(I,n) - enddo -! - esat = min(gdpm(i,k), fpvs(gdtm(i,k))) - GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 0.1) - 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) ! calculate d(qs)/dT -! - 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 - GCTM(I,K) = (GCHB(I) - grav*gdzm(i,k) - 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*tem + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV -! - ACWFK(I,K) = zero - ACWFN(I,K) = zero -! -!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) -! ELARM1(I) = min(max(CLMD*PA*BUOYM(I,K)/WCM_(I), ELAMIN), ELAMAX) -!DD#endif -! ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) -! - GCHMZ(I,K) = GCHM(I,K) - GCWMZ(I,K) = GCWM(I,K) - GCUMZ(I,K) = GCUM(I,K) - GCVMZ(I,K) = GCVM(I,K) - GCqMZ(I) = GCqM(I,K) - GCIMZ(I,K) = GCIM(I,K) - do n = ntrq,ntr - GCtrMZ(I,K,n) = GCtrM(I,K,n) - enddo - endif - ENDDO -! -! < in-cloud properties > -! - DO K=3,KMAX - km1 = k - 1 - DO I=ISTS,IENS - IF (kb(i) > 0 .and. K > KB(I) .AND. WCM_(I) > WCCRT) THEN - WCV(I,KM1) = SQRT(MAX(WCM_(I), zero)) - DELZ = GDZM(I,K) - GDZM(I,KM1) - ELARM1(I) = min(max(CLMDPA*BUOYM(I,KM1)/WCM_(I), ELAMIN), ELAMAX) - 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), 0.1) - 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) ! calculate d(qs)/dT - CPGMI = one / (CP + EL*FDQSM) - - PRCZH = PRECZH * MIN(GDZTR(I)*ZTREFI, one) - PRECR = FPREC(GDZM(I,K)-GDZMKB(I), PRCZH ) -! - wrk = one / GCYM(I,K) - DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI - GCQMZ(i) = min((GDQSM+FDQSM*DCTM)*GCYM(I,K), GCWMZ(I,K)) - GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i)) - GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) - GCCMZ = GCWMZ(I,K) - GCQMZ(i) - GTPRMZ(I,K ) - DELC = MIN(GCCMZ, zero) - GCCMZ = GCCMZ - DELC - GCQMZ(i) = GCQMZ(i) + 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) = wrk * GCQMZ(i) - GCCM = wrk * GCCMZ -! - BUOYM(I,K) = (DCTM*tem + 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) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) / (one + DELZ/TAUZ) - ELSE - WCM(I) = (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), EPSln) -!DD#endif - if (WCM(I) > zero) then - ELARM2 = min(max(CLMDPA*BUOYM(I,K)/WCM(I),ELAMIN), ELAMAX) - else - ELARM2 = zero - endif - ELAR = half * (ELARM1(I) + ELARM2) - GCYM(I,K) = GCYM(I,KM1) * EXP(ELAR*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 - GCUMZ(I,K) = GCUMZ(I,KM1) + GDU(I,KM1)*ELADZ - GCVMZ(I,K) = GCVMZ(I,KM1) + GDV(I,KM1)*ELADZ - do n = ntrq,ntr - GCtrMZ(I,K,n) = GCtrMZ(I,KM1,n) + GDq(I,KM1,n)*ELADZ - enddo -! - wrk = one / GCYM(I,K) - DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI - GCQMZ(i) = min((GDQSM+FDQSM*DCTM)*GCYM(I,K), GCWMZ(I,K)) - GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i)) - GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) - GCCMZ = GCWMZ(I,K) - GCQMZ(i) - GTPRMZ(I,K) - DELC = MIN(GCCMZ, zero) - GCCMZ = GCCMZ - DELC - GCQMZ(i) = GCQMZ(i) + DELC - GCCM = wrk * GCCMZ - GCQM(I,K) = wrk * GCQMZ(i) -! - 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 - do n = ntrq,ntr - GCtrM(I,K,n) = GCtrMZ(I,K,n) * wrk - enddo - DELZL = GDZ(I,KM1)-GDZM(I,KM1) - GCY (I,KM1) = GCYM(I,KM1) * EXP(ELAR*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) - -! - BUOYM(I,K) = (DCTM*tem + EPSVT*(GCQM(I,K)-GDQM)-GCCM+GDCM) * GRAV - BUOY(I,KM1) = half * (BUOYM(I,K)+BUOYM(I,KM1)) -! - IF (BUOY(I,KM1) > zero) THEN - WCM(I) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) / (one + DELZ/TAUZ) - ELSE - WCM(I) = (WCM_(I) + PA*(DELZ+DELZ)*BUOY(I,KM1) ) & - / (one + DELZ/TAUZ + (DELZ+DELZ)*ELAMIN ) - ENDIF - -! -! IF (BUOY(I,KM1) > zero) THEN -! ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ -! ENDIF -! ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ -!!! wrk = BUOY(I,KM1)*GCY(I,KM1)*DELZ -!!! ACWFK(I,K) = ACWFK(I,KM1) + wrk -!!! ACWFN(I,K) = ACWFN(I,KM1) - min(wrk,0.0) -! ACWFN(I,K) = ACWFN(I,KM1) + abs(min(wrk,0.0)) -! - - wrk = BUOY(I,KM1)*GCY(I,KM1)*DELZ - ACWFK(I,K) = ACWFK(I,KM1) + wrk - ACWFN(I,K) = ACWFN(I,KM1) - min(wrk,0.0) - - WCM_(I) = WCM(I) - -! if (lprnt .and. i == ipr) write(0,*) ' in cumup k=',k,' km1=',km1,' WCM_=',WCM_(I),' gcy=',gcy(i,km1),' buoym=',buoym(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 (kb(i) > 0 .and. k > kb(i) .and. ACWFK(I,K) > 1.0e-10) then - wrk = ACWFN(I,K) / ACWFK(I,K) - IF (KT(I) == -1 .and. wrk < wfn_neg .AND. WCV(I,K) > WVCRT) THEN - KT(I) = K - ACWF(I) = ACWFK(I,K) - ENDIF - endif - ENDDO - ENDDO -! if (lprnt .and. kt(ipr) > 0) write(0,*) ' in cumup kt=',kt(ipr),' gcy=',gcy(ipr,kt(ipr)) -! - KTMX = 2 - DO I=ISTS,IENS - kt(i) = min(kt(i), kmax-1) - KTMX = max(ktmx, KT(I)) - ENDDO -! - DO I=ISTS,IENS - kk = max(1, kt(i)+1) - do k=kk,kmax - GCYM (I,K) = zero - GCLZ (I,K) = zero - GCIZ (I,K) = zero - GPRCIZ(I,K) = zero - GSNWIZ(I,K) = zero - enddo - ENDDO -! if (lprnt .and. kt(ipr) > 0) write(0,*) ' in cumup2 kt=',kt(ipr),' gcy=',gcy(ipr,kt(ipr)) -! -! < cloud top properties > -! - DO I=ISTS,IENS - IF (kb(i) > 0 .and. KT(I) > kb(i)) THEN - K = KT(I) - kp1 = k + 1 - GCYT(I) = GCY(I,K) - ELADZ = GCYT(I) - GCYM(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 - do n = ntrq,NTR - GCtrT(I,n) = GCtrMZ(I,K,n) + GDq(I,K,n)*ELADZ - enddo -! - wrk = one / gcyt(i) - DCT = (GCHT(I)*wrk - GDHS(I,K)) / (CP*(one + GAM(I,K))) - GCQT(I) = min((GDQS(I,K) + FDQS(I,K)*DCT) * GCYT(I), GCWT(i)) - PRCZH = PRECZH * MIN(GDZTR(I)*ZTREFI, 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 - do n = ntrq,NTR -! GCtrT(I,n) = GCtrT(I,n)*(one-CPRES) + GCY(I,K)*GDq(I,K,n)*CPRES - GCtrT(I,n) = GCtrT(I,n) + GCY(I,K)*GDq(I,K,n) - enddo - 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)) - - 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 - do n = ntrq,NTR - gctrm(i,kp1,n) = gctrt(i,n)*wrk - enddo -! - 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 -! - -contains - - pure function FPREC(Z,ZH) - implicit none - real(r8), intent(in) :: Z - real(r8), intent(in) :: ZH - real(r8) :: FPREC - FPREC = MIN(MAX(one-EXP(-(Z-PRECZ0)/ZH), zero), one) - end function FPREC - - pure function FRICE(T) - implicit none - real(r8), intent(in) :: T - real(r8) :: FRICE - FRICE = MIN(MAX((TSICE-T)/(TSICE-TWICE), zero), one) - end function FRICE - - 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 cloud mean RH -! REAL(r8) :: RHMCRT = 0.25_r8 ! critical val. of cloud mean RH - REAL(r8) :: RHMCRT = 0.50_r8 ! critical val. of cloud mean RH - REAL(r8) :: ALP1 = zero - REAL(r8) :: TAUD = 1.e3_r8 -! REAL(r8) :: TAUD = 6.e2_r8 - REAL(r8) :: ZFMAX = 3.5e3_r8 - REAL(r8) :: ZDFMAX = 5.e2_r8 -! REAL(r8) :: FMAXP = 2._r8 -! - do i=ists,iens - qx(i) = zero - qsx(i) = zero - enddo -! - DO K=1,KTMX - DO I=ISTS,IENS - IF (kb(i) > 0 .and. 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 - k = kb(i) - IF (k > 0 .and. KT(I) > K .AND. RHM(I) >= RHMCRT) THEN - cbmfx(i) = max(cbmfx(i), zero) - ALP = ALP0 + ALP1 * (GDZM(I,KT(I))-GDZM(I,K)) - 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) + ACWF(I)*(delt/(ALP+ALP))) * 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 , CMDET, & ! output - QLIQ , QICE , GTPRC0, & ! output - CBMFX , GCYM , GPRCIZ, GSNWIZ, & ! input - GTPRT , GCLZ , GCIZ , GCYT, & ! input - KB , KT , KTMX , & ! input - ISTS , IENS ) ! input -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IJSDIM, KMAX, IM !! DD, for GFS, pass in -! -! [OUTPUT] - REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux - REAL(r8) CMDET (IJSDIM, KMAX) !! detrainment 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) GCYT (IJSDIM) !! detraining mass flux - 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 - INTEGER KB (IJSDIM) !! cloud base - INTEGER KT (IJSDIM) !! cloud top - INTEGER KTMX !! max of cloud top - INTEGER ISTS, IENS, I, K -! - DO K=1,KTMX - DO I=ISTS,IENS - if (kb(i) > 0) then - GMFLX(I,K) = GMFLX(I,K) + CBMFX(I) * GCYM(I,K) - GPRCI(I,K) = GPRCI(I,K) + CBMFX(I) * GPRCIZ(I,K) - GSNWI(I,K) = GSNWI(I,K) + CBMFX(I) * GSNWIZ(I,K) - QLIQ(I,K) = QLIQ (I,K) + CBMFX(I) * GCLZ(I,K) - QICE(I,K) = QICE (I,K) + CBMFX(I) * GCIZ(I,K) - endif - ENDDO - ENDDO -! - DO I= ISTS,IENS - k = kt(i) - if (kb(i) > 0 .and. k > kb(i)) then - GTPRC0(I) = GTPRC0(I) + CBMFX(I) * GTPRT(I) - CMDET(I,K) = CMDET(I,K) + CBMFX(I) * GCYT(I) - endif - ENDDO -! - END SUBROUTINE CUMFLX -!*********************************************************************** - SUBROUTINE CUMDET & !! detrainment - ( im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - GTT , GTQ , GTU , GTV , & ! modified - GDH , GDQ , GDU , GDV , & ! input -! GTT , GTQ , GTCFRC, GTU , GTV , & ! modified -! GDH , GDQ , GDCFRC, GDU , GDV , & ! input - CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input - GCLT , GCIT , GCUT , GCVT , GDQI , & ! input - gctrt, & - KT , ISTS , IENS , nctp ) ! input -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp, ntrq !! DD, for GFS, pass in -! -! [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 -! -! [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) DELPI (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) GCtrT (IJSDIM, ntrq:ntr, NCTP)!! detraining tracer - REAL(r8) GCUT (IJSDIM, NCTP) !! detraining u - REAL(r8) GCVT (IJSDIM, NCTP) !! detraining v - REAL(r8) GDQI (IJSDIM, KMAX) !! cloud ice - INTEGER KT (IJSDIM, NCTP) !! cloud top - INTEGER ISTS, IENS -! -! [INTERNAL WORK] - REAL(r8) GTHCI, GTQVCI, GTXCI - integer I, K, CTP, kk,n -! - - DO CTP=1,NCTP - DO I=ISTS,IENS - K = KT(I,CTP) - IF (K > 0) THEN - GTXCI = DELPI(I,K)*CBMFX(I,CTP) - - GTHCI = GTXCI * (GCHT(I,CTP) - GCYT(I,CTP)*GDH(I,K)) - GTQVCI = GTXCI * (GCQT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,1)) -! - 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) + GTXCI * (GCLT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,ITL)) -! qi tendency by detrainment is treated by stratiform scheme - GTQ(I,K,ITI) = GTQ(I,K,ITI) + GTXCI * (GCIT(I,CTP) - GCYT(I,CTP)*GDQI(I,K)) - do n = ntrq,NTR - GTQ(I,K,n) = GTQ(I,K,n) + GTXCI * (GCtrT(I,n,CTP) - GCYT(I,CTP)*GDQ(I,K,n)) - enddo - -! 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)) - ENDIF - ENDDO - ENDDO -! - END SUBROUTINE CUMDET -!*********************************************************************** - SUBROUTINE CUMSBH & !! adiabat. descent - ( IM , IJSDIM, KMAX , NTR, ntrq, & !DD dimensions - GTT , GTQ , & ! modified - GTU , GTV , & ! modified - GDH , GDQ , GDQI , & ! input - GDU , GDV , & ! input - DELPI , GMFLX , GMFX0 , & ! input - KTMX , CPRES , KB, ISTS , IENS ) ! input -! -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX, NTR, ntrq !! DD, for GFS, pass in -! -! [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 -! -! [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) DELPI (IJSDIM, KMAX) - REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux (updraft+downdraft) - REAL(r8) GMFX0 (IJSDIM, KMAX) !! mass flux (updraft only) - INTEGER KB(IJSDIM) !! cloud base index - negative means no convection - INTEGER KTMX - REAL(r8) CPRES !! pressure factor for cumulus friction - INTEGER ISTS, IENS -! -! [INTERNAL WORK] - 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 - REAL(r8) FX(ISTS:IENS) - - REAL(r8), dimension(IJSDIM, KMAX) :: GTLSBH, GTISBH - integer :: I, K, KM, KP, n -! -! - 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 - if (kb(i) > 0) then - 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 -! - IF (GMFLX(I,K) > GMFLX(I,KP)) THEN - FX1 = half - ELSE - FX1 = zero - ENDIF -! - wrk = DELPI(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) -! - 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 - GTU (I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) - GTV (I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) - DO n = ntrq, ntr - GTQ (I,K,n) = GTQ(I,K,n) + wrk & - * ( wrk1 * (GMFLX(I,KP) * (GDQ(I,KP,n)-GDQ(I,K ,n))) & - + FX1 * (GMFLX(I,K ) * (GDQ(I,K ,n)-GDQ(I,KM,n))) ) - ENDDO - - 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 = DELPI(I,K) * (( one-FX(I))*SBC0 + FX1 *SBC1) -! GTM3CI = DELPI(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 - endif - enddo - enddo -! - END SUBROUTINE CUMSBH -!*********************************************************************** -! -!*********************************************************************** - SUBROUTINE CUMSBW & !! adiabat. descent - ( IM , IJSDIM, KMAX , & !DD dimensions - GTU , GTV , & ! modified - GDU , GDV , & ! input - DELPI , GMFLX , GMFX0 , & ! input - KTMX , CPRES , KB, ISTS , IENS ) ! input -! -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX!! DD, for GFS, pass in -! -! [MODIFY] - REAL(r8) GTU (IJSDIM, KMAX) !! u tendency - REAL(r8) GTV (IJSDIM, KMAX) !! v tendency -! -! [INPUT] - REAL(r8) GDU (IJSDIM, KMAX) - REAL(r8) GDV (IJSDIM, KMAX) - REAL(r8) DELPI (IJSDIM, KMAX) - REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux (updraft+downdraft) - REAL(r8) GMFX0 (IJSDIM, KMAX) !! mass flux (updraft only) - INTEGER KB(IJSDIM) !! cloud base index - negative means no convection - INTEGER KTMX, ISTS, IENS - REAL(r8) CPRES !! pressure factor for cumulus friction -! -! [INTERNAL WORK] - REAL(r8) FX1, SBU0, SBV0, SBU1, SBV1, wrk, wrk1 - REAL(r8) FX(ISTS:IENS) - - integer :: I, K, KM, KP -! -! - FX = zero -! - DO K=KTMX,1,-1 - KM = MAX(K-1, 1) - KP = MIN(K+1, KMAX) - DO I=ISTS,IENS - if (kb(i) > 0) then - 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 -! - 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 -! - IF (GMFLX(I,K) > GMFLX(I,KP)) THEN - FX1 = half - ELSE - FX1 = zero - ENDIF -! - wrk = DELPI(I,K) - wrk1 = one - FX(I) -! - GTU(I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) - GTV(I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) -! - FX(I) = FX1 - endif - enddo - enddo -! - END SUBROUTINE CUMSBW -!*********************************************************************** - SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation - ( IM , IJSDIM, KMAX , NTR , ntrq, & !DD dimensions - GTT , GTQ , GTU , GTV , & ! modified - 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 , FDQS , DELP , & ! input - DELPI , & - sigmad, do_aw , do_awdd, flx_form, & !DDsigma input - gtmelt, gtevap, gtsubl, & !DDsigma input - dtdwn , dqvdwn, dqldwn, dqidwn, & !DDsigma input - dtrdwn, & - 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, ntrq ! DD, for GFS, pass in - logical, intent(in) :: do_aw, do_awdd, flx_form -! -! [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) 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 - REAL(r8) dtrdwn (IJSDIM, KMAX, ntrq:ntr) ! tracer tendency downdraft detrainment -! AW downdraft area fraction (assumed zero for now) - REAL(r8) sigmad (IJSDIM,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) FDQS (IJSDIM, KMAX) - REAL(r8) DELP (IJSDIM, KMAX) - REAL(r8) DELPI (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) GCtrD (ISTS:IENS, ntrq:ntr) ! downdraft tracer - - 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, & - wrk, wrk1, wrk2, wrk3, wrk4, tx1, & - WMX, HMX, DDWMX, DDHMX, dp_above, dp_below, fsigma, & - fmelt, fevp, wrkn, gctrdd(ntrq:ntr) - -!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 - integer ij, i, k, kp1, n -!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 :: MELTAU = 20._r8 ! melting timescale ! Moorthi june 30, 2017 -! -! REAL(r8), parameter :: EVAPR = 0.4_r8 ! evaporation factor ! Moorthi June 28, 2017 - 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 :: VTERM = 4._r8 ! term. vel. of precip. ! Moorthi June 28, 2017 - 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 (flx_form) then - if (.not. do_awdd) then - do k=1,kmax - do i=ists,iens - if (kb(i) > 0) then - 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) - endif - enddo - enddo - do n=ntrq,ntr - do k=1,kmax - do i=ists,iens - if (kb(i) > 0) then - dtrdwn(i,k,n) = gtq(i,k,n) - endif - enddo - 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 - do n=ntrq,ntr - do k=1,kmax - do i=ists,iens - dtrdwn(i,k,n) = zero - enddo - enddo - enddo - endif - endif -! - do i=ists,iens - GCHD(I) = zero - GCWD(I) = zero - GCUD(I) = zero - GCVD(I) = zero - enddo - do n=ntrq,ntr - do i=ists,iens - GCtrD (I,n) = zero - enddo - enddo -! - DO K=KTMX,1,-1 ! loop A - kp1 = min(k+1,kmax) -! -! < precipitation melt & freeze > -! - DO I=ISTS,IENS - if (kb(i) > 0) then - 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) * DELPI(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) * DELPI(I,K) - ENDIF -!DD heating rate due to precip melting for AW - gtmelt(i,k) = gtmelt(i,k) + GTTEV(I,K) - endif - ENDDO -! -! < downdraft > -! - DO I=ISTS,IENS ! loop B - if (kb(i) > 0) then - wrk = delpi(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) - do n = ntrq,ntr - GCtrD(I,n) = GCtrD(I,n) + GDq(I,K,n)*GMDDE(I,K) - enddo - 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) - do n = ntrq,ntr - GCtrDD(n) = FDET*GCtrD(I,n) - enddo -! - GTHCI = wrk * (GCHDD(I,K) - GMDDD(I)*GDH(I,K)) - GTQVCI = wrk * (GCWDD(I,K) - GMDDD(I)*GDQ(I,K,1)) -! - 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) - wrk * GMDDD(I)*GDQ(I,K,ITL) - GTQ (I,K,ITI) = GTQ(I,K,ITI) - wrk * GMDDD(I)*GDQI(I,K) - - do n = ntrq,ntr - GTQ (I,K,n) = GTQ(I,K,n) + wrk * (GCtrDD(n) - GMDDD(I)*GDQ(I,K,n)) - GCtrD(I,n) = GCtrD(I,n) - GCtrDD(n) - enddo - - 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) - endif - ENDDO ! loop B -! - ENDDO ! loop A -! - DO K=1,KTMX - kp1 = min(k+1,kmax) - DO I=ISTS,IENS - if (kb(i) > 0) then - wrk = DELPI(I,k) - tx1 = DELPI(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 (k > 1 .and. flx_form) then - fsigma = one - sigmad(i,kp1) - dp_below = wrk * (one - sigmad(i,k)) - dp_above = tx1 * (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)) - do n = ntrq,ntr - wrkn = gmdd(i,kp1) * gdq(i,k,n) - dtrdwn(i,k,n) = dtrdwn(i,k,n) + dp_below * wrkn - dtrdwn(i,kp1,n) = dtrdwn(i,kp1,n) - dp_above * wrkn - enddo - endif - - endif - ENDDO ! end of i loop - ENDDO ! end of k loop -! - if (.not. do_awdd .and. flx_form) then - do k=1,kmax - do i=ists,iens - if (kb(i) > 0) then - 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) - endif - enddo - enddo - do n=ntrq,ntr - do k=1,kmax - do i=ists,iens - if (kb(i) > 0) then - dtrdwn(i,k,n) = gtq(i,k,n) - dtrdwn(i,k,n) - endif - enddo - 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 -! -! [INTERNAL PARAM] - REAL(r8), parameter :: CMFMIN = 2.e-3_r8, &! Mc->cloudiness - CMFMAX = 3.e-1_r8, &! Mc->cloudiness - CLMIN = 1.e-3_r8, &! cloudiness Min. - CLMAX = 0.1_r8, &! cloudiness Max. - FACLW = 0.1_r8, &! Mc->CLW - FACLF = (CLMAX-CLMIN)/LOG(CMFMAX/CMFMIN) -! - 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 , & ! input - GCYM , GCYT , GCQT , GCLT , GCIT , & ! input - GTPRT , GTEVP , GTPRC0, & ! input - KB , KBMX , KT , KTMX , KTMXT , & ! input - DELPI , 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) GCYM (IJSDIM, KMAX, nctp) - 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) DELPI (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,nctp) :: DZT, RGCWT, MASK1, MASK2 - REAL(r8), dimension(ists:iens,nctp) :: RGCWT, MASK1 -! - do i=ists,iens - if (gtprc0(i) > zero) then - gtprc0i(i) = one / gtprc0(i) - else - gtprc0i(i) = zero - endif - 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 - IF (kb(i) > 0 .and. K > KB(I)) THEN - MASK1(I,CTP) = one - 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 - DO CTP=1,NCTP - DO I=ISTS,IENS - GCRB(i) = zero - DR(i) = zero - enddo - DO K=1,KBMX - DO I=ISTS,IENS - IF (kb(i) > 0 .and. K < KB(I)) THEN - GCRB(I) = GCRB(I) + (GCYM(I,K+1,ctp)-GCYM(I,K,ctp))* GDR(I,K,LT) - ENDIF - ENDDO - ENDDO -! - DO K=2,KTMX(CTP) - DO I=ISTS,IENS - IF (kb(i) > 0 .and. K >= KB(I) .AND. K < KT(I,CTP)) THEN - DR(I) = DR(I) + (GCYM(I,K+1,ctp)-GCYM(I,K,ctp)) * GDR(I,K,LT) - ENDIF - ENDDO - ENDDO -! - DO I=ISTS,IENS - K = KT(I,CTP) - if (kb(i) > 0 .and. k > kb(i)) then - DR(I) = DR(I) + (GCYT(I,CTP) - GCYM(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) + DELPI(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) + DELPI(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) - endif - 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) + DELPI(I,K) * GPRCC(I,LT) * EVPF - GPRCC(I,LT) = GPRCC(I,LT) * (one - EVPF) -! GTR(I,K,LT) = GTR(I,K,LT) + DELPI(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 , DELPI , & ! 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) DELPI (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) + DELPI(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 , DELPI , & ! 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) DELPI (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) + DELPI(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 - !DD add new CASE - ! 3: just fill holes, no attempt to conserve - 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 (3) - CASE DEFAULT - EXIT - END SELECT -! - DO I=ISTS,IENS - TOT0(I) = zero - TOT1(I) = zero - TRAT(I) = one - 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 -! - if(imfxr(LT) .ne. 3) then - DO I=ISTS,IENS - IF (TOT1(I) > zero ) THEN - TRAT(I) = MAX(TOT0(I), zero) / TOT1(I) - ENDIF - ENDDO - endif -! - 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 - -!*********************************************************************** - -end module cs_conv diff --git a/gfsphysics/physics/date_def.f b/gfsphysics/physics/date_def.f deleted file mode 100644 index 2907d7416..000000000 --- a/gfsphysics/physics/date_def.f +++ /dev/null @@ -1,13 +0,0 @@ - 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/gfsphysics/physics/dcyc2.f b/gfsphysics/physics/dcyc2.f deleted file mode 100644 index 196148d2b..000000000 --- a/gfsphysics/physics/dcyc2.f +++ /dev/null @@ -1,313 +0,0 @@ -! ===================================================================== ! -! 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,tsfc3,tf,tsflw,sfcemis, ! -! sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, ! -! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, ! -! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, ! -! ix, im, levs, deltim, fhswr, ! -! dry, icy, wet ! -! 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 ! -! Mar 2019 s. moorthi - modify xmu calculation in a time centered ! -! way and add more accuracy when physics ! -! time step is close to radiation time step ! -! ! -! 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 ! -! tsfc3 (im,3)- real, bottom surface (1 - land, 2 - ice, 3 - water ! -! temperature (k) ! -! tf (im) - real, surface air (layer 1) temperature (k) ! -! sfcemis(im,3)- 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 ! -! deltim - real, physics time step in seconds ! -! fhswr - real, Short wave radiation time step in seconds ! -! dry - logical, true over land ! -! icy - logical, true over ice ! -! wet - logical, true over water ! -! ! -! 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,tsfc3,tf,tsflw,sfcemis, & - & sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, & - & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & - & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & - & ix, im, levs, deltim, fhswr, & - & dry, icy, wet, & -! & dry, icy, wet, lprnt, ipr, & -! --- 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_kind_phys, & - & zero = 0.0d0, one = 1.0d0, & - & hour12 = 12.0_kind_phys, & - & f3600 = one/3600.0_kind_phys, & - & f7200 = one/7200.0_kind_phys, & - & czlimt = 0.0001_kind_phys, & ! ~ cos(89.99427) - & pid12 = con_pi / hour12 - -! --- inputs: - integer, intent(in) :: ix, im, levs - -! integer, intent(in) :: ipr -! logical lprnt - logical, dimension(im), intent(in) :: dry, icy, wet - real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr - - real(kind=kind_phys), dimension(im), intent(in) :: & - & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & - & sfcdsw, sfcnsw - - real(kind=kind_phys), dimension(im,3), intent(in) :: & - & tsfc3, 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 - -! --- 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, xmu, xcosz, & - & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd - - real(kind=kind_phys), dimension(im,3), intent(out) :: adjsfculw - -! --- locals: - integer :: i, k, nstp, nstl, it, istsun(im) - real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & - & rstl, solang -! -!===> ... begin here -! - tem1 = fhswr / deltim - nstp = max(6, nint(tem1)) - nstl = max(1, nint(nstp/tem1)) -! -! --- ... sw time-step adjustment for current cosine of zenith angle -! ---------------------------------------------------------- - if (nstl == 1) then - cns = pid12 * (solhr + deltim*f7200 - hour12) + slag - do i = 1, IM - xcosz(i) = sdec*sinlat(i) + cdec*coslat(i)*cos(cns+xlon(i)) - enddo - elseif (nstl == nstp) then - do i = 1, IM - xcosz(i) = coszen(i) - enddo - else - rstl = one / float(nstl) - solang = pid12 * (solhr - hour12) - anginc = pid12 * deltim * f3600 * rstl - do i = 1, im - xcosz(i) = zero - istsun(i) = zero - enddo - do it=1,nstl - cns = solang + (float(it)-0.5)*anginc + slag - do i = 1, IM - coszn = sdec*sinlat(i) + cdec*coslat(i)*cos(cns+xlon(i)) - xcosz(i) = xcosz(i) + max(0.0, coszn) - if (coszn > czlimt) istsun(i) = istsun(i) + 1 - enddo - enddo - do i = 1, IM - if (istsun(i) > 0) xcosz(i) = xcosz(i) / istsun(i) ! mean cosine of solar zenith angle at current time - enddo - endif -! - 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 - - if (dry(i)) then - tem2 = tsfc3(i,1) * tsfc3(i,1) - adjsfculw(i,1) = sfcemis(i,1) * con_sbc * tem2 * tem2 - & + (one - sfcemis(i,1)) * adjsfcdlw(i) - endif - if (icy(i)) then - tem2 = tsfc3(i,2) * tsfc3(i,2) - adjsfculw(i,2) = sfcemis(i,2) * con_sbc * tem2 * tem2 - & + (one - sfcemis(i,2)) * adjsfcdlw(i) - endif - if (wet(i)) then - tem2 = tsfc3(i,3) * tsfc3(i,3) - adjsfculw(i,3) = sfcemis(i,3) * con_sbc * tem2 * tem2 - & + (one - sfcemis(i,3)) * adjsfcdlw(i) - endif -! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: dry==',dry(i) -! &,' wet=',wet(i),' icy=',icy(i),' tsfc3=',tsfc3(i,:) -! &,' sfcemis=',sfcemis(i,:),' adjsfculw=',adjsfculw(i,:) -! -! --- ... 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 -! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: sfcnsw=',sfcnsw(i) -! &,' sfcdsw=',sfcdsw(i),' xmu=',xmu(i) - -! --- ... 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/gfsphysics/physics/dcyc2.pre.rad.f b/gfsphysics/physics/dcyc2.pre.rad.f deleted file mode 100644 index c303a2868..000000000 --- a/gfsphysics/physics/dcyc2.pre.rad.f +++ /dev/null @@ -1,206 +0,0 @@ -! ===================================================================== ! -! 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/gfsphysics/physics/efield.f b/gfsphysics/physics/efield.f deleted file mode 100644 index 64fb1bc69..000000000 --- a/gfsphysics/physics/efield.f +++ /dev/null @@ -1,3241 +0,0 @@ - - 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/gfsphysics/physics/funcphys.f90 b/gfsphysics/physics/funcphys.f90 deleted file mode 100644 index e8014f0f7..000000000 --- a/gfsphysics/physics/funcphys.f90 +++ /dev/null @@ -1,2899 +0,0 @@ -!------------------------------------------------------------------------------- -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/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 deleted file mode 100644 index 6916dd96a..000000000 --- a/gfsphysics/physics/gcm_shoc.f90 +++ /dev/null @@ -1,1748 +0,0 @@ - -! 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 -! - improved solution for sgs-tke equation -! S Moorthi - 05-11-17 - modified shear production term to eliminate -! spurious tke ove Antarctica. -! S Moorthi - 01-12-17 - added extra pressure dependent tke dissipation at -! pressures below a critical value pcrit -! S Moorthi - 04-12-17 - fixed a bug in the definition of hl on input -! replacing fac_fus by fac_sub -! S.Moorthi - 00-00-17 - added an alternate option for near boundary cek following -! Scipion et. al., from U. Oklahoma. - - - - subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & - prsl, delp, phii, phil, u, v, omega, tabs, & - qwv, qi, qc, qpi, qpl, rhc, supice, & - pcrit, cefac, cesfac, tkef1, dis_opt, & - cld_sgs, tke, hflx, evap, prnum, tkh, & - wthv_sec, lprnt, ipr, imp_phys, ncpl, ncpi) - - use machine , only : kind_phys - 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 :: zero=0.0d0, one=1.0d0, half=0.5d0, two=2.0d0, eps=0.622d0, & - three=3.0d0, oneb3=one/three, twoby3=two/three, fourb3=twoby3+twoby3 - real, parameter :: lsub = lcond+lfus, fac_cond = lcond/cp, fac_fus = lfus/cp, & - cpolv = cp/lcond, & - fac_sub = lsub/cp, ggri = one/ggr, kapa = rgas/cp, & - gocp = ggr/cp, rog = rgas*ggri, sqrt2 = sqrt(two), & - sqrtpii = one/sqrt(pi+pi), epsterm = rgas/rv, & - onebeps = one/epsterm, twoby15 = two / 15.0d0, & - onebrvcp= one/(rv*cp), skew_facw=1.2d0, skew_fact=0.0d0, & - nmin = 1.0d0, RI_cub = 6.4d-14, RL_cub = 1.0d-15, & - tkhmax=300.0d0, qcmin=1.0d-9 - -! onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=1.0, & - - 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) :: 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) - integer, intent(in) :: imp_phys! microphysics identifier - real, intent(in) :: dtn ! Physics time step, s - - real, intent(in) :: pcrit ! pressure in Pa below which additional tke dissipation is applied - real, intent(in) :: cefac ! tunable multiplier to dissipation term - real, intent(in) :: cesfac ! tunable multiplier to dissipation term for bottom level - real, intent(in) :: tkef1 ! uncentering terms in implicit tke integration - real, intent(in) :: dis_opt ! when > 0 use different formula for near surface dissipation - - 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,nzm) ! mean layer presure - real, intent(in) :: delp (ix,nzm) ! layer presure depth - real, intent(in) :: phii (ix,nz ) ! interface geopotential height - real, intent(in) :: phil (ix,nzm) ! layer geopotential height - real, intent(in) :: u (ix,nzm) ! u-wind, m/s - real, intent(in) :: v (ix,nzm) ! v-wind, m/s - real, intent(in) :: omega (ix,nzm) ! omega, Pa/s - real, intent(inout) :: tabs (ix,nzm) ! temperature, K - real, intent(inout) :: qwv (ix,nzm) ! water vapor mixing ratio, kg/kg - real, intent(inout) :: qc (ix,nzm) ! cloud water mixing ratio, kg/kg - real, intent(inout) :: qi (ix,nzm) ! cloud ice mixing ratio, kg/kg -! Anning Cheng 03/11/2016 SHOC feedback to number concentration - - real, intent(inout) :: ncpl (nx,nzm) ! cloud water number concentration,/m^3 - real, intent(inout) :: ncpi (nx,nzm) ! cloud ice number concentration,/m^3 - real, intent(in) :: qpl (nx,nzm) ! rain mixing ratio, kg/kg - real, intent(in) :: qpi (nx,nzm) ! snow mixing ratio, kg/kg - - real, intent(inout) :: rhc (nx,nzm) ! critical relative humidity - real, intent(in) :: supice ! ice supersaturation parameter - real, intent(out) :: cld_sgs(ix,nzm) ! sgs cloud fraction -! real, intent(inout) :: cld_sgs(nx,nzm) ! sgs cloud fraction - real, intent(inout) :: tke (ix,nzm) ! turbulent kinetic energy. m**2/s**2 -! real, intent(inout) :: tk (nx,nzm) ! eddy viscosity - real, intent(inout) :: tkh (ix,nzm) ! eddy diffusivity - real, intent(inout) :: prnum (nx,nzm) ! turbulent Prandtl number - real, intent(inout) :: wthv_sec (ix,nzm) ! Buoyancy flux, K*m/s - -! SHOC tunable parameters - - real, parameter :: lambda = 0.04d0 -! real, parameter :: min_tke = 1.0d-6 ! Minumum TKE value, m**2/s**2 - real, parameter :: min_tke = 1.0d-4 ! Minumum TKE value, m**2/s**2 -! real, parameter :: max_tke = 100.0d0 ! Maximum TKE value, m**2/s**2 - real, parameter :: max_tke = 40.0d0 ! Maximum TKE value, m**2/s**2 -! Maximum turbulent eddy length scale, m -! real, parameter :: max_eddy_length_scale = 2000.0d0 - real, parameter :: max_eddy_length_scale = 1000.0d0 -! Maximum "return-to-isotropy" time scale, s - real, parameter :: max_eddy_dissipation_time_scale = 2000.d0 - real, parameter :: Pr = 1.0d0 ! Prandtl number - -! Constants for the TKE dissipation term based on Deardorff (1980) - real, parameter :: pt19=0.19d0, pt51=0.51d0, pt01=0.01d0, atmin=0.01d0, atmax=one-atmin - real, parameter :: Cs = 0.15d0, epsln=1.0d-6 -! real, parameter :: Ck = 0.2d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 - real, parameter :: Ck = 0.1d0 ! 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 -! 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.4d0 ! Von Karman constant Moorthi - as in GFS - real, parameter :: tscale=400.0d0 ! time scale set based off of similarity results of BK13, s - real, parameter :: w_tol_sqd = 4.0d-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.0d0, thresh = 0.0d0 - real, parameter :: w3_tol = 1.0d-20 ! Min vlaue of third moment of w - - -! These parameters are a tie-in with a microphysical scheme -! Double check their values for the Zhao-Carr scheme. - real, parameter :: tbgmin = 233.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 258.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 253.16d0 ! Minimum temperature for cloud water., K - real, parameter :: tbgmax = 273.16d0 ! 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 = 2.0d0, qw2tune = 2.0d0, qwthl2tune = 2.0d0, & - real, parameter :: thl2tune = 1.0d0, qw2tune = 1.0d0, qwthl2tune = 1.0d0, & -! thl_tol = 1.0d-4, rt_tol = 1.0d-8, basetemp = 300.0d0 - thl_tol = 1.0d-2, rt_tol = 1.0d-4 - - integer, parameter :: nitr=6 - -! Local variables. Note that pressure is in millibars in the SHOC code. - - real zl (nx,nzm) ! height of the pressure levels above surface, m - real zi (nx,nz) ! height of the interface levels, m - real adzl (nx,nzm) ! layer thickness i.e. zi(k+1)-zi(k) - defined at levels - real adzi (nx,nz) ! level thickness i.e. zl(k)-zl(k-1) - defined at interface - - real hl (nx,nzm) ! liquid/ice water static energy , K - real qv (nx,nzm) ! water vapor, kg/kg - real qcl (nx,nzm) ! liquid water (condensate), kg/kg - real qci (nx,nzm) ! ice water (condensate), kg/kg - real w (nx,nzm) ! z-wind, m/s - real bet (nx,nzm) ! ggr/tv0 - real gamaz (nx,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,nzm) ! Second moment total water mixing ratio, kg^2/kg^2 - real thl_sec (nx,nzm) ! Second moment liquid/ice static energy, K^2 - real qwthl_sec(nx,nzm) ! Covariance tot. wat. mix. ratio and static energy, K*kg/kg - real wqw_sec (nx,nzm) ! Turbulent flux of tot. wat. mix., kg/kg*m/s - real wthl_sec (nx,nzm) ! Turbulent flux of liquid/ice static energy, K*m/s - real w_sec (nx,nzm) ! Second moment of vertical velocity, m**2/s**2 - real w3 (nx,nzm) ! Third moment of vertical velocity, m**3/s**3 - real wqp_sec (nx,nzm) ! Turbulent flux of precipitation, kg/kg*m/s - -! Eddy length formulation - real smixt (nx,nzm) ! Turbulent length scale, m - real isotropy (nx,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s -! real isotropy_debug (nx,nzm) ! Return to isotropy scale, s without artificial limits - real brunt (nx,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 - real conv_vel2(nx,nzm) ! Convective velocity scale cubed, m^3/s^3 - - real cek(nx) - -! Output of SHOC - real diag_frac, diag_qn, diag_qi, diag_ql - -! real diag_frac(nx,nzm) ! SGS cloud fraction -! real diag_qn (nx,nzm) ! SGS cloud+ice condensate, kg/kg -! real diag_qi (nx,nzm) ! SGS ice condensate, kg/kg -! real diag_ql (nx,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,nzm) :: tkesbbuoy, tkesbshear, tkesbdiss, tkesbbuoy_debug & -! tkebuoy_sgs, total_water, tscale1_debug, brunt2 - - real, dimension(nx,nzm) :: total_water, brunt2, thv, tkesbdiss - real, dimension(nx,nzm) :: def2 - real, dimension(nx) :: denom, numer, l_inf, cldarr, thedz, thedz2 - - real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & - 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, & - esval, esval2, om1, om2, epss, & - 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 - - - integer i,k,km1,ku,kd,ka,kb - -! - epss = eps * supice -! 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 i=1,nx - zi(i,k) = phii(i,k) * ggri - enddo - enddo - -! if (lprnt) write(0,*)' tabsin=',tabs(ipr,:) -! if (lprnt) write(0,*)' qcin=',qc(ipr,:) -! if (lprnt) write(0,*)' qwvin=',qwv(ipr,:) -! if (lprnt) write(0,*)' qiin=',qi(ipr,:) -! if (lprnt) write(0,*)' qplin=',qpl(ipr,:) -! if (lprnt) write(0,*)' qpiin=',qpi(ipr,:) -! if (lprnt) write(0,*)' tkein=',tke(ipr,:) -! -! move water from vapor to condensate if the condensate is negative -! - do k=1,nzm - do i=1,nx - if (qc(i,k) < zero) then - qwv(i,k) = qwv(i,k) + qc(i,k) - tabs(i,k) = tabs(i,k) - fac_cond * qc(i,k) - qc(i,k) = zero - endif - if (qi(i,k) < zero) then - qwv(i,k) = qwv(i,k) + qi(i,k) - tabs(i,k) = tabs(i,k) - fac_sub * qi(i,k) - qi(i,k) = zero - endif - enddo - enddo -! fill negative water vapor from below - do k=nzm,2,-1 - km1 = k - 1 - do i=1,nx - if (qwv(i,k) < zero) then - qwv(i,k) = qwv(i,km1) + qwv(i,k) * delp(i,k) / delp(i,km1) - endif - enddo - enddo - -! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,:) -! if (lprnt) write(0,*)' qwvin2=',qwv(ipr,:) - - do k=1,nzm - do i=1,nx - zl(i,k) = phil(i,k) * ggri - wrk = one / prsl(i,k) - qv(i,k) = max(qwv(i,k), zero) - thv(i,k) = tabs(i,k) * (one+epsv*qv(i,k)) - w(i,k) = - rog * omega(i,k) * thv(i,k) * wrk - qcl(i,k) = max(qc(i,k), zero) - qci(i,k) = max(qi(i,k), zero) -! -! qpl(i,k) = zero ! comment or remove when using with prognostic rain/snow -! qpi(i,k) = zero ! comment or remove when using with prognostic rain/snow - - wqp_sec(i,k) = zero ! Turbulent flux of precipiation -! - total_water(i,k) = qcl(i,k) + qci(i,k) + qv(i,k) - - prespot = (100000.0d0*wrk) ** kapa ! Exner function - bet(i,k) = ggr/(tabs(i,k)*prespot) ! Moorthi - thv(i,k) = thv(i,k)*prespot ! Moorthi -! -! Lapse rate * height = reference temperature - gamaz(i,k) = gocp * zl(i,k) - -! Liquid/ice water static energy - ! Note the the units are degrees K - hl(i,k) = tabs(i,k) + gamaz(i,k) - fac_cond*(qcl(i,k)+qpl(i,k)) & - - fac_sub *(qci(i,k)+qpi(i,k)) -! if (lprnt .and. i == ipr .and. k<=10) write(0,*)' hl=',hl(i,k), & -! ' tabs=',tabs(i,k),' gamaz=',gamaz(i,k), ' fac_cond=',fac_cond, & -! ' qcl=',qcl(i,k),' qpl=',qpl(i,k),' qci=',qci(i,k),' qpi=',qpi(i,k),& -! ' fac_sub=',fac_sub,' k=',k - w3(i,k) = zero - enddo - enddo - -! if (lprnt) write(0,*)' hlin=',hl(ipr,1:40) - -! Define vertical grid increments for later use in the vertical differentiation - - do k=2,nzm - km1 = k - 1 - do i=1,nx - adzi(i,k) = zl(i,k) - zl(i,km1) - adzl(i,km1) = zi(i,k) - zi(i,km1) - enddo - enddo - do i=1,nx - adzi(i,1) = (zl(i,1)-zi(i,1)) ! unused in the code - adzi(i,nz) = adzi(i,nzm) ! at the top - probably unused - adzl(i,nzm) = zi(i,nz) - zi(i,nzm) -! - wthl_sec(i,1) = hflx(i) - wqw_sec(i,1) = evap(i) - 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 i=1,nx - if (tke(i,k) > zero) then -! wrk = half*(tkh(i,ka)+tkh(i,kb))*(w(i,ku) - w(i,kd)) & - wrk = half*(tkh(i,ka)*prnum(i,ka)+tkh(i,kb)*prnum(i,kb))*(w(i,ku) - w(i,kd)) & - * sqrt(tke(i,k)) / (zl(i,ku) - zl(i,kd)) - w_sec(i,k) = max(twoby3 * tke(i,k) - twoby15 * wrk, zero) -! w_sec(i,k) = max(twoby3 * tke(i,k), zero) -! if(lprnt .and. i == ipr .and. k <40) write(0,*)' w_sec=',w_sec(i,k),' tke=r',tke(i,k),& -! ' tkh=',tkh(i,ka),tkh(i,kb),' w=',w(i,ku),w(i,kd),' prnum=',prnum(i,ka),prnum(i,kb) - else - w_sec(i,k) = zero - endif - enddo - enddo - - do k=2,nzm - - km1 = k - 1 - 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,k) ! adzi(k) = (zl(k)-zl(km1)) -! wrk3 = max(tkh(i,k),pt01) * wrk1 - wrk3 = max(tkh(i,k),epsln) * wrk1 - - sm = half*(isotropy(i,k)+isotropy(i,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 - -! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 -! No rain, snow or graupel in pdf (Annig, 08/29/2018) - - wrk1 = hl(i,k) - hl(i,km1) & - + (qpl(i,k) - qpl(i,km1)) * fac_cond & - + (qpi(i,k) - qpi(i,km1)) * fac_sub - wthl_sec(i,k) = - wrk3 * wrk1 - -! SGS vertical flux of total water. Eq 2 in BK13 - - wrk2 = total_water(i,k) - total_water(i,km1) - wqw_sec(i,k) = - wrk3 * wrk2 - -! Second moment of liquid/ice water static energy. Eq 4 in BK13 - - thl_sec(i,k) = thl2tune * sm * wrk1 * wrk1 - -! Second moment of total water mixing ratio. Eq 3 in BK13 - - qw_sec(i,k) = qw2tune * sm * wrk2 * wrk2 - -! Covariance of total water mixing ratio and liquid/ice water static energy. -! Eq 5 in BK13 - - qwthl_sec(i,k) = qwthl2tune * sm * wrk1 * wrk2 - - enddo ! i loop - enddo ! k loop - -! These would be at the surface - do we need them? - do i=1,nx -! wthl_sec(i,1) = wthl_sec(i,2) -! wqw_sec(i,1) = wqw_sec(i,2) - thl_sec(i,1) = thl_sec(i,2) - qw_sec(i,1) = qw_sec(i,2) - qwthl_sec(i,1) = qwthl_sec(i,2) - 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() - -! if (lprnt) write(0,*)' tabsout=',tabs(ipr,1:40) -! if (lprnt) write(0,*)' qcout=',qc(ipr,1:40) -! if (lprnt) write(0,*)' qwvout=',qwv(ipr,1:40) -! if (lprnt) write(0,*)' qiout=',qi(ipr,1:40) - -contains - - subroutine tke_shoc() - -! This subroutine solves the TKE equation, -! Heavily based on SAM's tke_full.f90 by Marat Khairoutdinov - - real grd,betdz,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, tkef2 - integer i,k,ku,kd,itr,k1 - - rdtn = one / dtn - - call tke_shear_prod(def2) ! Calculate shear production of TKE - -! Ensure values of TKE are reasonable - - do k=1,nzm - do i=1,nx - tke(i,k) = max(min_tke,tke(i,k)) - tkesbdiss(i,k) = zero -! tkesbshear(i,k) = zero -! tkesbbuoy(i,k) = zero - enddo - enddo - - call eddy_length() ! Find turbulent mixing length - call check_eddy() ! Make sure it's reasonable - - tkef2 = one - tkef1 - do k=1,nzm - ku = k+1 - kd = k - -! Cek = Ce * cefac - - if(k == 1) then - ku = 2 - kd = 2 -! Cek = Ces - elseif(k == nzm) then - ku = k - kd = k -! Cek = Ces - endif - - if (dis_opt > 0) then - do i=1,nx - wrk = (zl(i,k)-zi(i,1)) / adzl(i,1) + 1.5d0 - cek(i) = (one + two / max((wrk*wrk - 3.3d0), 0.5d0)) * cefac - enddo - else - if (k == 1) then - cek = ces * cesfac - else - cek = ce * cefac - endif - endif - - do i=1,nx - grd = adzl(i,k) ! adzl(k) = zi(k+1)-zi(k) - - -! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in -! assumed_pdf(). The value used here is from the previous time step - - a_prod_bu = ggr / thv(i,k) * wthv_sec(i,k) - -! If wthv_sec from subgrid PDF is not available use Brunt-Vaisalla frequency from eddy_length() - -!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+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001d0) ! tkh is eddy thermal diffussivity - - -!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.1d0*grd, 0.76d0*sqrt(tke(i,k)/(buoy_sgs+1.0d-10)))) - endif - - ratio = smix/grd - Cee = Cek(i) * (pt19 + pt51*ratio) * max(one, sqrt(pcrit/prsl(i,k))) - -! TKE shear production term - a_prod_sh = half*(def2(i,ku)*tkh(i,ku)*prnum(i,ku) & - + def2(i,kd)*tkh(i,kd)*prnum(i,kd)) - - -! smixt (turb. mixing lenght) is calculated in eddy_length() -! Explicitly integrate TKE equation forward in time -! a_diss = Cee/smixt(i,k)*tke(i,k)**1.5 ! TKE dissipation term -! tke(i,k) = max(zero,tke(i,k)+dtn*(max(zero,a_prod_sh+a_prod_bu)-a_diss)) - -! Semi-implicitly integrate TKE equation forward in time - - wtke = tke(i,k) - wtk2 = wtke -! wrk = (dtn*Cee)/smixt(i,k) - wrk = (dtn*Cee) / smixt(i,k) - wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wrk1=',wrk1,& -! ' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,' dtn=',dtn,' smixt=',& -! smixt(i,k),' tkh=',tkh(i,ku),tkh(i,kd),' def2=',def2(i,ku),def2(i,kd)& -! ,' prnum=',prnum(i,ku),prnum(i,kd),' wthv_sec=',wthv_sec(i,k),' thv=',thv(i,k) - - 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 / (one+a_diss) - wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& -! ' a_diss=',a_diss,' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,& -! ' wrk1=',wrk1,' itr=',itr,' k=',k - - wtk2 = wtke - - enddo - - tke(i,k) = min(max(min_tke, wtke), max_tke) - a_diss = wrk*sqrt(tke(i,k)) - - tscale1 = (dtn+dtn) / a_diss ! corrected Eq 8 in BK13 -- tau = 2*tke/eps - - tkesbdiss(i,k) = rdtn*a_diss*tke(i,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,k) = min(max_eddy_dissipation_time_scale, tscale1) - else - isotropy(i,k) = min(max_eddy_dissipation_time_scale, & - tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) - endif -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' isotropy=',isotropy(i,k),& -! ' buoy_sgs=',buoy_sgs,' lambda=',lambda,' tscale1=',tscale1 - -! TKE budget terms - -! tkesbdiss(i,k) = a_diss -! tkesbshear(i,k) = a_prod_sh -! tkesbbuoy(i,k) = a_prod_bu -! tkesbbuoy_debug(i,k) = a_prod_bu_debug -! tkebuoy_sgs(i,k) = buoy_sgs - - enddo ! i loop - enddo ! k -! - wrk = half * ck - do k=2,nzm - k1 = k - 1 - do i=1,nx - tkh(i,k) = min(tkhmax, wrk * (isotropy(i,k) * tke(i,k) & - + isotropy(i,k1) * tke(i,k1))) ! Eddy thermal diffusivity - enddo ! i -! if (lprnt) write(0,*)' shocendtkh=',tkh(ipr,k),' tke=',tke(ipr,k),& -! tke(ipr,k1),' isot=',isotropy(ipr,k),isotropy(ipr,k1),'k=',k,' k1=',k1 - enddo ! k - - - end subroutine tke_shoc - - - subroutine tke_shear_prod(def2) - -! Calculate TKE shear production term - - real, intent(out) :: def2(nx,nzm) - - real rdzw, wrku, wrkv, wrkw - integer i,k,k1 - -! Calculate TKE shear production term at layer interface - - do k=2,nzm - k1 = k - 1 - do i=1,nx - rdzw = one / adzi(i,k) - wrku = (u(i,k)-u(i,k1)) * rdzw - wrkv = (v(i,k)-v(i,k1)) * rdzw -! wrkw = (w(i,k)-w(i,k1)) * rdzw - def2(i,k) = wrku*wrku + wrkv*wrkv !+ 2*wrkw(1) * wrkw(1) - enddo - enddo ! k loop - do i=1,nx -! def2(i,1) = def2(i,2) - def2(i,1) = (u(i,1)*u(i,1) + v(i,1)*v(i,1)) / (zl(i,1)*zl(i,1)) - enddo - - 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, k, kk, kl, ku, kb, kc, kli, kui - - do i=1,nx - cldarr(i) = zero - numer(i) = zero - denom(i) = zero - enddo - -! Find the length scale outside of clouds, that includes boundary layers. - - do k=1,nzm - do i=1,nx - -! Reinitialize the mixing length related arrays to zero -! smixt(i,k) = one ! shoc_mod module variable smixt - smixt(i,k) = epsln ! shoc_mod module variable smixt - brunt(i,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,k)+qci(i,k) <= qcmin) then - tkes = sqrt(tke(i,k)) * adzl(i,k) - numer(i) = numer(i) + tkes*zl(i,k) ! Numerator in Eq. 11 in BK13 - denom(i) = denom(i) + tkes ! Denominator in Eq. 11 in BK13 - else - cldarr(i) = one ! Take note of columns containing cloud. - endif - enddo - enddo - -! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) - do i=1,nx - if (denom(i) > zero .and. numer(i) > zero) then - l_inf(i) = min(0.1d0 * (numer(i)/denom(i)), 100.0d0) - else - l_inf(i) = 100.0d0 - endif - 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 - if (k == 1) then - kb = 1 - kc = 2 - thedz(:) = adzi(:,kc) - elseif (k == nzm) then - kb = nzm-1 - kc = nzm - thedz(:) = adzi(:,k) - else - thedz(:) = adzi(:,kc) + adzi(:,k) ! = (z(k+1)-z(k-1)) - endif - - do i=1,nx - -! vars module variable bet (=ggr/tv0) ; grid module variable adzi - - betdz = bet(i,k) / thedz(i) - - tkes = sqrt(tke(i,k)) - -! Compute local Brunt-Vaisalla frequency - - wrk = qcl(i,k) + qci(i,k) - if (wrk > zero) then ! If in the cloud - -! Find the in-cloud Brunt-Vaisalla frequency - - omn = qcl(i,k) / (wrk+1.0d-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,k),prsl(i,k)) & - + (one-omn) * dtqsati(tabs(i,k),prsl(i,k)) - -! Saturation mixing ratio over water/ice wrt temp based on relative water phase content - - qsatt = omn * qsatw(tabs(i,k),prsl(i,k)) & - + (one-omn) * qsati(tabs(i,k),prsl(i,k)) - -! liquid/ice moist static energy static energy divided by cp? - - bbb = (one + epsv*qsatt-wrk-qpl(i,k)-qpi(i,k) & - + 1.61d0*tabs(i,k)*dqsat) / (one+lstarn*dqsat) - -! Calculate Brunt-Vaisalla frequency using centered differences in the vertical - - brunt(i,k) = betdz*(bbb*(hl(i,kc)-hl(i,kb)) & - + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,k)) & - * (total_water(i,kc)-total_water(i,kb)) & - + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,k))*(qpl(i,kc)-qpl(i,kb)) & - + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,k))*(qpi(i,kc)-qpi(i,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,k) - qpl(i,k) - qpi(i,k) - brunt(i,k) = betdz*( bbb*(hl(i,kc)-hl(i,kb)) & - + epsv*tabs(i,k)*(total_water(i,kc)-total_water(i,kb)) & - + (bbb*fac_cond-tabs(i,k))*(qpl(i,kc)-qpl(i,kb)) & - + (bbb*fac_sub -tabs(i,k))*(qpi(i,kc)-qpi(i,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,k) >= zero) then - brunt2(i,k) = brunt(i,k) - else - brunt2(i,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,k) = term + (0.4*zl(i,k)-term)*exp(-zl(i,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) > zero) then - wrk1 = one / (tscale*tkes*vonk*zl(i,k)) - wrk2 = one / (tscale*tkes*l_inf(i)) - wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,k) / tke(i,k) - wrk1 = sqrt(one / max(wrk1,1.0d-8)) * (one/0.3d0) -! smixt(i,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) - smixt(i,k) = min(max_eddy_length_scale, wrk1) - -! smixt(i,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,k))) & -! + (1./(tscale*tkes*l_inf(i)))+0.01*(brunt2(i,k)/tke(i,k)))))/0.3) -! else -! smixt(i,k) = zero - endif - -! endif - - - 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 i=1,nx -! conv_vel2(i,1) = zero ! Convective velocity scale cubed -! enddo - ! Integrate velocity scale in the vertical -! do k=2,nzm -! do i=1,nx -! conv_vel2(i,k) = conv_vel2(i,k-1) & -! + 2.5*adzi(i,k)*bet(i,k)*wthv_sec(i,k) -! enddo -! enddo - - do i=1,nx - - if (cldarr(i) == 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,k) + qci(i,k) - if (wrk > qcmin) then - if (kl == 0) then - kl = k - endif - -! Look for the cloud top in this column - if (qcl(i,k+1)+qci(i,k+1) <= qcmin) 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,k)** oneb3 - endif - 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 (kl > 0 .and. ku > 0 .and. ku-kl > 0) then - if (kl > 0 .and. ku >= kl) then -! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud - conv_var = zero - do kk=kl,ku - conv_var = conv_var+ 2.5d0*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) - enddo - conv_var = conv_var ** oneb3 - - if (conv_var > zero) then ! If convective vertical velocity scale > 0 - - depth = (zl(i,ku)-zl(i,kl)) + adzl(i,kl) - - do kk=kl,ku -! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) - -! wrk = conv_var/(depth*sqrt(tke(i,kk))) -! wrk = wrk * wrk + pt01*brunt2(i,kk)/tke(i,kk) - - wrk = conv_var/(depth*depth*sqrt(tke(i,kk))) & - + pt01*brunt2(i,kk)/tke(i,kk) - - smixt(i,kk) = min(max_eddy_length_scale, (one/0.3d0)*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 - - - 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, 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 i=1,nx - conv_vel2(i,1) = zero ! Convective velocity scale cubed - enddo -! Integrate velocity scale in the vertical - do k=2,nzm -! conv_vel(k)=conv_vel(k-1) - 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,k)*bet(i,k)*(tvws(k)) -!Do not include grid-scale contribution to convective velocity scale in GCM applications -! conv_vel2(i,k)=conv_vel2(i,k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+wthv_sec(i,k)) -!********************************************************************** - - conv_vel2(i,k) = conv_vel2(i,k-1) & - + 2.5d0*adzi(i,k)*bet(i,k)*wthv_sec(i,k) - enddo - enddo - - end subroutine conv_scale - - - subroutine check_eddy() - -! This subroutine checks eddy length values - - integer i, 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 i=1,nx - - wrk = 0.1d0*adzl(i,k) - ! Minimum 0.1 of local dz - smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,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,k)=min(sqrt(dx*dy),smixt(i,k)) - - if (qcl(i,kb) == zero .and. qcl(i,k) > zero .and. brunt(i,k) > 1.0d-4) then -!If just above the cloud top and atmosphere is stable, set to 0.1 of local dz - smixt(i,k) = wrk - endif - - enddo ! i - 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, k, kb, kc - - real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & - omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & - wrk, wrk1, wrk2, wrk3, avew -! cond_w, wrk, wrk1, wrk2, wrk3, avew -! -! See Eq. 7 in C01 (B.7 in Pete's dissertation) - real, parameter :: c=7.0d0, a0=0.52d0/(c*c*(c-2.0d0)), a1=0.87d0/(c*c), & - a2=0.5d0/c, a3=0.6d0/(c*(c-2.0d0)), a4=2.4d0/(3.0d0*c+5.0d0), & - a5=0.6d0/(c*(3.0d0*c+5.0d0)) -!Moorthi a5=0.6d0/(c*(3.0d0+5.0d0*c)) - -! do k=1,nzm - do k=2,nzm - - kb = k-1 - kc = k+1 - -! if(k == 1) then -! kb = 1 -! kc = 2 -! do i=1,nx -! thedz(i) = one / adzl(i,kc) -! thedz2(i) = thedz(i) -! enddo -! elseif(k == nzm) then - if(k == nzm) then - kb = nzm-1 - kc = nzm - do i=1,nx - thedz(i) = one / adzi(i,k) - thedz2(i) = one / adzl(i,kb) - enddo - else - do i=1,nx - thedz(i) = one / adzi(i,k) - thedz2(i) = one / (adzl(i,k)+adzl(i,kb)) - enddo - endif - - - do i=1,nx - - iso = half*(isotropy(i,k)+isotropy(i,kb)) - isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared - buoy_sgs2 = isosqr*half*(brunt(i,k)+brunt(i,kb)) - bet2 = half*(bet(i,k)+bet(i,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,k)+w_sec(i,kb)) - -!aab -! - - wrk1 = bet2*iso - wrk2 = thedz2(i)*wrk1*wrk1*iso - wrk3 = thl_sec(i,kc) - thl_sec(i,kb) - - f0 = wrk2 * wrk1 * wthl_sec(i,k) * wrk3 - - wrk = wthl_sec(i,kc) - wthl_sec(i,kb) - - f1 = wrk2 * (wrk*wthl_sec(i,k) + half*avew*wrk3) - - wrk1 = bet2*isosqr - f2 = thedz(i)*wrk1*wthl_sec(i,k)*(w_sec(i,k)-w_sec(i,kb)) & - + (thedz2(i)+thedz2(i))*bet(i,k)*isosqr*wrk - - f3 = thedz2(i)*wrk1*wrk + thedz(i)*bet2*isosqr*(wthl_sec(i,k)*(tke(i,k)-tke(i,kb))) - - wrk1 = thedz(i)*iso*avew - f4 = wrk1*(w_sec(i,k)-w_sec(i,kb) + tke(i,k)-tke(i,kb)) - - f5 = wrk1*(w_sec(i,k)-w_sec(i,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.0d0/4.0d0)*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_w is an estimate of third moment from second oment - If the third moment is larger -! than the estimate - limit w3. - -!aab - -! 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 - do i=1,nx - w3(i,1) = w3(i,2) - 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,k,ku,kd - real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2, cond_w - -! 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 i=1,nx - -! Initialize cloud variables to zero - diag_qn = zero - diag_frac = zero - diag_ql = zero - diag_qi = zero - - pval = prsl(i,k) - pfac = pval * 1.0d-5 - pkap = pfac ** kapa - -! Read in liquid/ice static energy, total water mixing ratio, -! and vertical velocity to variables PDF needs - thl_first = hl(i,k) + fac_cond*qpl(i,k) + fac_sub*qpi(i,k) - qw_first = total_water(i,k) -! w_first = half*(w(i,kd)+w(i,ku)) - w_first = w(i,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 - - if (k < nzm) then - w3var = half*(w3(i,kd)+w3(i,ku)) - thlsec = max(zero, half*(thl_sec(i,kd)+thl_sec(i,ku)) ) - qwsec = max(zero, half*(qw_sec(i,kd)+qw_sec(i,ku)) ) - qwthlsec = half * (qwthl_sec(i,kd) + qwthl_sec(i,ku)) - wqwsec = half * (wqw_sec(i,kd) + wqw_sec(i,ku)) - wthlsec = half * (wthl_sec(i,kd) + wthl_sec(i,ku)) - else ! at the model top assuming zeros - w3var = half*w3(i,k) - thlsec = max(zero, half*thl_sec(i,k)) - qwsec = max(zero, half*qw_sec(i,k)) - qwthlsec = half * qwthl_sec(i,k) - wqwsec = half * wqw_sec(i,k) - wthlsec = half * wthl_sec(i,k) - endif - -! w3var = w3(i,k) -! thlsec = max(zero,thl_sec(i,k)) -! qwsec = max(zero,qw_sec(i,k)) -! qwthlsec = qwthl_sec(i,k) -! wqwsec = wqw_sec(i,k) -! wthlsec = wthl_sec(i,k) - -! Compute square roots of some variables so we don't have to do it again -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' w_sec=',w_sec(i,k),' k=',k - if (w_sec(i,k) > zero) then - sqrtw2 = sqrt(w_sec(i,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,k)**(3./2.) -! Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi - - IF (w_sec(i,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 -!aab - - 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.4d0 - w2_2 = 0.4d0 - -! 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(atmin,min(half*(one-Skew_w*sqrt(one/(4.0d0*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) - 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,k) - w2_2 = w2_2 * w_sec(i,k) - - ENDIF - -! Find parameters of the PDF of liquid/ice static energy - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thlsec=',thlsec,' w1_2=',w1_2,' w1_1=',w1_1,& -! ' thl_first=',thl_first,' k=',k,' wthlsec=',wthlsec,sqrtw2,sqrtthl - 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 = three * (one - aterm*wrk1 - onema*wrk2) - wrk4 = -skew_facw*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi -! 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 = three * (thl1_2-thl1_1) - if (wrk /= zero) then - thl2_1 = thlsec * min(100.0d0,max(zero,( thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - thl2_2 = thlsec * min(100.0d0,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 - else - thl2_1 = zero - thl2_2 = zero - endif -! -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' sqrtthl=',sqrtthl,' thl_first=',thl_first,& -! ' thl1_2=',thl1_2,' corrtest1=',corrtest1,' w1_2=',w1_2,' w1_1=',w1_1 - - thl1_1 = thl1_1*sqrtthl + thl_first - thl1_2 = thl1_2*sqrtthl + thl_first - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' thl1_2=',thl1_2 - - 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 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' qw1_1=',qw1_1,' corrtest2=',corrtest2,& -! ' w1_2=',w1_2,' wqwsec=',wqwsec,' sqrtw2=',sqrtw2,' sqrtqt=',sqrtqt,' qwsec=',qwsec - - tsign = abs(qw1_2-qw1_1) - -! Skew_qw = skew_facw*Skew_w - - IF (tsign > 0.4d0) THEN - Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2d0) THEN - Skew_qw = zero - ELSE - Skew_qw = (skew_facw/0.2d0) * Skew_w * (tsign-0.2d0) - ENDIF - - wrk1 = qw1_1 * qw1_1 - wrk2 = qw1_2 * qw1_2 - wrk3 = three * (one - aterm*wrk1 - onema*wrk2) - wrk4 = Skew_qw - aterm*wrk1*qw1_1 - onema*wrk2*qw1_2 - wrk = three * (qw1_2-qw1_1) - - if (wrk /= zero) then - qw2_1 = qwsec * min(100.0d0,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - qw2_2 = qwsec * min(100.0d0,max(zero,(-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 == zero) 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 - -! wrk1 = gamaz(i,k) - fac_cond*qpl(i,k) - fac_sub*qpi(i,k) -! Tl1_1 = thl1_1 - wrk1 -! Tl1_2 = thl1_2 - wrk1 - - Tl1_1 = thl1_1 - gamaz(i,k) - Tl1_2 = thl1_2 - gamaz(i,k) - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' Tl1_1=',Tl1_1,' Tl1_2=',Tl1_2,& -! ' wrk1=',wrk1,' thl1_1=',thl1_1,' thl1_2=',thl1_2,' qpl=',qpl(i,k),' qpi=',qpi(i,k) - -! Now compute qs - -! Partition based on temperature for the first plume - - IF (Tl1_1 >= tbgmax) THEN - lstarn1 = lcond - esval = min(fpvsl(Tl1_1), pval) -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' esval=',esval,' pval=',pval,' eps=',eps - qs1 = eps * esval / (pval-0.378d0*esval) - ELSE IF (Tl1_1 <= tbgmin) THEN - lstarn1 = lsub - esval = min(fpvsi(Tl1_1), pval) - qs1 = epss * esval / (pval-0.378d0*esval) - ELSE - om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) - lstarn1 = lcond + (one-om1)*lfus - esval = min(fpvsl(Tl1_1), pval) - esval2 = min(fpvsi(Tl1_1), pval) - qs1 = om1 * eps * esval / (pval-0.378d0*esval) & - + (one-om1) * epss * esval2 / (pval-0.378d0*esval2) - ENDIF - -! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) -! beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 - - beta1 = lstarn1 / Tl1_1 - beta1 = beta1 * beta1 * onebrvcp - - -! 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 - IF (Tl1_2 >= tbgmax) THEN - lstarn2 = lcond - esval = min(fpvsl(Tl1_2), pval) - qs2 = eps * esval / (pval-0.378d0*esval) - ELSE IF (Tl1_2 <= tbgmin) THEN - lstarn2 = lsub - esval = min(fpvsi(Tl1_2), pval) - qs2 = epss * esval / (pval-0.378d0*esval) - ELSE - om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) - lstarn2 = lcond + (one-om2)*lfus - esval = min(fpvsl(Tl1_2), pval) - esval2 = min(fpvsi(Tl1_2), pval) - qs2 = om2 * eps * esval / (pval-0.378d0*esval) & - + (one-om2) * epss * esval2 / (pval-0.378d0*esval2) - ENDIF - -! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 -! beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 - - beta2 = lstarn2 / Tl1_2 - beta2 = beta2 * beta2 * onebrvcp - - - ENDIF - - qs1 = qs1 * rhc(i,k) - qs2 = qs2 * rhc(i,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 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc s1=',s1,' qw1_1=',qw1_1,'wrk=',wrk,& -! ' qs1=',qs1,' beta1=',beta1,' cqt1=',cqt1 - - 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 .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=',s1,'std=',std_s1,& -! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k - - IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 - ELSEIF (s1 >= qcmin) THEN - C1 = one - 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) - ELSEIF (s2 >= qcmin) THEN - C2 = one - 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 .and. k<40) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& -! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k,' tl1=',tl1_1,tl1_2,' om1=',om1,'om2=',om2& -! ,' tbgmin=',tbgmin,'a_bg=',a_bg - - - diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,k)) - diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) - diag_qi = max(zero, diag_qn - diag_ql) - - -! Update temperature variable based on diagnosed cloud properties - om1 = max(zero, min(one, (tabs(i,k)-tbgmin)*a_bg)) - lstarn1 = lcond + (one-om1)*lfus - tabs(i,k) = hl(i,k) - gamaz(i,k) + fac_cond*(diag_ql+qpl(i,k)) & - + fac_sub *(diag_qi+qpi(i,k)) & - + tkesbdiss(i,k) * (dtn/cp) ! tke dissipative heating - -! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,k),' k=',k& -! ,' hl=',hl(i,k),' gamaz=',gamaz(i,k),' diag_ql=',diag_ql,' qpl=',qpl(i,k)& -! ,' diag_qi=',diag_qi,' qpi=',qpi(i,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& -! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 - -! Update ncpl and ncpi Anning Cheng 03/11/2016 -! ncpl(i,k) = diag_ql/max(qc(i,k),1.e-10)*ncpl(i,k) - -! Update ncpl and ncpi Moorthi 12/12/2018 - if (imp_phys > 0) then - if (ncpl(i,k) > nmin) then - ncpl(i,k) = diag_ql/max(qc(i,k),1.0d-10)*ncpl(i,k) - else - ncpl(i,k) = max(diag_ql/(fourb3*pi*RL_cub*997.0d0), nmin) - endif - if (ncpi(i,k) > nmin) then - ncpi(i,k) = diag_qi/max(qi(i,k),1.0d-10)*ncpi(i,k) - else - ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0d0), nmin) - endif - endif - -! Update moisture fields - qc(i,k) = diag_ql - qi(i,k) = diag_qi - qwv(i,k) = max(zero, total_water(i,k) - diag_qn) - cld_sgs(i,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,k) - - bastoeps = onebeps * thv(i,k) - - if (k < nzm) then - wthv_sec(i,k) = wthlsec + wrk*wqwsec & - + (fac_cond-bastoeps)*wqls & - + (fac_sub-bastoeps) *wqis & - + ((lstarn1/cp)-thv(i,k))*half*(wqp_sec(i,kd)+wqp_sec(i,ku)) - else - wthv_sec(i,k) = wthlsec + wrk*wqwsec & - + (fac_cond-bastoeps)*wqls & - + (fac_sub-bastoeps) *wqis & - + ((lstarn1/cp)-thv(i,k))*half*wqp_sec(i,k) - endif - -! wthv_sec(i,k) = wthlsec + wrk*wqwsec & -! + (fac_cond-bastoeps)*wqls & -! + (fac_sub-bastoeps)*wqis & -! + ((lstarn1/cp)-basetemp)*half*(wqp_sec(i,kd)+wqp_sec(i,ku)) - - 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/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 deleted file mode 100644 index 64d234091..000000000 --- a/gfsphysics/physics/gcycle.F90 +++ /dev/null @@ -1,265 +0,0 @@ -# 1 "physics/gcycle.F90" - 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, intent(in) :: 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), & - 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) - - logical :: lake(Model%nx*Model%ny) - - character(len=6) :: tile_num_ch - real(kind=kind_phys), parameter :: pifac=180.0/pi - real(kind=kind_phys) :: sig1t, dt_warm - integer :: npts, len, nb, ix, jx, ls, ios, ll - 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_kind_phys - npts = Model%nx*Model%ny -! - 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%nstf_name(1) > 0 ) then - TSFFCS(len) = Sfcprop(nb)%tref (ix) - else - TSFFCS(len) = Sfcprop(nb)%tsfc (ix) - endif - SNOFCS (len) = Sfcprop(nb)%weasd (ix) - ZORFCS (len) = Sfcprop(nb)%zorll (ix) - if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then - ZORFCS (len) = Sfcprop(nb)%zorli (ix) - elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then - ZORFCS (len) = Sfcprop(nb)%zorlo (ix) - endif - 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) < 0.1_kind_phys .OR. SLIFCS(len) > 1.5_kind_phys) THEN - SLMASK(len) = 0.0_kind_phys - ELSE - SLMASK(len) = 1.0_kind_phys - ENDIF - - IF (SLIFCS(len) > 1.99_kind_phys) THEN - AISFCS(len) = 1.0_kind_phys - ELSE - AISFCS(len) = 0.0_kind_phys - ENDIF - if (Sfcprop(nb)%lakefrac(ix) > 0.0_kind_phys) then - lake(len) = .true. - else - lake(len) = .false. - 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), action='READ', 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, & -! Model%fhour, RLA, RLO, SLMASK, & - OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & - SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & - VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, & - SNOFCS, ZORFCS, ALBFC1, TG3FCS, CNPFCS, & - SMCFC1, STCFC1, SLIFCS, AISFCS, & - VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & - CVBFCS, CVTFCS, Model%me, Model%nlunit, & - size(Model%input_nml_file), & - Model%input_nml_file, & - lake, Model%min_lakeice, Model%min_seaice, & - 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) - if ( Model%nstf_name(1) > 0 ) then - Sfcprop(nb)%tref(ix) = TSFFCS (len) -! if ( Model%nstf_name(2) == 0 ) then -! dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & -! / Sfcprop(nb)%xz(ix) -! Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & -! + dt_warm - Sfcprop(nb)%dt_cool(ix) -! endif - else - Sfcprop(nb)%tsfc(ix) = TSFFCS (len) - Sfcprop(nb)%tsfco(ix) = TSFFCS (len) - endif - Sfcprop(nb)%weasd (ix) = SNOFCS (len) - Sfcprop(nb)%zorll (ix) = ZORFCS (len) - if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then - Sfcprop(nb)%zorli(ix) = ZORFCS (len) - elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then - Sfcprop(nb)%zorlo(ix) = ZORFCS (len) - endif - 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 - ll = len + (ls-1)*npts - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (ll) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (ll) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) - if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) - 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=',fhour - - RETURN - END diff --git a/gfsphysics/physics/get_prs.f b/gfsphysics/physics/get_prs.f deleted file mode 100644 index 9ce05c904..000000000 --- a/gfsphysics/physics/get_prs.f +++ /dev/null @@ -1,382 +0,0 @@ - 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.0d0, one=1.0d0 - &, half=0.5d0, p00i=1.0d-5 - &, rkapi=one/rkap - &, rkapp1=one+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 == 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))*half - prkl(i,k) = (prsl(i,k)*p00i) ** kappa(i,k) - enddo - enddo - do k=2,levs - do i=1,im - tem = half * (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) > zero) then - do i=1,im - prki(i,k) = (prsi(i,k)*p00i) ** kappa(i,levs) - enddo - endif -! - do i=1,im - phii(i,1) = zero ! 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) <= zero) then - do k=1,levs - do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half - enddo - enddo - endif - if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = zero ! 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))*half - 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) = zero ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k) * (one+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) <= zero) then - do k=1,levs - do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half - enddo - enddo - endif - if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = zero ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k)*(one+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) <= zero) then - do k=1,levs - do i=1,im - PRSL(i,k) = 100.0d0 * PRKL(i,k) ** rkapi - enddo - enddo - endif - if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = zero ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = CP * T(i,k) * (one + 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.0d0, one=1.0d0 - 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 == 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) * (one + 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) * (one + 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.0d0, one=1.0d0 - 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) = (one-sumq(i,k))*ri(0) + xr(i,k) - xcp(i,k) = (one-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.0d0, one=1.0d0 - 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) > zero ) 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) = (one-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.0d0, one=1.0d0 - 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) > zero ) 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) = (one-sumq(i,k))*cpi(0) + xcp(i,k) - enddo - enddo -! - return - end diff --git a/gfsphysics/physics/get_prs_fv3.f90 b/gfsphysics/physics/get_prs_fv3.f90 deleted file mode 100644 index 756a632eb..000000000 --- a/gfsphysics/physics/get_prs_fv3.f90 +++ /dev/null @@ -1,60 +0,0 @@ -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/gfsphysics/physics/gfdl_cloud_microphys.F90 b/gfsphysics/physics/gfdl_cloud_microphys.F90 deleted file mode 100644 index f01486db0..000000000 --- a/gfsphysics/physics/gfdl_cloud_microphys.F90 +++ /dev/null @@ -1,4975 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics 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. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; 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 the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics (Chen and Lin 2013) \cite chen2013seasonal and (Zhou et al. 2019) \cite zhou2019toward. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: Shian-Jiann lin, Linjiong Zhou -! ======================================================================= - -module gfdl_cloud_microphys_mod - USE module_mp_radar - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real, parameter :: rhos = 0.1e3, rhog = 0.4e3 - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - - ! real, parameter :: rdgas = 287.04 ! gfdl: gas constant for dry air - - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qrmin = 1.e-8 ! min value for ??? - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vr_min = 1.e-3 !< min fall speed for rain - real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav, fac_rc - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 0 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .true. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_qa = .true. !< do inline cloud fraction - logical :: rad_snow = .true. !< consider snow in cloud fraciton calculation - logical :: rad_graupel = .true. !< consider graupel in cloud fraction calculation - logical :: rad_rain = .true. !< consider rain in cloud fraction calculation - logical :: fix_negative = .false. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - ! logical :: master - ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & - ! id_ice, id_prec, id_cond, id_var, id_droplets - real, parameter :: dt_fr = 8. !< homogeneous freezing of all cloud water at t_wfr - dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km - - ! qi0_crt = 0.8e-4 - ! qs0_crt = 0.6e-3 - ! c_psaci = 0.1 - ! c_pgacs = 0.1 - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.25 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.25 !< rh increment for minimum evaporation of rain - real :: rh_ins = 0.25 !< rh increment for sublimation of snow - - ! conversion time scale - - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion - real :: tau_l2r = 900. !< cloud water to rain auto - conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - - ! horizontal subgrid variability - - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) - - real :: rthresh = 10.0e-6 !< critical cloud drop radius (micro m) - - ! ----------------------------------------------------------------------- - ! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33 - ! optimized: qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - ! qi_gen ~ 4.808e-7 at 0 c; 1.818e-6 at - 10 c, 9.82679e-5 at - 40c - ! the following value is constructed such that qc_crt = 0 at zero c and @ - 10c matches - ! wrf / wsm6 ice initiation scheme; qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den - ! ----------------------------------------------------------------------- - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation during remapping step if fast_sat_adj = .t. - real :: qi_gen = 1.82e-6 !< max cloud ice generation during remapping step - - ! cloud condensate upper bounds: "safety valves" for ql & qi - - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) - !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) - - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! good values: - - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. - - ! upper bounds of fall speed (with variable speed option) - - real :: vi_max = 0.5 !< max fall speed for ice - real :: vs_max = 5.0 !< max fall speed for snow - real :: vg_max = 8.0 !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< must be true when prog_ccn is false - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - real :: log_10, tice0, t_wfr - - integer :: reiflag = 1 - ! 1: Heymsfield and Mcfarquhar, 1996 - ! 2: Wyser, 1998 - - logical :: tintqs = .false. !< use temperature in the saturation mixing in PDF - - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 10.0, rermax = 10000.0 - real :: resmin = 150.0, resmax = 10000.0 - real :: regmin = 300.0, regmax = 10000.0 - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - 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, dt_in, land, rain, snow, ice, & - graupel, hydrostatic, phys_hydrostatic, iis, iie, jjs, jje, kks, & - kke, ktop, kbot, seconds,p,lradar,refl_10cm,reset) - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic,lradar - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - integer, intent (in) :: seconds - logical, intent (in) :: reset - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin, p - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :, :) :: refl_10cm - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - - logical :: melti = .false. - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes, kflip - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, dimension (size (pt, 1), size (pt, 3)) :: m2_rain, m2_sol - - real :: allmax -!+---+-----------------------------------------------------------------+ -!For 3D reflectivity calculations - REAL, DIMENSION(ktop:kbot):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ -!+---+-----------------------------------------------------------------+ - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), land (:, j), udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & - vt_s, vt_g, vt_i, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - if (do_qa) then - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - else - do j = js, je - do i = is, ie - ! qa_dt (i, j, k) = - qa (i, j, k) * rdt - qa_dt (i, j, k) = 0. ! gfs - enddo - enddo - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! diagnostic output - ! ----------------------------------------------------------------------- - - ! if (id_vtr > 0) then - ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vts > 0) then - ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vtg > 0) then - ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vti > 0) then - ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_droplets > 0) then - ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_var > 0) then - ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) - ! endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - - ! if (id_cond > 0) then - ! do j = js, je - ! do i = is, ie - ! cond (i, j) = cond (i, j) * rgrav - ! enddo - ! enddo - ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_snow > 0) then - ! used = send_data (id_snow, snow, time, iis, jjs) - ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean snow = ', tot_prec - ! endif - ! endif - ! - ! if (id_graupel > 0) then - ! used = send_data (id_graupel, graupel, time, iis, jjs) - ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean graupel = ', tot_prec - ! endif - ! endif - ! - ! if (id_ice > 0) then - ! used = send_data (id_ice, ice, time, iis, jjs) - ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean ice_mp = ', tot_prec - ! endif - ! endif - ! - ! if (id_rain > 0) then - ! used = send_data (id_rain, rain, time, iis, jjs) - ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean rain = ', tot_prec - ! endif - ! endif - ! - ! if (id_rh > 0) then !not used? - ! used = send_data (id_rh, rh0, time, iis, jjs) - ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) - ! endif - ! - ! - ! if (id_prec > 0) then - ! used = send_data (id_prec, prec_mp, time, iis, jjs) - ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) - ! endif - - ! if (mp_print) then - ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) - ! if (seconds == 0) then - ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. - ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'daily prec_mp = ', tot_prec - ! prec1 (:, :) = 0. - ! endif - ! endif - - ! call mpp_clock_end (gfdl_mp_clock) - if(lradar) then - ! Only set melti to true at the output times - if (reset) then - melti = .true. - else - melti = .false. - endif - do j = js, je - do i = is, ie - do k = ktop,kbot - kflip = kbot-ktop+1-k+1 - t1d(k) = pt(i,j,kflip) - p1d(k) = p(i,j,kflip) - qv1d(k) = qv(i,j,kflip)/(1-qv(i,j,kflip)) - qr1d(k) = qr(i,j,kflip) - qs1d(k) = qs(i,j,kflip) - qg1d(k) = qg(i,j,kflip) - enddo - call refl10cm_gfdl (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, ktop, kbot, i,j, melti) - do k = ktop,kbot - kflip = kbot-ktop+1-k+1 - refl_10cm(i,j,kflip) = MAX(-35., dBZ(k)) - enddo - enddo - enddo - endif - - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: qi, qs - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dt_rain, dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - dt_rain = dts * 0.5 - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - qiz (k) = qi (i, j, k) - qsz (k) = qs (i, j, k) - enddo - - ! ----------------------------------------------------------------------- - ! this is to prevent excessive build - up of cloud ice from external sources - ! ----------------------------------------------------------------------- - - if (de_ice) then - do k = ktop, kbot - qio = qiz (k) - dt_in * qi_dt (i, j, k) ! original qi before phys - qin = max (qio, qi0_max) ! adjusted value - if (qiz (k) > qin) then - qsz (k) = qsz (k) + qiz (k) - qin - qiz (k) = qin - dqi = (qin - qio) * rdt ! modified qi tendency - qs_dt (i, j, k) = qs_dt (i, j, k) + qi_dt (i, j, k) - dqi - qi_dt (i, j, k) = dqi - qi (i, j, k) = qiz (k) - qs (i, j, k) = qsz (k) - endif - enddo - endif - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qrz (k) = qr (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = 0. - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - if (prog_ccn) then - do k = ktop, kbot - ! convert # / cc to # / m^3 - ccn (k) = qn (i, j, k) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - use_ccn = .false. - else - ccn0 = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - if (use_ccn) then - ! ----------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! ----------------------------------------------------------------------- - ccn0 = ccn0 * rdgas * tz (kbot) / p1 (kbot) - endif - tmp = cpaut * (ccn0 * rhor) ** (- 1. / 3.) - do k = ktop, kbot - c_praut (k) = tmp - ccn (k) = ccn0 - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate horizontal subgrid variability - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - - s_leng = sqrt (sqrt (area1 (i) / 1.e10)) - t_land = dw_land * s_leng - t_ocean = dw_ocean * s_leng - h_var = t_land * land (i) + t_ocean * (1. - land (i)) - h_var = min (0.20, max (0.01, h_var)) - ! if (id_var > 0) w_var (i, j) = h_var - - ! ----------------------------------------------------------------------- - ! relative humidity increment - ! ----------------------------------------------------------------------- - - rh_adj = 1. - h_var - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) ! rh_inr = 0.25 - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, :) = 0. - m2_sol (i, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! define air density based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! time - split warm rain processes: 1st pass - ! ----------------------------------------------------------------------- - - call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - m2_rain (i, k) = m2_rain (i, k) + m1_rain (k) - m1 (k) = m1 (k) + m1_rain (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! time - split warm rain processes: 2nd pass - ! ----------------------------------------------------------------------- - - call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - m2_rain (i, k) = m2_rain (i, k) + m1_rain (k) - m2_sol (i, k) = m2_sol (i, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var) - - enddo - - ! convert units from Pa*kg/kg to kg/m^2/s - m2_rain (i, :) = m2_rain (i, :) * rdt * rgrav - m2_sol (i, :) = m2_sol (i, :) * rdt * rgrav - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (do_qa) then - qa_dt (i, j, k) = 0. - else - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * (qaz (k) / real (ntimes) - qa0 (k)) - endif - enddo - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - ! do k = ktop, kbot - ! vt_r (i, j, k) = vtrz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_s (i, j, k) = vtsz (k) - ! enddo - ! endif - ! - ! if (id_vtg > 0) then - ! do k = ktop, kbot - ! vt_g (i, j, k) = vtgz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_i (i, j, k) = vtiz (k) - ! enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, & - den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - real, intent (in) :: rh_rain, h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg - real, intent (inout), dimension (ktop:kbot) :: m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc0, qc - real :: qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - if (no_fall) then - vtr (:) = vf_min - r1 = 0. - else - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (const_vr) then - vtr (:) = vr_fac ! ifs_2016: 4.0 - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - ! if (.not. fast_sat_adj) & - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vtr (k - 1) + vtr (k)) - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - endif - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qc0 = fac_rc * ccn (k) - if (tz (k) > t_wfr) then - if (use_ccn) then - ! ----------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! ----------------------------------------------------------------------- - qc = qc0 - else - qc = qc0 / den (k) - endif - dq = ql (k) - qc - if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid varaibility - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - qc0 = fac_rc * ccn (k) - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (1.e-6, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - if (use_ccn) then - ! -------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! -------------------------------------------------------------------- - qc = qc0 - else - qc = qc0 / den (k) - endif - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - endif - enddo - endif - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - real, intent (in) :: rh_rain, h_var - - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - - integer :: k - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qrmin) then - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the gird box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * evap, dqv / (1. + lcpk (k) * dqsdt)) - ! ----------------------------------------------------------------------- - ! alternative minimum evap in dry environmental air - ! sink = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqsdt)) - ! evap = max (evap, sink) - ! ----------------------------------------------------------------------- - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - ! if (qr (k) > qrmin .and. ql (k) > 1.e-7 .and. qsat < q_plus) then - if (qr (k) > qrmin .and. ql (k) > 1.e-6 .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (in) :: rh_adj, rh_rain, dts, h_var - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_g2v, fac_v2g, fac_i2s, fac_imlt - real :: tz, qv, ql, qr, qi, qs, qg, melt - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: dt5, factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - - integer :: k - - dt5 = 0.5 * dts - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - - fac_imlt = 1. - exp (- dt5 / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tzk (k) > tice .and. qik (k) > qcmin) then - - ! ----------------------------------------------------------------------- - ! pimlt: instant melting of cloud ice - ! ----------------------------------------------------------------------- - - melt = min (qik (k), fac_imlt * (tzk (k) - tice) / icpk (k)) - tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount - qlk (k) = qlk (k) + tmp - qrk (k) = qrk (k) + melt - tmp - qik (k) = qik (k) - melt - q_liq (k) = q_liq (k) + melt - q_sol (k) = q_sol (k) - melt - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - - elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then - - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - - dtmp = t_wfr - tzk (k) - factor = min (1., dtmp / dt_fr) - sink = min (qlk (k) * factor, dtmp / icpk (k)) - qi_crt = qi_gen * min (qi_lim, 0.1 * (tice - tzk (k))) / den (k) - tmp = min (sink, dim (qi_crt, qik (k))) - qlk (k) = qlk (k) - sink - qsk (k) = qsk (k) + sink - tmp - qik (k) = qik (k) + tmp - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + sink * lhi (k) / cvm (k) - - endif - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qcmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qrmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qrmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - ! sjl, 20170321: - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - ql = ql + tmp - qr = qr + sink - tmp - ! qr = qr + sink - ! sjl, 20170321: - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qcmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qrmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qrmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > 1.e-7) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! pasut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 - ! ----------------------------------------------------------------------- - - qim = qi0_crt / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qrmin) - q_plus = qi + di (k) - if (q_plus > (qim + qrmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - ! ----------------------------------------------------------------------- - ! sink is no greater than 75% of qi - ! ----------------------------------------------------------------------- - sink = min (0.75 * qi, psaci + psaut) - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > 1.e-6) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > 1.e-7 .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > 1.e-7) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > 1.e-7) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qrmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > 1.e-7 .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > 1.e-6) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > 1.e-6) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, h_var, rh_rain) - -end subroutine icloud - -! ======================================================================= -!>temperature sentive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, & - ql, qr, qi, qs, qg, qa, h_var, rh_rain) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, rh_adj, h_var, rh_rain - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_v2l, fac_l2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp - real :: q_plus, q_minus, dt_evap, dt_pisub - real :: evap, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g - - integer :: k - - if (fast_sat_adj) then - dt_evap = 0.5 * dts - else - dt_evap = dts - endif - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_v2l = 1. - exp (- dt_evap / tau_v2l) - fac_l2v = 1. - exp (- dt_evap / tau_l2v) - - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), 1.e-7) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (.not. do_qa) qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free - ! ----------------------------------------------------------------------- - - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - cycle ! cloud free - endif - endif - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: - ! ----------------------------------------------------------------------- - - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > 0.) then - ! SJL 20170703 added ql factor to prevent the situation of high ql and low RH - ! factor = min (1., fac_l2v * sqrt (max (0., ql (k)) / 1.e-5) * 10. * dq0 / qsw) - ! factor = fac_l2v - ! factor = 1 - factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90% - evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt)) - else ! condensate all excess vapor into cloud water - ! ----------------------------------------------------------------------- - ! evap = fac_v2l * dq0 / (1. + tcp3 (k) * dwsdt) - ! sjl, 20161108 - ! ----------------------------------------------------------------------- - evap = dq0 / (1. + tcp3 (k) * dwsdt) - endif - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing below - 48 c - ! ----------------------------------------------------------------------- - - dtmp = t_wfr - tz (k) ! [ - 40, - 48] - if (dtmp > 0. .and. ql (k) > qcmin) then - sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k)) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism - ! ----------------------------------------------------------------------- - - if (fast_sat_adj) then - dt_pisub = 0.5 * dts - else - dt_pisub = dts - tc = tice - tz (k) - if (ql (k) > qrmin .and. tc > 0.) then - sink = 3.3333e-10 * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = qv (k) - qsi - sink = dq / (1. + tcpk (k) * dqsdt) - if (qi (k) > qrmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dt_pisub * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - tmp = tice - tz (k) - ! 20160912: the following should produce more ice at higher altitude - ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k) - qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = max (pidep, sink, - qi (k)) - endif - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qrmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qrmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - -#ifdef USE_MIN_EVAP - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qcmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif -#endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - - if (do_qa) cycle - - if (rad_snow) then - q_sol (k) = qi (k) + qs (k) - else - q_sol (k) = qi (k) - endif - if (rad_rain) then - q_liq (k) = ql (k) + qr (k) - else - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! ----------------------------------------------------------------------- - ! mostly liquid water q_cond (k) at initial cloud development stage - ! ----------------------------------------------------------------------- - rqi = (tice - tin) / (tice - t_wfr) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - - if (qpz > qrmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (qstar < q_minus) then - qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = qa (k) + (q_plus - qstar) / (dq + dq) ! partial cloud cover - ! qa (k) = sqrt (qa (k) + (q_plus - qstar) / (dq + dq)) - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!> rain evaporation -! ======================================================================= - -subroutine revap_rac1 (hydrostatic, is, ie, dt, tz, qv, ql, qr, qi, qs, qg, den, hvar) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: is, ie - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (is:ie) :: den, hvar, qi, qs, qg - - real, intent (inout), dimension (is:ie) :: tz, qv, qr, ql - - real, dimension (is:ie) :: lcp2, denfac, q_liq, q_sol, cvm, lhl - - real :: dqv, qsat, dqsdt, evap, qden, q_plus, q_minus, sink - real :: tin, t2, qpz, dq, dqh - - integer :: i - - ! ----------------------------------------------------------------------- - ! define latend heat coefficient - ! ----------------------------------------------------------------------- - - do i = is, ie - lhl (i) = lv00 + d0_vap * tz (i) - q_liq (i) = ql (i) + qr (i) - q_sol (i) = qi (i) + qs (i) + qg (i) - cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice - lcp2 (i) = lhl (i) / cvm (i) - ! denfac (i) = sqrt (sfcrho / den (i)) - enddo - - do i = is, ie - if (qr (i) > qrmin .and. tz (i) > t_wfr) then - qpz = qv (i) + ql (i) - tin = tz (i) - lcp2 (i) * ql (i) ! presence of clouds suppresses the rain evap - qsat = wqs2 (tin, den (i), dqsdt) - dqh = max (ql (i), hvar (i) * max (qpz, qcmin)) - dqv = qsat - qv (i) - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (i) * den (i) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * exp (0.725 * log (qden))) & - / (crevp (4) * t2 + crevp (5) * qsat * den (i)) - evap = min (qr (i), dt * evap, dqv / (1. + lcp2 (i) * dqsdt)) - qr (i) = qr (i) - evap - qv (i) = qv (i) + evap - q_liq (i) = q_liq (i) - evap - cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice - tz (i) = tz (i) - evap * lhl (i) / cvm (i) - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (i) > qrmin .and. ql (i) > 1.e-8 .and. qsat < q_plus) then - denfac (i) = sqrt (sfcrho / den (i)) - sink = dt * denfac (i) * cracw * exp (0.95 * log (qr (i) * den (i))) - sink = sink / (1. + sink) * ql (i) - ql (i) = ql (i) - sink - qr (i) = qr (i) + sink - endif - endif - enddo - -end subroutine revap_rac1 - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, dt5, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - dt5 = 0.5 * dtm - fac_imlt = 1. - exp (- dt5 / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 60.) k0 = kbot - - ! sjl, turn off melting of falling cloud ice, snow and graupel - k0 = kbot - ! sjl, turn off melting of falling cloud ice, snow and graupel - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_fac < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vti (k - 1) + vti (k)) - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vts (k - 1) + vts (k)) - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qrmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vtg (k - 1) + vtg (k)) - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qrmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qrmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - q (k) = q (k) * dp (k) - a4 (1, k) = q (k) / dz (k) - qm (k) = 0. - enddo - - ! ----------------------------------------------------------------------- - ! construct vertical profile with zt as coordinate - ! ----------------------------------------------------------------------- - - call cs_profile (a4 (1, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! convert back to * dry * mixing ratio: - ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - grat = del (2) / del (1) ! grid ratio - bet = grat * (grat + 0.5) - q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet - gam (1) = (1. + grat * (grat + 1.5)) / bet - - do k = 2, km - d4 = del (k - 1) / del (k) - bet = 2. + 2. * d4 - gam (k - 1) - q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet - gam (k) = d4 / bet - enddo - - a_bot = 1. + d4 * (d4 + 1.5) - q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & - / (d4 * (d4 + 0.5) - a_bot * gam (km)) - - do k = km, 1, - 1 - q (k) = q (k) - gam (k) * q (k + 1) - enddo - - ! ----------------------------------------------------------------------- - ! apply constraints - ! ----------------------------------------------------------------------- - - do k = 2, km - gam (k) = a4 (1, k) - a4 (1, k - 1) - enddo - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! top: - ! ----------------------------------------------------------------------- - - q (1) = max (q (1), 0.) - q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) - q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) - - ! ----------------------------------------------------------------------- - ! interior: - ! ----------------------------------------------------------------------- - - do k = 3, km - 1 - if (gam (k - 1) * gam (k + 1) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - endif - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom : - ! ----------------------------------------------------------------------- - - q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) - q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) - ! q (km + 1) = max (q (km + 1), 0.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - do k = 1, km - 1 - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - enddo - - k = km - 1 - if (extm (k)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aa = - 4.14122e-5 - real, parameter :: bb = - 0.00538922 - real, parameter :: cc = - 0.0516344 - real, parameter :: dd = 0.00216078 - real, parameter :: ee = 1.9714 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: qden, tc, rhof - - real :: vi0 - - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = vi_fac - else - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl), which gives smaller fall speed than hd90 formula - ! ----------------------------------------------------------------------- - vi0 = 0.01 * vi_fac - do k = ktop, kbot - if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi - vti (k) = vf_min - else - tc (k) = tk (k) - tice - vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee - vti (k) = vi0 * exp (log_10 * vti (k)) * 0.9 - vti (k) = min (vi_max, max (vf_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = vs_fac ! 1. ifs_2016 - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vf_min - else - vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vf_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = vg_fac ! 2. - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vf_min - else - vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vf_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: gcon, cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - -! real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) -! real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - real den_rc - - integer :: i, k - - pie = 4. * atan (1.0) - - ! s. klein's formular (eq 16) from am2 - - fac_rc = (4. / 3.) * pie * rhor * rthresh ** 3 - - if (prog_ccn) then - ! if (master) write (*, *) 'prog_ccn option is .t.' - else - den_rc = fac_rc * ccn_o * 1.e6 - ! if (master) write (*, *) 'mp: for ccn_o = ', ccn_o, 'ql_rc = ', den_rc - den_rc = fac_rc * ccn_l * 1.e6 - ! if (master) write (*, *) 'mp: for ccn_l = ', ccn_l, 'ql_rc = ', den_rc - endif - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; - ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (6) = pie * rnzg * rhog - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - gcon = 40.74 * sqrt (sfcrho) ! 44.628 - - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - ! decreasing csacw to reduce cloud water --- > snow - - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - csaci = csacw * c_psaci - - cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) - ! cgaci = cgacw * 0.1 - - ! sjl, may 28, 2012 - cgaci = cgacw * 0.05 - ! sjl, may 28, 2012 - - cracw = craci ! cracw = 3.27206196043822 - cracw = c_cracw * cracw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cssub (5) = hlts ** 2 * vdifu - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, logunit, fn_nml) - - implicit none - - integer, intent (in) :: me - integer, intent (in) :: master - integer, intent (in) :: nlunit - integer, intent (in) :: logunit - - character (len = 64), intent (in) :: fn_nml - character (len = *), intent (in) :: input_nml_file(:) - - integer :: ios - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - ! master = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: 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 = gfdl_cloud_microphysics_nml) - close (nlunit) -#endif - - ! write version number and namelist to log file - if (me == master) then - write (logunit, *) " ================================================================== " - write (logunit, *) "gfdl_cloud_microphys_mod" - write (logunit, nml = gfdl_cloud_microphysics_nml) - endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - log_10 = log (10.) - - tice0 = tice - 0.01 - t_wfr = tice - 40.0 ! supercooled water can exist down to - 48 c, which is the "absolute" - - ! if (master) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (master) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. master) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (master) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - module_is_initialized = .true. - -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - - xam_r = pi*rhor/6. - xbm_r = 3. - xmu_r = 0. - xam_s = pi*rhos/6. - xbm_s = 3. - xmu_s = 0. - xam_g = pi*rhog/6. - xbm_g = 3. - xmu_g = 0. - - call radar_init - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! master = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer, parameter :: length = 2621 - - integer :: i - - if (.not. tables_are_initialized) then - - ! master = (mpp_pe () .eq. mpp_root_pe ()) - ! if (master) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (length)) - allocate (table2 (length)) - allocate (table3 (length)) - allocate (tablew (length)) - allocate (des (length)) - allocate (des2 (length)) - allocate (des3 (length)) - allocate (desw (length)) - - call qs_table (length) - call qs_table2 (length) - call qs_table3 (length) - call qs_tablew (length) - - do i = 1, length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (length) = des (length - 1) - des2 (length) = des2 (length - 1) - des3 (length) = des3 (length - 1) - desw (length) = desw (length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, fac0, fac1, fac2 - - integer :: i - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - tmin = table_ice - 160. - - do i = 1, n - tem0 = tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - tmin = table_ice - 160. - - do i = 1, n - tem = tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (t, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, esh20 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (200) - - integer :: i - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1600 - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 20 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1221 - tem = 253.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh20 = e00 * exp (fac2) - if (i <= 200) then - esupc (i) = esh20 - else - table (i + 1400) = esh20 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 200 - tem = 253.16 + delt * real (i - 1) - wice = 0.05 * (table_ice - tem) - wh2o = 0.05 * (tem - 253.16) - table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10, ap1, tmin - - real, dimension (im, km) :: es - - integer :: i, k, it - - tmin = table_ice - 160. - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -!>author Linjiong Zhoum, Shian-Jiann Lin -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, ks, ke, den, delp, lsm, qmw, qmi, qmr, qms, qmg, t, & - rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, ks, ke - integer, intent (in), dimension (is:ie) :: lsm ! land sea mask, 0: ocean, 1: land, 2: sea ice - - real, intent (in), dimension (is:ie, ks:ke) :: den, delp, t - real, intent (in), dimension (is:ie, ks:ke) :: qmw, qmi, qmr, qms, qmg !< units: kg / kg - - real, intent (out), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg !< units: micron - - real, dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg !< units: g / m^2 - - integer :: i, k - - real :: lambdar, lambdas, lambdag - real :: dpg, rei_fac, mask, ccn, bw - real, parameter :: rho_0 = 50.e-3 - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-12, beta = 1.22, qmin1 = 9.e-6 - - do k = ks, ke - do i = is, ie - - dpg = abs (delp (i, k)) / grav - mask = min (max (real(lsm (i)), 0.0), 2.0) - - ! ----------------------------------------------------------------------- - ! cloud water (Martin et al., 1994) - ! ----------------------------------------------------------------------- - - ccn = 0.80 * (- 1.15e-3 * (ccn_o ** 2) + 0.963 * ccn_o + 5.30) * abs (mask - 1.0) + & - 0.67 * (- 2.10e-4 * (ccn_l ** 2) + 0.568 * ccn_l - 27.9) * (1.0 - abs (mask - 1.0)) - - if (qmw (i, k) .gt. qmin) then - qcw (i, k) = dpg * qmw (i, k) * 1.0e3 - rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * den (i, k) * qmw (i, k)) / (4.0 * pi * rhow * ccn))) * 1.0e4 - rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) - else - qcw (i, k) = 0.0 - rew (i, k) = rewmin - endif - - if (reiflag .eq. 1) then - - ! ----------------------------------------------------------------------- - ! cloud ice (Heymsfield and Mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qmi (i, k) .gt. qmin1) then - qci (i, k) = dpg * qmi (i, k) * 1.0e3 - rei_fac = log (1.0e3 * qmi (i, k) * den (i, k)) - if (t (i, k) - tice .lt. - 50) then - rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 - elseif (t (i, k) - tice .lt. - 40) then - rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 - elseif (t (i, k) - tice .lt. - 30) then - rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 - else - rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 - endif - rei (i, k) = max (reimin, min (reimax, rei (i, k))) - else - qci (i, k) = 0.0 - rei (i, k) = reimin - endif - - endif - - if (reiflag .eq. 2) then - - ! ----------------------------------------------------------------------- - ! cloud ice (Wyser, 1998) - ! ----------------------------------------------------------------------- - - if (qmi (i, k) .gt. qmin1) then - qci (i, k) = dpg * qmi (i, k) * 1.0e3 - bw = - 2. + 1.e-3 * log10 (den (i, k) * qmi (i, k) / rho_0) * max (0.0, tice - t (i, k)) ** 1.5 - rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) - rei (i, k) = max (reimin, min (reimax, rei (i, k))) - else - qci (i, k) = 0.0 - rei (i, k) = reimin - endif - - endif - - ! ----------------------------------------------------------------------- - ! rain (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qmr (i, k) .gt. qmin) then - qcr (i, k) = dpg * qmr (i, k) * 1.0e3 - lambdar = exp (0.25 * log (pi * rhor * n0r / qmr (i, k) / den (i, k))) - rer (i, k) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, k) = max (rermin, min (rermax, rer (i, k))) - else - qcr (i, k) = 0.0 - rer (i, k) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qms (i, k) .gt. qmin1) then - qcs (i, k) = dpg * qms (i, k) * 1.0e3 - lambdas = exp (0.25 * log (pi * rhos * n0s / qms (i, k) / den (i, k))) - res (i, k) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, k) = max (resmin, min (resmax, res (i, k))) - else - qcs (i, k) = 0.0 - res (i, k) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qmg (i, k) .gt. qmin) then - qcg (i, k) = dpg * qmg (i, k) * 1.0e3 - lambdag = exp (0.25 * log (pi * rhog * n0g / qmg (i, k) / den (i, k))) - reg (i, k) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, k) = max (regmin, min (regmax, reg (i, k))) - else - qcg (i, k) = 0.0 - reg (i, k) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_gfdl (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii,jj, melti) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii,jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg -! REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti - DOUBLE PRECISION:: cback, x, eta, f_d -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) -! temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(rdgas*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = n0s - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - k_0 = kts - K_LOOP:do k = kte-1, kts, -1 - if ( melti .and. (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - EXIT K_LOOP - endif - enddo K_LOOP -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo - - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_gfdl -!+---+-----------------------------------------------------------------+ - -end module gfdl_cloud_microphys_mod diff --git a/gfsphysics/physics/gfs_phy_tracer_config.F b/gfsphysics/physics/gfs_phy_tracer_config.F deleted file mode 100644 index 8ed7443d3..000000000 --- a/gfsphysics/physics/gfs_phy_tracer_config.F +++ /dev/null @@ -1,240 +0,0 @@ -#undef MULTI_GASES - -! -!! ! 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' -#ifdef MULTI_GASES - print *,' ++++ nto nto2 ',nto,nto2 - if(nto > 0) gfs_phy_tracer%vname(nto) = 'spfo' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'spfo2' -#else - if(nto > 0) gfs_phy_tracer%vname(nto) = 'o' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'o2' -#endif - - - 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/gfsphysics/physics/gocart_tracer_config_stub.f b/gfsphysics/physics/gocart_tracer_config_stub.f deleted file mode 100644 index d6df297c7..000000000 --- a/gfsphysics/physics/gocart_tracer_config_stub.f +++ /dev/null @@ -1,17 +0,0 @@ -! -!! ! 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/gfsphysics/physics/gscond.f b/gfsphysics/physics/gscond.f deleted file mode 100644 index b16b0d8d5..000000000 --- a/gfsphysics/physics/gscond.f +++ /dev/null @@ -1,521 +0,0 @@ -!> \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 Zhao-Carr Zhao-Carr-Sundqvist Microphysics -!! @{ -!! \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 -!! - CRTRH: Critical relative humidity for cloud generation -!! -!! \section intramps Intraphysics Communication -!! - Routine GSCOND is called from GFS_physics_driver after call to shallow convection scheme -!! - Routine PRECPD is called from GFS_physics_driver 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/gfsphysics/physics/gscondp.f b/gfsphysics/physics/gscondp.f deleted file mode 100644 index 2cab7dee4..000000000 --- a/gfsphysics/physics/gscondp.f +++ /dev/null @@ -1,358 +0,0 @@ - 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/gfsphysics/physics/gwdc.f b/gfsphysics/physics/gwdc.f deleted file mode 100644 index 3ea8705b1..000000000 --- a/gfsphysics/physics/gwdc.f +++ /dev/null @@ -1,1366 +0,0 @@ -!> \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 GFS_gwd -!> \defgroup GFS_cgwd GFS 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). -!! -!! - 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. -!! -!> 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 arg_table_gwdc_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 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/gfsphysics/physics/gwdps.f b/gfsphysics/physics/gwdps.f deleted file mode 100644 index 433c9101e..000000000 --- a/gfsphysics/physics/gwdps.f +++ /dev/null @@ -1,1432 +0,0 @@ -!> \file gwdps.f -!! This file is the parameterization of orographic gravity wave -!! drag and mountain blocking. - -!> \defgroup GFS_gwd GFS Orographic 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. -!! -!!\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 GFS_gwd -!> \defgroup GFS_ogwd GFS 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. -!! -!! The NWP model gravity wave drag (GWD) scheme in the GFS has two -!! main components: how the surface stress is computed, and then how -!! that stress is distributed over a vertical column where it may -!! interact with the models momentum. Each of these depends on the -!! large scale environmental atmospheric state and assumptions about -!! the sub-grid scale processes. In Alpert GWD (1987) based on linear, -!! two-dimensional non-rotating, stably stratified flow over a mountain ridge, -!! sub-grid scale gravity wave motions are assumed which propagate away -!! from the mountain. Described in Alpert (1987), the flux measured over -!! a "low level" vertically averaged layer, in the atmosphere defines a base -!! level flux. "Low level" was taken to be the first 1/3 of the troposphere -!! in the 1987 implementation. This choice was meant to encompass a thick -!! low layer for vertical averages of the environmental (large scale) flow -!! quantities. The vertical momentum flux or gravity wave stress in a -!! grid box due to a single mountain is given as in Pierrehumbert, (1987) (PH): -!! -!! \f$ \tau = \frac {\rho \: U^{3}\: G(F_{r})} {\Delta X \; N } \f$ -!! -!! emetic \f$ \Delta X \f$ is a grid increment, N is the Brunt Viasala frequency -!! -!! -!! \f$ N(\sigma) = \frac{-g \: \sigma \: -!! \frac{\partial\Theta}{\partial\sigma}}{\Theta \:R \:T} \f$ -!! -!! The environmental variables are calculated from a mass weighted vertical -!! average over a base layer. G(Fr) is a monotonically increasing -!! function of Froude number, -!! -!! \f$ F_{r} = \frac{N h^{'}}{U} \f$ -!! -!! where U is the wind speed calculated as a mass weighted vertical average in -!! the base layer, and h', is the vertical displacement caused by the orography -!! variance. An effective mountain length for the gravity wave processes, -!! -!! \f$ l^{*} = \frac{\Delta X}{m} \f$ -!! -!! where m is the number of mountains in a grid box, can then -!! be defined to obtain the form of the base level stress -!! -!! -!! \f$ \tau = \frac {\rho \: U^{3} \: G(F_{r})} {N \;l^{*}} \f$ -!! -!! giving the stress induced from the surface in a model grid box. -!! PH gives the form for the function G(Fr) as -!! -!! -!! \f$ G(F_{r}) = \bar{G}\frac{F^{2}_{r}}{F^{2}_{r}\: + \:a^{2}} \f$ -!! -!! Where \f$ \bar{G} \f$ is an order unity non-dimensional saturation -!! flux set to 1 and 'a' is a function of the mountain aspect ratio also -!!set to 1 in the 1987 implementation of the GFS GWD. Typical values of -!! U=10m/s, N=0.01 1/s, l*=100km, and a=1, gives a flux of 1 Pascal and -!! if this flux is made to go to zero linearly with height then the -!! decelerations would be about 10/m/s/day which is consistent with -!! observations in PH. -!! -!! -!! In Kim, Moorthi, Alpert's (1998, 2001) GWD currently in GFS operations, -!! the GWD scheme has the same physical basis as in Alpert (1987) with the addition -!! of enhancement factors for the amplitude, G, and mountain shape details -!! in G(Fr) to account for effects from the mountain blocking. A factor, -!! E m’, is an enhancement factor on the stress in the Alpert '87 scheme. -!! The E ranges from no enhancement to an upper limit of 3, E=E(OA)[1-3], -!! and is a function of OA, the Orographic Asymmetry defined in KA (1995) as -!! -!! Orographic Asymmetry (OA) = \f$ \frac{ \bar{x} \; - \; -!! \sum\limits_{j=1}^{N_{b}} x_{j} \; n_{j} }{\sigma_{x}} \f$ -!! -!! where Nb is the total number of bottom blocks in the mountain barrier, -!! \f$ \sigma_{x} \f$ is the standard deviation of the horizontal distance defined by -!! -!! \f$ \sigma_{x} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{b}} -!! \; (x_{j} \; - \; \bar{x} )^2}{N_{x}} } \f$ -!! -!! -!! where Nx is the number of grid intervals for the large scale domain being -!! considered. So the term, E(OA)m’/ \f$ \Delta X \f$ in Kim's scheme represents -!! a multiplier on G shown in Alpert's eq (1), where m’ is the number of mountains -!! in a sub-grid scale box. Kim increased the complexity of m’ making it a -!! function of the fractional area of the sub-grid mountain and the asymmetry -!! and convexity statistics which are found from running a gravity wave -!! model for a large number of cases: -!! -!! \f$ m^{'} = C_{m} \Delta X \left[ \frac{1 \; + \; -!! \sum\limits_{x} L_{h} }{\Delta X} \right]^{OA+1} \f$ -!! -!! Where, according to Kim, \f$ \sum \frac{L_{h}}{\Delta X} \f$ is -!! the fractional area covered by the subgrid-scale orography higher than -!! a critical height \f$ h_{c} = Fr_{c} U_{0}/N_{0} \f$ , over the -!! "low level" vertically averaged layer, for a grid box with the interval -!! \f$ \Delta X \f$. Each \f$ L_{n}\f$ is the width of a segment of -!! orography intersection at the critical height: -!! -!! \f$ Fr_{0} = \frac{N_{0} \; h^{'}}{U_{0}} \f$ -!! -!! \f$ G^{'}(OC,Fr_{0}) = \frac{Fr_{0}^{2}}{Fr_{0}^{2} \; + \; a^{2}} \f$ -!! -!! \f$ a^{2} = \frac{C_{G}}{OC} \f$ -!! -!! \f$ E(OA, Fr_{0}) = (OA \; + \; 2)^{\delta} \f$ and \f$ \delta -!! \; = \; \frac{C_{E} \; Fr_{0}}{Fr_{c}} \f$ where \f$ Fr_{c} \f$ -!! is as in Alpert. -!! -!! -!! This represents a closed scheme, somewhat empirical adjustments -!! to the original scheme to calculate the surface stress. -!! -!! Momentum is deposited by the sub-grid scale gravity waves break due -!! to the presence of convective mixing assumed to occur when the -!! minimum Richardson number: -!! -!! Orographic Convexity (OC) = \f$ \frac{ \sum\limits_{j=1}^{N_{x}} -!! \; (h_{j} \; - \; \bar{h})^4 }{N_{x} \;\sigma_{h}^4} \f$ , -!! and where \f$ \sigma_{h} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{x}} -!! \; (h_{j} \; - \; \bar{h} )^2}{N_{x}} } \f$ -!! -!! This represents a closed scheme, somewhat empirical adjustments -!! to the original scheme to calculate the surface stress. -!! -!! Momentum is deposited by the sub-grid scale gravity waves break due -!! to the presence of convective mixing assumed to occur when -!! the minimum Richardson number: -!! -!! \f$ Ri_{m} = \frac{Ri(1 \; - \; Fr)}{(1 \; + \; \sqrt{Ri}Fr)^2} \f$ -!! -!! Is less than 1/4 Or if critical layers are encountered in a layer -!! the the momentum flux will vanish. The critical layer is defined -!! when the base layer wind becomes perpendicular to the environmental -!! wind. Otherwise, wave breaking occurs at a level where the amplification -!! of the wave causes the local Froude number or similarly a truncated -!! (first term of the) Scorer parameter, to be reduced below a critical -!! value by the saturation hypothesis (Lindzen,). This is done through -!! eq 1 which can be written as -!! -!! \f$ \tau = \rho U N k h^{'2} \f$ -!! -!! For small Froude number this is discretized in the vertical so at each -!! level the stress is reduced by ratio of the Froude or truncated Scorer -!! parameter, \f$ \frac{U^{2}}{N^{2}} = \frac{N \tau_{l-1}}{\rho U^{3} k} \f$ , -!! where the stress is from the layer below beginning with that found near -!! the surface. The respective change in momentum is applied in -!! that layer building up from below. -!! -!! An amplitude factor is part of the calibration of this scheme which is -!! a function of the model resolution and the vertical diffusion. This -!! is because the vertical diffusion and the GWD account encompass -!! similar physical processes. Thus, one needs to run the model over -!! and over for various amplitude factors for GWD and vertical diffusion. -!! -!! In addition, there is also mountain blocking from lift and frictional -!! forces. Improved integration between how the GWD is calculated and -!! the mountain blocking of wind flow around sub-grid scale orography -!! is underway at NCEP. The GFS already has convectively forced GWD -!! an independent process. The next step is to test -!! -!! -!! @{ -!> -!! \section arg_table_gwdps_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 | -!! -!> \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, 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) - 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, Rtrm, PHIANG, CDmb, DBIM, ZR - 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) -! - 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) -! &, 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 iwklm(im) -! 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, onebg & - &, scork, rscor, hd, fro, rim, sira & - &, dtaux, dtauy, pkp1log, pklog & - &, cosang, sinang, cos2a, sin2a -! - 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 - onebg = 1.0 / g - 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 == 14) then -! ---- for lm and gwd calculation points - RDXZB(:) = 0 - ipt = 0 - npt = 0 - DO I = 1,IM - IF (elvmax(i) > HMINMT .and. hprime(i) > hpmin) then - npt = npt + 1 - ipt(npt) = i - if (ipr == i) npr = npt - ENDIF - ENDDO - IF (npt == 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) * onebg - pklog = phil(j,k) * onebg -!!!------- ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) - - if (ELVMAX(j) <= pkp1log .and. ELVMAX(j) >= 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.0+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 - kp1 = k + 1 - DO I = 1, npt - j = ipt(i) - RDZ = g / (phil(j,kp1) - phil(j,k)) -! --- Brunt-Vaisala Frequency -!> - Compute Brunt-Vaisala Frequency \f$N\f$. - BNV2LM(I,K) = (G+G) * RDZ * (VTK(I,Kp1) - VTK(I,K)) - & / (VTK(I,Kp1) + 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 / (PRSI(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) = (PRSI(J,1)-PRSL(J,1)) * DELKS(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 < iwklm(I) .and. kreflm(I) == 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, iwklm(i)-1 - 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 - if (k < iwklm(I)-1) then - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) - else - RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) - endif - 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) > 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) < -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) == 0 ) then - PE(I) = PE(I) + BNV2lm(I,K) * (G*ELVMAX(J) - phil(J,K)) - & * (PHII(J,K+1) - PHII(J,K)) - & * (onebg*onebg) -! --- 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) >= 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) > 0) then - DO K = IDXZB(I), 1, -1 - IF (PHIL(J,IDXZB(I)) > 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). - - cosang = cos(ang(i,k)) - sinang = sin(ang(i,k)) - cos2a = cosang * cosang - sin2a = sinang * sinang - tem = cos2a + GAMMA(J)*sin2a - ! Here Rtrm is 1.0/R - ! -------------------- - if (abs(tem) > 1.e-06) then - Rtrm = (gamma(J)*cos2a + sin2a) / tem - elseif (tem > 0.0) then - Rtrm = (gamma(J)*cos2a + sin2a) * 1.0e6 - else - Rtrm = - (gamma(J)*cos2a + sin2a) * 1.0e6 - endif - ZR = MAX( 2.0 - Rtrm, 0. ) - -! --- (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 * ZR * sigma(J) * - & MAX(cosANG, gamma(J)*sinANG) * ZLEN / hprime(J) - DB(I,K) = DBTMP * UDS(I,K) -! -! 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 /= 14) then -! ---- for mb not present and gwd (nmtvr .ne .14) - ipt = 0 - npt = 0 - DO I = 1,IM - IF ( hprime(i) > hpmin ) then - npt = npt + 1 - ipt(npt) = i - if (ipr == i) npr = npt - ENDIF - ENDDO - IF (npt == 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 > 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.0+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 - kp1 = k + 1 - DO I =1,npt - J = ipt(i) - TI = 2.0 / (T1(J,K)+T1(J,Kp1)) - TEM = TI / (PRSL(J,K)-PRSL(J,Kp1)) - RDZ = g / (phil(j,kp1) - phil(j,k)) - TEM1 = U1(J,K) - U1(J,Kp1) - TEM2 = V1(J,K) - V1(J,Kp1) - DW2 = TEM1*TEM1 + TEM2*TEM2 - SHR2 = MAX(DW2,DW2MIN) * RDZ * RDZ - BVF2 = G*(GOCP+RDZ*(VTJ(I,Kp1)-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,Kp1)-VTK(I,K)) - & / (VTK(I,Kp1)+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 < 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 / (PRSI(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) = (PRSI(J,1)-PRSL(J,1)) * DELKS(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 < 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 - if (k < kref(i)-1) then - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) - else - RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) - endif - 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 - kp1 = k + 1 - DO I = 1,npt - J = ipt(i) - VELCO(I,K) = 0.5 * ((U1(J,K)+U1(J,Kp1))*UBAR(I) - & + (V1(J,K)+V1(J,Kp1))*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 <= 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 >= kref(I)) THEN - ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) < RIC) - & .OR. (VELCO(I,K) <= 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 >= kref(I)) THEN - IF (.NOT.ICRILV(I) .AND. TAUP(I,K) > 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) > 0. .AND. kp1 < 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}= kint(i) )) THEN - TEMC = 2.0 + 1.0 / TEM2 - HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF - TAUP(I,KP1) = TEM1 * HD * HD - ELSE - TAUP(I,KP1) = TAUP(I,K) * RSCOR - ENDIF - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - ENDIF - ENDIF - ENDDO - ENDDO -! -! DO I=1,IM -! taup(i,km+1) = taup(i,km) -! ENDDO -! - IF(LCAP .LE. KM) THEN - DO KLCAP = LCAPP1, KM+1 - DO I = 1,npt - SIRA = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP) - TAUP(I,KLCAP) = SIRA * TAUP(I,LCAP) - ENDDO - ENDDO - ENDIF -! -! 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' -! - DO KLCAP = LCAP, KM - DO I = 1,npt - TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP - ENDDO - ENDDO -! -!------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 > kref(I) .and. PRSI(ipt(i),K) >= RLOLEV) THEN - IF(TAUD(I,K) /= 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 < IDXZB(I) .AND. IDXZB(I) /= 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 - - DO I = 1,npt - J = ipt(i) -! TEM = (-1.E3/G) - DUSFC(J) = - onebg * DUSFC(J) - DVSFC(J) = - onebg * 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/gfsphysics/physics/h2o_def.f b/gfsphysics/physics/h2o_def.f deleted file mode 100644 index 310a3c796..000000000 --- a/gfsphysics/physics/h2o_def.f +++ /dev/null @@ -1,12 +0,0 @@ - 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/gfsphysics/physics/h2oc.f b/gfsphysics/physics/h2oc.f deleted file mode 100644 index 5fb507431..000000000 --- a/gfsphysics/physics/h2oc.f +++ /dev/null @@ -1,894 +0,0 @@ -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/gfsphysics/physics/h2ohdc.f b/gfsphysics/physics/h2ohdc.f deleted file mode 100644 index 92339afe9..000000000 --- a/gfsphysics/physics/h2ohdc.f +++ /dev/null @@ -1,165 +0,0 @@ - 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/gfsphysics/physics/h2ointerp.f90 b/gfsphysics/physics/h2ointerp.f90 deleted file mode 100644 index b017e72e7..000000000 --- a/gfsphysics/physics/h2ointerp.f90 +++ /dev/null @@ -1,187 +0,0 @@ - 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='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/gfsphysics/physics/h2ophys.f b/gfsphysics/physics/h2ophys.f deleted file mode 100644 index 144c1c385..000000000 --- a/gfsphysics/physics/h2ophys.f +++ /dev/null @@ -1,100 +0,0 @@ - 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=10000.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/gfsphysics/physics/iccn_def.f b/gfsphysics/physics/iccn_def.f deleted file mode 100644 index 5e0bbe50d..000000000 --- a/gfsphysics/physics/iccn_def.f +++ /dev/null @@ -1,15 +0,0 @@ - module iccn_def - use machine , only : kind_phys - implicit none - - integer, parameter :: kcipl=32, latscip=192, lonscip=288 - & , timeci=12 - - real (kind=kind_phys):: ci_lat(latscip), ci_lon(lonscip) - & , ci_time(timeci+1) - real (kind=4), allocatable, dimension(:,:,:,:):: ciplin, ccnin - real (kind=kind_phys), allocatable, dimension(:,:,:,:):: ci_pres - data ci_time/15.5,45.,74.5,105.,135.5,166.,196.5, - & 227.5,258.,288.5,319.,349.5,380.5/ - - end module iccn_def diff --git a/gfsphysics/physics/iccninterp.f90 b/gfsphysics/physics/iccninterp.f90 deleted file mode 100644 index d1254692c..000000000 --- a/gfsphysics/physics/iccninterp.f90 +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE read_cidata (me, master) - use machine, only: kind_phys - use iccn_def - use netcdf -!--- in/out - integer, intent(in) :: me - integer, intent(in) :: master -!--- locals - integer :: i, n, k, ncid, varid,j,it - real(kind=kind_phys), allocatable, dimension(:) :: hyam,hybm - real(kind=4), allocatable, dimension(:,:,:) :: ci_ps - - allocate (hyam(kcipl), hybm(kcipl), ci_ps(lonscip,latscip,timeci)) - allocate (ciplin(lonscip,latscip,kcipl,timeci)) - allocate (ccnin(lonscip,latscip,kcipl,timeci)) - allocate (ci_pres(lonscip,latscip,kcipl,timeci)) - call nf_open("cam5_4_143_NAAI_monclimo2.nc", nf_NOWRITE, ncid) - call nf_inq_varid(ncid, "lat", varid) - call nf_get_var(ncid, varid, ci_lat) - call nf_inq_varid(ncid, "lon", varid) - call nf_get_var(ncid, varid, ci_lon) - call nf_inq_varid(ncid, "PS", varid) - call nf_get_var(ncid, varid, ci_ps) - call nf_inq_varid(ncid, "hyam", varid) - call nf_get_var(ncid, varid, hyam) - call nf_inq_varid(ncid, "hybm", varid) - call nf_get_var(ncid, varid, hybm) - call nf_inq_varid(ncid, "NAAI", varid) - call nf_get_var(ncid, varid, ciplin) - do it = 1,timeci - do k=1, kcipl - ci_pres(:,:,k,it)=hyam(k)*1.e5+hybm(k)*ci_ps(:,:,it) - end do - end do - call nf_close(ncid) - call nf_open("cam5_4_143_NPCCN_monclimo2.nc", nf_NOWRITE, ncid) - call nf_inq_varid(ncid, "NPCCN", varid) - call nf_get_var(ncid, varid, ccnin) - call nf_close(ncid) -!--- - deallocate (hyam, hybm, ci_ps) - if (me == master) then - write(*,*) 'Reading in ICCN data',ci_time - endif - - END SUBROUTINE read_cidata -! -!********************************************************************** -! - SUBROUTINE setindxci(npts,dlat,jindx1,jindx2,ddy,dlon, & - iindx1,iindx2,ddx) -! - USE MACHINE, ONLY: kind_phys - USE iccn_def, ONLY: jci => latscip, ci_lat,ici=>lonscip, ci_lon -! - implicit none -! - integer npts, JINDX1(npts),JINDX2(npts),iINDX1(npts),iINDX2(npts) - real(kind=kind_phys) dlat(npts),DDY(npts),dlon(npts),DDX(npts) -! - integer i,j -! - DO J=1,npts - jindx2(j) = jci + 1 - do i=1,jci - if (dlat(j) < ci_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),jci) - if (jindx2(j) .ne. jindx1(j)) then - DDY(j) = (dlat(j) - ci_lat(jindx1(j))) & - / (ci_lat(jindx2(j)) - ci_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif - !print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & - ! jindx2(j),' ci_lat=',ci_lat(jindx1(j)), & - ! ci_lat(jindx2(j)),' ddy=',ddy(j) - ENDDO - - DO J=1,npts - iindx2(j) = ici + 1 - do i=1,ici - if (dlon(j) < ci_lon(i)) then - iindx2(j) = i - exit - endif - enddo - iindx1(j) = max(iindx2(j)-1,1) - iindx2(j) = min(iindx2(j),ici) - if (iindx2(j) .ne. iindx1(j)) then - ddx(j) = (dlon(j) - ci_lon(iindx1(j))) & - / (ci_lon(iindx2(j)) - ci_lon(iindx1(j))) - else - ddx(j) = 1.0 - endif - !print *,' j=',j,' dlon=',dlon(j),' iindx12=',iindx1(j), & - ! iindx2(j),' ci_lon=',ci_lon(iindx1(j)), & - ! ci_lon(iindx2(j)),' ddx=',ddx(j) - ENDDO - - RETURN - END -! -!********************************************************************** -!********************************************************************** -! - SUBROUTINE ciinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ddy, & - iindx1,iindx2,ddx,lev, prsl, ciplout,ccnout) -! - USE MACHINE, ONLY : kind_phys - use iccn_def - implicit none - integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i - real(kind=kind_phys) fhour,temj, tx1, tx2,temi -! - - integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) - integer me,idate(4) - integer IDAT(8),JDAT(8) -! - real(kind=kind_phys) DDY(npts), ddx(npts),ttt - real(kind=kind_phys) ciplout(npts,lev),cipm(npts,kcipl) - real(kind=kind_phys) ccnout(npts,lev),ccnpm(npts,kcipl) - real(kind=kind_phys) cipres(npts,kcipl), prsl(npts,lev) - 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. ci_time(1)) RJDAY = RJDAY+365. -! - n2 = timeci + 1 - do j=2,timeci - if (rjday .lt. ci_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - -! -! - tx1 = (ci_time(n2) - rjday) / (ci_time(n2) - ci_time(n1)) - if (n2 > timeci) n2 = n2 - timeci -! if (me .eq. 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday & -! ,'ci_time=',ci_time(n1),ci_time(n2), ci_time(timeci+1),tx1 - tx2 = 1.0 - tx1 -! - DO L=1,kcipl - DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) - I1 = IINDX1(J) - I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) - cipm(j,L) = & - tx1*(TEMI*TEMJ*ciplin(I1,J1,L,n1)+DDX(j)*DDY(J)*ciplin(I2,J2,L,n1) & - +TEMI*DDY(j)*ciplin(I1,J2,L,n1)+DDX(j)*TEMJ*ciplin(I2,J1,L,n1)) & - + tx2*(TEMI*TEMJ*ciplin(I1,J1,L,n2)+DDX(j)*DDY(J)*ciplin(I2,J2,L,n2) & - +TEMI*DDY(j)*ciplin(I1,J2,L,n2)+DDX(j)*TEMJ*ciplin(I2,J1,L,n2)) - - ccnpm(j,L) = & - tx1*(TEMI*TEMJ*ccnin(I1,J1,L,n1)+DDX(j)*DDY(J)*ccnin(I2,J2,L,n1) & - +TEMI*DDY(j)*ccnin(I1,J2,L,n1)+DDX(j)*TEMJ*ccnin(I2,J1,L,n1)) & - + tx2*(TEMI*TEMJ*ccnin(I1,J1,L,n2)+DDX(j)*DDY(J)*ccnin(I2,J2,L,n2) & - +TEMI*DDY(j)*ccnin(I1,J2,L,n2)+DDX(j)*TEMJ*ccnin(I2,J1,L,n2)) - - cipres(j,L) = & - tx1*(TEMI*TEMJ*ci_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*ci_pres(I2,J2,L,n1) & - +TEMI*DDY(j)*ci_pres(I1,J2,L,n1)+DDX(j)*TEMJ*ci_pres(I2,J1,L,n1)) & - + tx2*(TEMI*TEMJ*ci_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*ci_pres(I2,J2,L,n2) & - +TEMI*DDY(j)*ci_pres(I1,J2,L,n2)+DDX(j)*TEMJ*ci_pres(I2,J1,L,n2)) - ENDDO - ENDDO - - DO J=1,npts - DO L=1,lev - ! noticed input is from top to bottom - if(prsl(j,l).ge.cipres(j,kcipl)) then - ciplout(j,l)=cipm(j,kcipl) - ccnout(j,l)=ccnpm(j,kcipl) - else if(prsl(j,l).le.cipres(j,1)) then - ciplout(j,l)=cipm(j,1) - ccnout(j,l)=ccnpm(j,1) - else - DO k=kcipl-1,1,-1 - ! DH* There is no backstop if this condition isn't met, - ! i.e. i1 and i2 will have values determined by the - ! previous code (line 178) - this leads to crashes in - ! debug mode (out of bounds), for example for regression - ! test fv3_stretched_nest_debug. For the time being, - ! this is 'solved' by simply switching off ICCN - ! if MG2/3 are not used (these are the only microphysics - ! schemes that use the ICCN data); however, this doesn't - ! mean that the code is correct for MG2/3, it just doesn't - ! abort if the below condition isn't met, because the code - ! is not tested in DEBUG mode. *DH - IF(prsl(j,l)>cipres(j,k)) then - i1=k - i2=min(k+1,kcipl) - exit - end if - end do - ciplout(j,l)=cipm(j,i1)+(cipm(j,i2)-cipm(j,i1)) & - /(cipres(j,i2)-cipres(j,i1))*(prsl(j,l)-cipres(j,i1)) - ccnout(j,l)=ccnpm(j,i1)+(ccnpm(j,i2)-ccnpm(j,i1)) & - /(cipres(j,i2)-cipres(j,i1))*(prsl(j,l)-cipres(j,i1)) - end if - ENDDO - ENDDO -! - RETURN - END diff --git a/gfsphysics/physics/idea_co2.f b/gfsphysics/physics/idea_co2.f deleted file mode 100644 index b65d72f00..000000000 --- a/gfsphysics/physics/idea_co2.f +++ /dev/null @@ -1,73 +0,0 @@ - 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/gfsphysics/physics/idea_composition.f b/gfsphysics/physics/idea_composition.f deleted file mode 100644 index f86883259..000000000 --- a/gfsphysics/physics/idea_composition.f +++ /dev/null @@ -1,237 +0,0 @@ - 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/gfsphysics/physics/idea_dissipation.f b/gfsphysics/physics/idea_dissipation.f deleted file mode 100644 index 118895fe6..000000000 --- a/gfsphysics/physics/idea_dissipation.f +++ /dev/null @@ -1,191 +0,0 @@ - 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/gfsphysics/physics/idea_h2o.f b/gfsphysics/physics/idea_h2o.f deleted file mode 100644 index c7dd49ce3..000000000 --- a/gfsphysics/physics/idea_h2o.f +++ /dev/null @@ -1,95 +0,0 @@ - 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/gfsphysics/physics/idea_ion.f b/gfsphysics/physics/idea_ion.f deleted file mode 100644 index 1c483005e..000000000 --- a/gfsphysics/physics/idea_ion.f +++ /dev/null @@ -1,1845 +0,0 @@ -! 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/gfsphysics/physics/idea_o2_o3.f b/gfsphysics/physics/idea_o2_o3.f deleted file mode 100644 index 1ed15d2f9..000000000 --- a/gfsphysics/physics/idea_o2_o3.f +++ /dev/null @@ -1,153 +0,0 @@ - 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/gfsphysics/physics/idea_phys.f b/gfsphysics/physics/idea_phys.f deleted file mode 100644 index 24bfe8efe..000000000 --- a/gfsphysics/physics/idea_phys.f +++ /dev/null @@ -1,605 +0,0 @@ -!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/gfsphysics/physics/idea_solar_heating.f b/gfsphysics/physics/idea_solar_heating.f deleted file mode 100644 index f0c98a608..000000000 --- a/gfsphysics/physics/idea_solar_heating.f +++ /dev/null @@ -1,1227 +0,0 @@ - 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/gfsphysics/physics/idea_tracer.f b/gfsphysics/physics/idea_tracer.f deleted file mode 100644 index 21f618c94..000000000 --- a/gfsphysics/physics/idea_tracer.f +++ /dev/null @@ -1,419 +0,0 @@ - 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/gfsphysics/physics/ideaca.f b/gfsphysics/physics/ideaca.f deleted file mode 100644 index e2db22efd..000000000 --- a/gfsphysics/physics/ideaca.f +++ /dev/null @@ -1,232 +0,0 @@ -!*********************************************************************** -!*********************************************************************** -! 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/gfsphysics/physics/iounitdef.f b/gfsphysics/physics/iounitdef.f deleted file mode 100644 index 61c711bb1..000000000 --- a/gfsphysics/physics/iounitdef.f +++ /dev/null @@ -1,94 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! 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/gfsphysics/physics/lrgsclr.f b/gfsphysics/physics/lrgsclr.f deleted file mode 100644 index a198614de..000000000 --- a/gfsphysics/physics/lrgsclr.f +++ /dev/null @@ -1,289 +0,0 @@ - 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/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 deleted file mode 100644 index 276a2f3bc..000000000 --- a/gfsphysics/physics/m_micro_driver.F90 +++ /dev/null @@ -1,1849 +0,0 @@ - subroutine m_micro_driver(im, ix, lm, flipv, dt_i & - &, prsl_i, prsi_i, phil, phii & - &, omega_i, QLLS_i, QLCN_i, QILS_i, QICN_i& - &, lwheat_i, swheat_i, w_upi, cf_upi & - &, FRLAND, ZPBL, CNV_MFD_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& - &, qgl_io, ncpr_io, ncps_io, ncgl_io & - &, CLLS_io, KCBL & - &, CLDREFFL, CLDREFFI, CLDREFFR, CLDREFFS & - &, CLDREFFG, aerfld_i & - &, naai_i, npccn_i, iccn & - &, skip_macro & - &, lprnt, alf_fac, qc_min, pdfflag & - &, ipr, kdt, xlat, xlon, rhc_i) - - 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, fix_up_clouds_2M - use cldwat2m_micro,only: mmicro_pcond - use micro_mg2_0, only: micro_mg_tend2_0 => micro_mg_tend, qcvar2 => qcvar - use micro_mg3_0, only: micro_mg_tend3_0 => micro_mg_tend, qcvar3 => qcvar - use aerclm_def, only: ntrcaer - -! 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 -! Anning Cheng 9/29/2017 implemented the MG2 from NCAR -! alphar8 for qc_var scaled from climatology value -! -! Feb 2018 : S. Moorthi Updated for MG3 with graupel as prognostic variable -!------------------------------------ -! input -! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0d0, oneb3=one/3.0d0, onebcp=one/cp, & - zero=0.0d0, half=0.5d0, onebg=one/grav, & - & kapa=rgas*onebcp, cpbg=cp/grav, & - & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp,& - & qsmall=1.0d-14, rainmin = 1.0d-13, & - & fourb3=4.0d0/3.0d0, RL_cub=1.0d-15, nmin=1.0d0 - - integer, parameter :: ncolmicro = 1 - integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp, pdfflag - logical,intent(in) :: flipv, skip_macro, lprnt - integer,intent(in) :: iccn - real (kind=kind_phys), intent(in):: dt_i, alf_fac, qc_min(2) - - real (kind=kind_phys), dimension(ix,lm),intent(in) :: & - & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & - & lwheat_i,swheat_i - real (kind=kind_phys), dimension(ix,0:lm),intent(in):: prsi_i, & - & phii - real (kind=kind_phys), dimension(im,lm),intent(in) :: & - & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & - & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & - & CNV_NICE_i, w_upi, rhc_i, naai_i, npccn_i - real (kind=kind_phys), dimension(im,lm,ntrcaer),intent(in) :: & - & aerfld_i - real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & - & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon - -! output - real (kind=kind_phys),dimension(ix,lm) :: lwm_o, qi_o, & - cldreffl, cldreffi, cldreffr, cldreffs, cldreffg - real (kind=kind_phys),dimension(im) :: rn_o, sr_o - -! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose - integer, dimension(IM) :: KCBL - -! 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, & - & qgl_io, ncgl_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_FICE,CNV_NDROP,CNV_NICE -! & 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, PLO, ZLO, temp, & - & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF, & -! & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF,SMAXL,SMAXI, & -! & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC,CNN01,CNN04,CNN1,DNHET_IMM, & - & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC, DNHET_IMM, & - & NHET_IMM,NHET_DEP,NHET_DHF,DUST_IMM,DUST_DEP, DUST_DHF,WSUB, & - & SIGW_GW,SIGW_CNV,SIGW_TURB, & -! & SIGW_GW,SIGW_CNV,SIGW_TURB,SIGW_RC,REV_CN_X,REV_LS_X, & - & rnw,snw,ncpr,ncps,qgl,ncgl, & -! & RSU_LS_X, ALPHT_X, DLPDF_X, DIPDF_X,rnw,snw,ncpr,ncps,qgl,ncgl, & -! & ACLL_CN_X,ACIL_CN_X, PFRZ, FQA,QCNTOT,QTOT,QL_TOT,qi_tot,blk_l,rhc - & FQA,QL_TOT,qi_tot,blk_l,rhc - - real(kind=kind_phys) :: QCNTOT, QTOT - - real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN, CLLS - -! real(kind=kind_phys), dimension(IM,LM):: DQRL_X, & -! real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN,CLLS, & -! & CCN01,CCN04,CCN1 - -! real(kind=kind_phys), allocatable, dimension(:,:) :: RHX_X & -! &, CFPDF_X, VFALLSN_CN_X, QSNOW_CN, VFALLRN_CN_X, QRAIN_CN & - - real(kind=kind_phys), allocatable, dimension(:,:) :: & - & ALPHT_X, PFRZ -! & QSNOW_CN, QRAIN_CN, ALPHT_X, PFRZ - -! real(kind=kind_phys), allocatable, dimension(:,:) :: & -! & QSNOW_CN, QRAIN_CN & -!! &, CFPDF_X, QSNOW_CN, QRAIN_CN & -! &, ALPHT_X, PFRZ -!! &, REV_CN_X, RSU_CN_X, DLPDF_X, DIPDF_X, ALPHT_X, PFRZ & -!! &, ACLL_CN_X, ACIL_CN_X, DQRL_X & -!! &, PFI_CN_X, PFL_CN_X, QST3, DZET, QDDF3 -!! real(kind=kind_phys), allocatable, dimension(:) :: vmip - -! real(kind=kind_phys), dimension(IM,LM) :: QDDF3 -! 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 -! & VFALLRN_CN_X, QRAIN_CN, dum - - real(kind=kind_phys), dimension(IM,LM+1) :: ZET - real(kind=kind_phys), dimension(IM,0:LM) :: PLE, kh - -! real(kind=kind_phys), dimension(IM,0:LM) :: PLE, PKE, kh -! &, PFI_CN_X, PFL_CN_X - - 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, & - & qgr8, ngr8 - - 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 - real(kind=kind_phys), dimension(IM) :: LS_SNR, LS_PRC2 -! & VMIP, twat - - real(kind=kind_phys), dimension (LM) :: uwind_gw,vwind_gw, & - & tm_gw, pm_gw, nm_gw, h_gw, rho_gw, 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, dsoutr8, qcsinksum_rate1ord,qrtend,nrtend, & - & qstend, nstend, alphar8, rhr8, & - - & qgtend, ngtend, qgoutr8, ngoutr8, dgoutr8 - - 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,sadice, & - & sadsnow, am_evp_st, reff_rain, reff_snow, & - & umr,ums,qrsedten,qssedten,refl,arefl,areflz,frefl,csrfl, & - & acsrfl,fcsrfl,rercld,qrout2,qsout2,nrout2,nsout2,drout2, & - & dsout2,freqs,freqr,nfice,qcrat,prer_evap, & -! graupel related - & reff_grau, umg, qgsedtenr8, mnuccrior8, & - & pracgr8, psacwgr8, pgsacwr8, pgracsr8, prdgr8, qmultgr8,& - & qmultrgr8, psacrr8, npracgr8, nscngr8, ngracsr8, nmultgr8,& - & nmultrgr8, npsacwgr8, qgout2, ngout2, dgout2, freqg - - 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), dimension(2:LM+1) :: lflx, iflx, rflx, & - sflx, gflx - -! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & -! &, dcrit=20.0e-6 & - real (kind=kind_phys), parameter :: disp_liu=1.0d0 & - &, ui_scale=1.0d0 & - &, dcrit=1.0d-6 & -! &, ts_autice=1800.0 & -! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1d6 & - &, ncnstr8 = 100.0d6 - - real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 - real(kind=kind_phys):: t_ice_denom - - integer, dimension(1) :: lev_sed_strt ! sedimentation start level - real(kind=kind_phys), parameter :: sig_sed_strt=0.05d0 ! normalized pressure at sedimentation start - - 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.0d0, fsoot_drop=0.1d0 & - &, sigma_nuc_r8=0.28d0,SCLMFDFR=0.03d0 -! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1d0 - - type (AerProps), dimension (IM,LM) :: AeroProps - type (AerProps) :: AeroAux, AeroAux_b - real, allocatable, dimension(:,:,:) :: AERMASSMIX - - logical :: use_average_v, ltrue, lprint - -!================================== -!====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.0, 4.0 , 4.0 , 1.0 , 2.e-3, 8.e-4, 2.0 , 1.0 , -1.0 & - &, 0.0 , 1.3 , 1.0e-9, 3.3e-4, 20.0 , 4.8 , 4.8 , 230.0 , 1.0 & - &, 1.0 , 230.0, 14400., 50.0 , 0.01 , 0.1 , 200.0, 0.0 , 0.0 & - &, 0.5 , 0.5 , 2000.0, 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 , 900.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 880.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 980.0& - &, 1.0 , 1.0 , 1.0 , 0.0 , 0.0 , 1.e-5, 2.e-5, 2.1e-5, 4.e-5& -! &, 3e-5, 0.1 , 4.0 , 250./ ! Annings version - &, 3e-5, 0.1 , 4.0 , 150./ ! Annings version -! &, 3e-5, 0.1 , 1.0 , 150./ - - -! rhr8 = 1.0 - 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) - qgl(i,k) = qgl_io(i,ll) - ncpr(i,k) = ncpr_io(i,ll) - ncps(i,k) = ncps_io(i,ll) - ncgl(i,k) = ncgl_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) = max(CLLS_io(I,ll)-CLCN_i(I,ll),zero) - PLO(i,k) = prsl_i(i,ll)*0.01d0 - zlo(i,k) = phil(i,ll) * onebg - temp(i,k) = t_io(i,ll) - radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) - rhc(i,k) = rhc_i(i,ll) - if (iccn == 1) then - CDNC_NUC(i,k) = npccn_i(i,ll) - INC_NUC(i,k) = naai_i (i,ll) - endif - - END DO - END DO - DO K=0, LM - ll = lm-k - DO I = 1,IM - PLE(i,k) = prsi_i(i,ll) * 0.01d0 ! interface pressure in hPa - zet(i,k+1) = phii(i,ll) * onebg - END DO - END DO - if (.not. skip_macro) then -! allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & - allocate(CNV_MFD(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) - rnw(i,k) = rnw_io(i,k) - snw(i,k) = snw_io(i,k) - qgl(i,k) = qgl_io(i,k) - ncpr(i,k) = ncpr_io(i,k) - ncps(i,k) = ncps_io(i,k) - ncgl(i,k) = ncgl_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) = max(CLLS_io(I,k)-CLCN_i(I,k),zero) - PLO(i,k) = prsl_i(i,k)*0.01d0 - zlo(i,k) = phil(i,k) * onebg - temp(i,k) = t_io(i,k) - radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) - rhc(i,k) = rhc_i(i,k) - if (iccn == 1) then - CDNC_NUC(i,k) = npccn_i(i,k) - INC_NUC(i,k) = naai_i (i,k) - endif - - END DO - END DO - DO K=0, LM - DO I = 1,IM - PLE(i,k) = prsi_i(i,k) * 0.01d0 ! interface pressure in hPa - zet(i,k+1) = phii(i,k) * onebg - END DO - END DO - if (.not. skip_macro) then -! allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & - allocate(CNV_MFD(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 - -! if (lprnt) then -! write(0,*)' inmic qlcn=',qlcn(ipr,:) -! write(0,*)' inmic qlls=',qlls(ipr,:) -! write(0,*)' inmic qicn=',qicn(ipr,:) -! write(0,*)' inmic qils=',qils(ipr,:) -! endif -! - DT_MOIST = dt_i - dt_r8 = dt_i - - if (kdt == 1) then - DO K=1, LM - DO I = 1,IM - CALL fix_up_clouds_2M(Q1(I,K), TEMP(i,k), QLLS(I,K), & - & QILS(I,K), CLLS(I,K), QLCN(I,K), & - & QICN(I,K), CLCN(I,K), NCPL(I,K), & - & NCPI(I,K), qc_min) - if (rnw(i,k) <= qc_min(1)) then - ncpr(i,k) = zero - elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) - endif - if (snw(i,k) <= qc_min(2)) then - ncps(i,k) = zero - elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = zero - elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - - enddo - enddo - endif - do i=1,im - KCBL(i) = max(LM-KCBL(i),10) - KCT(i) = 10 - enddo - - DO I=1, IM - DO K = LM-2, 10, -1 - If ((CNV_DQLDT(I,K) <= 1.0d-9) .and. & - & (CNV_DQLDT(I,K+1) > 1.0d-9)) then - KCT(I) = K+1 - exit - end if - END DO - END DO - -! do L=LM,1,-1 -! do i=1,im -! DZET(i,L) = ZET(i,L) - ZET(i,L+1) -! 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 -!------------------------------------------------------------------------------ - -! if (.not. skip_macro) then -! allocate(qddf3(im,lm)) -! allocate(vmip(im)) -! do i=1,im -! 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) -! qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) & -! & * (ple(i,k) - ple(i,k-1)) * (100.0/grav) -! 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 -! deallocate (vmip) -! endif - - - do l=lm-1,1,-1 - do i=1,im - tx1 = half * (temp(i,l+1) + temp(i,l)) - kh(i,l) = 3.55d-7*tx1**2.5d0*(rgas*0.01d0) / 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) = one / (one/max(0.15d0*ZPBL(i),0.4d0*zlo(i,lm-1))& - & + one/(zlo(i,l)*0.4d0) ) - - SC_ICE(i,l) = one - NCPL(i,l) = MAX( NCPL(i,l), zero) - NCPI(i,l) = MAX( NCPI(i,l), zero) - RAD_CF(i,l) = max(zero, min(CLLS(i,l)+CLCN(i,l), one)) - if (iccn /= 1) then - CDNC_NUC(i,l) = zero - INC_NUC(i,l) = zero - endif - - enddo - end do -! T_ICE_ALL = TICE - 40.0 - T_ICE_ALL = CLOUDPARAMS(33) + TICE - t_ice_denom = one / (tice - t_ice_all) - - - do l=1,lm - rhdfdar8(l) = 1.d-8 - rhu00r8(l) = 0.95d0 - - ttendr8(l) = zero - qtendr8(l) = zero - cwtendr8(l) = zero - - npccninr8(l) = zero - enddo - do k=1,10 - do l=1,lm - rndstr8(l,k) = 2.0d-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 - -! - do k=1,lm - do i=1,im - call init_Aer(AeroProps(I, K)) - enddo - enddo -! - - allocate(AERMASSMIX(IM,LM,15)) - if (iccn == 2) then - AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) - else - AERMASSMIX(:,:,1:5) = 1.0d-6 - AERMASSMIX(:,:,6:15) = 2.0d-14 - endif - call AerConversion1 (AERMASSMIX, AeroProps) - deallocate(AERMASSMIX) - - use_average_v = .false. - if (USE_AV_V > zero) 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(half*SQRT(TAUOROX(I)*TAUOROX(I) & - & + TAUOROY(I)*TAUOROY(I)), 10.0d0) - do k=1,lm - - uwind_gw(k) = min(half*SQRT( U1(I,k)*U1(I,k) & - & + V1(I,k)*V1(I,k)), 50.0d0) - -! 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.0d0*PLO(I,k) - tm_gw(k) = TEMP(I,k) - - nm_gw(k) = zero - rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) - - ter8(k) = TEMP(I,k) - plevr8(k) = 100.0d0*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) = zero - naair8(k) = zero - - npre8(k) = zero - - if (RAD_CF(I,k) > 0.01d0 .and. qir8(k) > zero) then - npre8(k) = NPRE_FRAC*NCPI(I,k) - else - npre8(k) = zero - endif - - omegr8(k) = OMEGA(I,k) - lc_turb(k) = max(blk_l(I,k), 50.0d0) -! rad_cooling(k) = RADheat(I,k) - - if (npre8(k) > zero .and. qir8(k) > zero) then - dpre8(k) = ( qir8(k)/(6.0d0*npre8(k)*900.0d0*PI))**(one/3.0d0) - else - dpre8(k) = 1.0d-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.0d0*PLE(I,k) - rhoi_gw(k) = zero - ni_gw(k) = zero - ti_gw(k) = zero - 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, q1(i,:)) - - do k=1,lm - nm_gw(k) = max(nm_gw(k), 0.005d0) - h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) - if (h_gw(K) > zero) then - h_gw(K) = sqrt(2.0d0*tausurf_gw/h_gw(K)) - end if - - wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133d0 - - wparc_cgw(k) = zero - end do - -!!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep - - if (kcldtopcvn > 20) then - - ksa1 = one - Nct = nm_gw(kcldtopcvn) - Wct = max(CNV_CVW(I,kcldtopcvn), zero) - - 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.56d0* & - & 1.806d0*c2_gw*c2_gw)*Wct*0.133d0 - enddo - - end if - - do k=1,lm - dummyW(k) = 0.133d0*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) = zero - wparc_gw(l) = zero - enddo - - - - kbmin = KCBL(I) - kbmin = min(kbmin, LM-1) - 4 - do K = 1, LM - wparc_turb(k) = KH(I,k) / lc_turb(k) - dummyW(k) = 10.0d0 - enddo - - if (FRLAND(I) < 0.1d0 .and. ZPBL(I) < 800.0d0 .and. & - & TEMP(I,LM) < 298.0d0 .and. TEMP(I,LM) > 274.0d0 ) then - do K = 1, LM - dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01d0,10.0d0),-10.0d0) - dummyW(k) = one / (one+exp(dummyW(k))) - enddo - maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & - & 0.17d0), 0.3d0) - do K = 1, LM - wparc_turb(k) = (one-dummyW(k))*wparc_turb(k) & - & + dummyW(k)*maxkh - enddo - - end if - - wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2d0) - - - -!!!:=========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) > 70.0d0) then - - ccn_diag(1) = 0.001d0 - ccn_diag(2) = 0.004d0 - ccn_diag(3) = 0.01d0 - - if (K > 2 .and. K <= LM-2) then - tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 - else - tauxr8 = ter8(K) - endif - - AeroAux = AeroProps(I, K) - - pfrz_inc_r8(k) = zero - rh1_r8 = zero !related to cnv_dql_dt, needed to changed soon - -! if (lprnt) write(0,*)' bef aero npccninr8=',npccninr8(k),' k=',k & -! &,' ccn_param=',ccn_param,' in_param=',in_param & -! &,' AeroAux%kap=',AeroAux%kap - - 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)) -! & size(ccn_diag), lprnt) -! if (lprnt) write(0,*)' aft aero npccninr8=',npccninr8(k),' k=',k - - if (npccninr8(k) < 1.0d-12) npccninr8(k) = zero - -! 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(:) = zero - smaxliq(K) = zero - swparc(K) = zero - smaxicer8(K) = zero - nheticer8(K) = zero - sc_icer8(K) = 2.0d0 -! sc_icer8(K) = 1.0d0 - naair8(K) = zero - npccninr8(K) = zero - nlimicer8(K) = zero - nhet_immr8(K) = zero - dnhet_immr8(K) = zero - nhet_depr8(K) = zero - nhet_dhfr8(K) = zero - dust_immr8(K) = zero - dust_depr8(K) = zero - dust_dhfr8(K) = zero - - end if - -! SMAXL(I,k) = smaxliq(k) * 100.0 -! SMAXI(I,k) = smaxicer8(k) * 100.0 - NHET_NUC(I,k) = nheticer8(k) * 1.0d-6 - NLIM_NUC(I,k) = nlimicer8(k) * 1.0d-6 - SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0d0) -! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) -! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) -! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) -! if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 -! if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) -! - if(iccn == 0) then - if(temp(i,k) < T_ICE_ALL) then -! SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) - SC_ICE(i,k) = max(SC_ICE(I,k), 1.5d0) - elseif(temp(i,k) > TICE) then - SC_ICE(i,k) = rhc(i,k) - else -! SC_ICE(i,k) = 1.0 -! tx1 = max(SC_ICE(I,k), 1.2) - tx1 = max(SC_ICE(I,k), 1.5d0) - SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + & - (temp(i,k)-t_ice_all)*rhc(i,k))* t_ice_denom - endif - endif - if (iccn.ne.1) then - CDNC_NUC(I,k) = npccninr8(k) - INC_NUC (I,k) = naair8(k) - endif - NHET_IMM(I,k) = max(nhet_immr8(k), zero) - DNHET_IMM(I,k) = max(dnhet_immr8(k), zero) - NHET_DEP(I,k) = nhet_depr8(k) * 1.0d-6 - NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0d-6 - DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0d-6 - DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0d-6 - DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0d-6 - WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8d0 - 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) -! if(lprnt) write(0,*)' bef macro_cloud clcn=',clcn(ipr,:) -! if(lprnt) write(0,*)' bef macro_cloud clls=',clls(ipr,:) - -! allocate(RHX_X(im,lm), CFPDF_X(im,lm), VFALLSN_CN_X(im,lm), & - allocate( & -! & QSNOW_CN(im,lm), VFALLRN_CN_X(im,lm), QRAIN_CN(im,lm),& -! & QSNOW_CN(im,lm), QRAIN_CN(im,lm),& -! & REV_CN_X(im,lm), RSU_CN_X(im,lm), DLPDF_X(im,lm), & -! & DIPDF_X(im,lm), ALPHT_X(im,lm), PFRZ(im,lm), & - & ALPHT_X(im,lm), PFRZ(im,lm)) -! & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm) -! & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm), & -! & DZET(im,lm)) -! & DZET(im,lm), qst3(im,lm)) -! allocate (PFI_CN_X(im,0:lm), PFL_CN_X(im,0:lm)) - -! do L=LM,1,-1 -! do i=1,im -! DZET(i,L) = ZET(i,L) - ZET(i,L+1) -! 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 -! do k=1,lm -! do i=1,im -! REV_CN_X(i,k) = 0.0 -! RSU_CN_X(i,k) = 0.0 -! 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 - -! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & -! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, FRLAND, & - call macro_cloud (IM, LM, DT_MOIST, alf_fac, PLO, PLE, & - & CNV_DQLDT, & -! & CNV_MFD, CNV_DQLDT, & -! & CNV_MFD, CNV_DQLDT, CNV_PRC3, CNV_UPDF, & -! & U1, V1, temp, Q1, QLLS, QLCN, QILS, QICN, & - & temp, Q1, QLLS, QLCN, QILS, QICN, & -! & U1, V1, TH1, Q1, QLLS, QLCN, QILS, QICN, & - & CLCN, CLLS, & -! & CLCN, CLLS, CN_PRC2, CN_ARFX, CN_SNR, & - & CLOUDPARAMS, SCLMFDFR, & -! & 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, & - & ALPHT_X, & - & CNV_FICE, CNV_NDROP, CNV_NICE, & - & SC_ICE, NCPL, NCPI, PFRZ, & - & lprnt, ipr, rhc, pdfflag, qc_min) -! & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr, rhc) - - -! 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 clls=',clls(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.0d-6) then - tx1 = one / 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) = zero - CNV_NICE(i,k) = zero - endif -! temp(i,k) = th1(i,k) * PK(i,k) - RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), one) -! - if (iccn.ne.1) then - if (PFRZ(i,k) > zero) 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) = zero - NHET_NUC(i,k) = zero - endif - 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, qc_min & -! &, pdfflag, PLO , Q1, QLLS & -! &, QLCN, QILS, QICN, TEMP & -! &, CLLS, CLCN, SC_ICE, NCPI & -! &, NCPL) -!! &, NCPL, INC_NUC) -!============ Put cloud fraction back in contact with the PDF (Barahona et al., GMD, 2014)============ - -!make sure QI , NI stay within T limits - call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) - - -! deallocate(RHX_X, CFPDF_X, VFALLSN_CN_X, & - deallocate( & -! & QSNOW_CN, VFALLRN_CN_X, QRAIN_CN, REV_CN_X, RSU_CN_X,& -! & QSNOW_CN, QRAIN_CN, & - & PFRZ) -! & DLPDF_X, DIPDF_X, PFRZ, ACLL_CN_X, ACIL_CN_X, DQRL_X,& -! & PFI_CN_X, PFL_CN_X) -! & PFI_CN_X, PFL_CN_X, DZET, qst3, qddf3) - - 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 = QLCN(i,k) + QICN(i,k) - QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) - QI_TOT(i,k) = QICN(i,k) + QILS(i,k) -! Anning if negative, borrow water and ice from vapor 11/23/2016 - if (QL_TOT(i,k) < zero) 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) = zero - endif - if (QI_TOT(i,k) < zero) 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) = zero - endif - QTOT = QL_TOT(i,k) + QI_TOT(i,k) - if (QTOT > zero) then - FQA(i,k) = min(max(QCNTOT / QTOT, zero), one) - else - FQA(i,k) = zero - 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) = zero - LS_PRC2(i) = zero - - nbincontactdust = 1 - - do l=1,10 - do k=1,lm - naconr8(k,l) = zero - rndstr8(k,l) = 2.0d-7 - enddo - enddo - do k=1,lm - npccninr8(k) = zero - naair8(k) = zero - omegr8(k) = zero - -! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) - tx1 = MIN(CLLS(I,k) + CLCN(I,k), one) - if (tx1 > zero) then - cldfr8(k) = min(max(tx1, 0.00001d0), one) - else - cldfr8(k) = zero - endif - - if (temp(i,k) > tice) then - liqcldfr8(k) = cldfr8(k) - icecldfr8(k) = zero - elseif (temp(i,k) <= t_ice_all) then - liqcldfr8(k) = zero - icecldfr8(k) = cldfr8(k) - else - icecldfr8(k) = cldfr8(k) * (tice - temp(i,k))/(tice-t_ice_all) - liqcldfr8(k) = cldfr8(k) - icecldfr8(k) - endif - - - 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), zero) - nir8(k) = MAX(NCPI(I,k), zero) - qrr8(k) = rnw(I,k) - qsr8(k) = snw(I,k) - qgr8(k) = qgl(I,k) - nrr8(k) = MAX(NCPR(I,k), zero) - nsr8(k) = MAX(NCPS(I,k), zero) - ngr8(k) = MAX(ncgl(I,k), zero) - - - naair8(k) = INC_NUC(I,k) - npccninr8(k) = CDNC_NUC(I,k) - - if (cldfr8(k) >= 0.001d0) then - nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) - else - nimmr8(k) = zero - endif - - - AeroAux = AeroProps(I, K) - call getINsubset(1, AeroAux, AeroAux_b) - naux = AeroAux_b%nmods - if (nbincontactdust < naux) then - nbincontactdust = naux - endif - naconr8(K, 1:naux) = AeroAux_b%num(1:naux) - rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * half - -! The following moved inside of if(fprcp <= 0) then loop -! 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.0d0 - rpdelr8(k) = one / pdelr8(k) - plevr8(k) = 100.0d0 * PLO(I,k) - zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0d-10) - omegr8(k) = WSUB(I,k) -! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) -! alphar8(k) = qcvar2 - rhr8(k) = rhc(i,k) - - END DO - do k=1,lm+1 - pintr8(k) = PLE(I,k-1) * 100.0d0 - kkvhr8(k) = KH(I,k-1) - END DO - - lev_sed_strt = 0 - tx1 = one / pintr8(lm+1) - do k=1,lm - if (plevr8(k)*tx1 < sig_sed_strt) then - lev_sed_strt(1) = k - endif - enddo - lev_sed_strt(1) = max(lm/6, min(lm/3,lev_sed_strt(1))) -! if (kdt == 1) & -! write(0,*)' lev_sed_strt=',lev_sed_strt,' plevr8=',plevr8(lev_sed_strt), & -! ' pintr8=',pintr8(lm+1),' sig_sed_strt=',sig_sed_strt -! -! do k=1,lm -! if (cldfr8(k) <= 0.2 ) then -! alphar8(k) = 0.5 -! elseif (cldfr8(k) <= 0.999) then -!! tx1 = 0.0284 * exp(4.4*cldfr8(k)) -!! alphar8(k) = tx1 / (cldfr8(k) - tx1*(one-cldfr8(k))) -!! alphar8(k) = 0.5 + (7.5/0.799)*(cldfr8(k)-0.2) -! alphar8(k) = 0.5 + (7.5/0.799)*(cldfr8(k)-0.2) -! else -! alphar8(k) = 8.0 -! endif -! alphar8(k) = min(8.0, max(alphar8(k), 0.5)) -! enddo - - kbmin = KCBL(I) - -!!!Call to MG microphysics. Lives in cldwat2m_micro.f -! ttendr8, qtendr8,cwtendr8, not used so far Anning noted August 2015 - - if (fprcp <= 0) then ! if fprcp = -1, then Anning's code for MG2 will be used - ! if fprcp = 0, then MG1 is used - -! Get black carbon properties for contact ice nucleation - do k=1,lm - 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 - enddo - - call mmicro_pcond ( ncolmicro, ncolmicro, & - & dt_r8, ter8, ttendr8, & - & ncolmicro, LM , qvr8, & - & qtendr8, cwtendr8, qcr8, qir8, ncr8, nir8, & - & abs(fprcp), qrr8, qsr8, nrr8, nsr8, & - & plevr8, pdelr8, cldfr8, liqcldfr8, & - & icecldfr8, cldor8, pintr8, & - & rpdelr8, zmr8, 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, dsoutr8, 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, & - & lprnt, xlat(i), xlon(i), rhr8) - -! if (lprint) write(0,*)' prectr8=',prectr8(1), & -! & ' precir8=',precir8(1) - - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) - - - 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, zero) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, zero) - rnw(I,k) = qrr8(k) - snw(I,k) = qsr8(k) - NCPR(I,k) = nrr8(k) - NCPS(I,k) = nsr8(k) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0), 150.0d0) - CLDREFFI(I,k) = min(max(effir8(k), 20.0d0), 150.0d0) - CLDREFFR(I,k) = max(droutr8(k)*0.5d0*1.0d6, 150.0d0) - CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) - - enddo ! K loop - - elseif (fprcp == 1) then ! Call MG2 -! -------- -! if (lprnt .and. i == ipr) then -! write(0,*)' bef micro_mg_tend ter8= ', ter8(:) -! write(0,*)' bef micro_mg_tend qvr8= ', qvr8(:),'dt_r8=',dt_r8 -! write(0,*)' bef micro_mg_tend rhr8= ', rhr8(:) -! endif - lprint = lprnt .and. i == ipr - ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & - .or. any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) - if (ltrue) then - alphar8(:) = qcvar2 - -! if(lprint) then -! write(0,*)' calling micro_mg_tend2_0 qcvar2=',qcvar2 -! write(0,*)' qcr8=',qcr8(:) -! write(0,*)' ncr8=',ncr8(:) -! write(0,*)' npccninr8=',npccninr8(:) -! write(0,*)' plevr8=',plevr8(:) -! write(0,*)' ter8=',ter8(:) -! endif - - call micro_mg_tend2_0 ( & - & ncolmicro, lm, dt_r8, & - & ter8, qvr8, & - & qcr8, qir8, & - & ncr8, nir8, & - & qrr8, qsr8, & - & nrr8, nsr8, & - & alphar8, 1., & - & plevr8, pdelr8, & -! & cldfr8, liqcldfr8, icecldfr8, rhc, & - & cldfr8, liqcldfr8, icecldfr8, rhr8, & - & qcsinksum_rate1ord, & - & naair8, npccninr8, & - & rndstr8, naconr8, & - & tlatr8, qvlatr8, & - & qctendr8, qitendr8, & - & nctendr8, nitendr8, & - & qrtend, qstend, & - & nrtend, nstend, & - & effcr8, effc_fnr8, effir8, & - & sadice, sadsnow, & - & prectr8, precir8, & - & nevaprr8, evapsnowr8, & - & am_evp_st, & - & prainr8, prodsnowr8, & - & cmeoutr8, deffir8, & - & pgamradr8, lamcradr8, & - & qsoutr8, dsoutr8, & - & lflx, iflx, & - & rflx, sflx, qroutr8, & - & reff_rain, reff_snow, & - & qcsevapr8, qisevapr8, qvresr8, & - & cmeioutr8, vtrmcr8, vtrmir8, & - & umr, ums, & - & qcsedtenr8, qisedtenr8, & - & qrsedten, qssedten, & - & praor8, prcor8, & - & mnucccor8, mnucctor8, msacwior8, & - & psacwsor8, bergsor8, bergor8, & - & meltor8, homoor8, & - & qcresor8, prcior8, praior8, & - & qiresor8, mnuccror8, pracsor8, & - & meltsdtr8, frzrdtr8, mnuccdor8, & - & nroutr8, nsoutr8, & - & refl, arefl, areflz, & - & frefl, csrfl, acsrfl, & - & fcsrfl, rercld, & - & ncair8, ncalr8, & - & qrout2, qsout2, & - & nrout2, nsout2, & - & drout2, dsout2, & - & freqs, freqr, & - & nfice, qcrat, & - & prer_evap, xlat(i), xlon(i), lprint, iccn, & - & lev_sed_strt) -! - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) - 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 - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 - snw(I,k) = snw(I,k) + qstend(k)*dt_r8 - - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) - CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) - CLDREFFR(I,k) = max(reff_rain(k),150.0d0) - CLDREFFS(I,k) = max(reff_snow(k),250.0d0) - enddo ! K loop -! if (lprint) then -! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) -! write(0,*)' aft micro_mg_tend q1= ', q1(i,:) -! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) -! endif - else - LS_PRC2(I) = zero - LS_SNR(I) = zero - do k=1,lm - CLDREFFL(I,k) = 10.0d0 - CLDREFFI(I,k) = 50.0d0 - CLDREFFR(I,k) = 1000.0d0 - CLDREFFS(I,k) = 250.0d0 - enddo ! K loop - endif -! - else ! Call MG3 -! -------- - ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & - .or. any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) & - .or. any(qgr8 >= qsmall) - lprint = lprnt .and. i == ipr - if (ltrue) then - alphar8(:) = qcvar3 - -! if(lprint) then -! write(0,*)' calling micro_mg_tend3_0 qcvar3=',qcvar3,' i=',i -! write(0,*)' qcr8=',qcr8(:) -! write(0,*)' qir8=',qir8(:) -! write(0,*)' ncr8=',ncr8(:) -! write(0,*)' nir8=',nir8(:) -! write(0,*)' npccninr8=',npccninr8(:) -! write(0,*)' plevr8=',plevr8(:) -! write(0,*)' ter8=',ter8(:) -! endif - - call micro_mg_tend3_0 ( & - & ncolmicro, lm, dt_r8, & - & ter8, qvr8, & - & qcr8, qir8, & - & ncr8, nir8, & - & qrr8, qsr8, & - & nrr8, nsr8, & - & qgr8, ngr8, & - & alphar8, 1., & - & plevr8, pdelr8, & -! & cldfr8, liqcldfr8, icecldfr8, rhc, & - & cldfr8, liqcldfr8, icecldfr8, rhr8, & - & qcsinksum_rate1ord, & - & naair8, npccninr8, & - & rndstr8, naconr8, & - & tlatr8, qvlatr8, & - & qctendr8, qitendr8, & - & nctendr8, nitendr8, & - & qrtend, qstend, & - & nrtend, nstend, & -! - & qgtend, ngtend, & -! - & effcr8, effc_fnr8, effir8, & - & sadice, sadsnow, & - & prectr8, precir8, & - & nevaprr8, evapsnowr8, & - & am_evp_st, & - & prainr8, prodsnowr8, & - & cmeoutr8, deffir8, & - & pgamradr8, lamcradr8, & - & qsoutr8, dsoutr8, & -! - & qgoutr8, ngoutr8, dgoutr8, & -! - & lflx, iflx, gflx, & -! - & rflx, sflx, qroutr8, & -! - & reff_rain, reff_snow, reff_grau, & -! - & qcsevapr8, qisevapr8, qvresr8, & - & cmeioutr8, vtrmcr8, vtrmir8, & - & umr, ums, & -! - & umg, qgsedtenr8, & -! - & qcsedtenr8, qisedtenr8, & - & qrsedten, qssedten, & - & praor8, prcor8, & - & mnucccor8, mnucctor8, msacwior8, & - & psacwsor8, bergsor8, bergor8, & - & meltor8, homoor8, & - & qcresor8, prcior8, praior8, & -! - & qiresor8, mnuccror8, mnuccrior8, pracsor8, & -! - & meltsdtr8, frzrdtr8, mnuccdor8, & -! - & pracgr8, psacwgr8, pgsacwr8, & - & pgracsr8, prdgr8, & - & qmultgr8, qmultrgr8, psacrr8, & - & npracgr8, nscngr8, ngracsr8, & - & nmultgr8, nmultrgr8, npsacwgr8, & -! - & nroutr8, nsoutr8, & - & refl, arefl, areflz, & - & frefl, csrfl, acsrfl, & - & fcsrfl, rercld, & - & ncair8, ncalr8, & - & qrout2, qsout2, & - & nrout2, nsout2, & - & drout2, dsout2, & -! - & qgout2, ngout2, dgout2, freqg, & - & freqs, freqr, & - & nfice, qcrat, & - & prer_evap, xlat(i), xlon(i), lprint, iccn, & - & lev_sed_strt) - - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) - 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 - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 - snw(I,k) = snw(I,k) + qstend(k)*dt_r8 - qgl(I,k) = qgl(I,k) + qgtend(k)*dt_r8 - - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) - NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, zero) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) - CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) - CLDREFFR(I,k) = max(reff_rain(k),150.0d0) - CLDREFFS(I,k) = max(reff_snow(k),250.0d0) - CLDREFFG(I,k) = max(reff_grau(k),250.0d0) - enddo ! K loop -! if (lprint) then -! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) -! write(0,*)' aft micro_mg_tend q1= ', q1(i,:) -! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) -! endif - else - LS_PRC2(I) = zero - LS_SNR(I) = zero - do k=1,lm - CLDREFFL(I,k) = 10.0d0 - CLDREFFI(I,k) = 50.0d0 - CLDREFFR(I,k) = 1000.0d0 - CLDREFFS(I,k) = 250.0d0 - CLDREFFG(I,k) = 250.0d0 - enddo ! K loop - endif - endif - - enddo ! I loop -!============================================Finish 2-moment micro implementation=========================== - -!TVQX1 = SUM( ( Q1 + QL_TOT + QI_TOT(1:im,:,:))*DM, 3) & - - - if (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) - - CALL fix_up_clouds_2M(Q1(I,K), TEMP(i,k), QLLS(I,K), & - & QILS(I,K), CLLS(I,K), QLCN(I,K), & - & QICN(I,K), CLCN(I,K), NCPL(I,K), & - & NCPI(I,K), qc_min) - - QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) - QI_TOT(I,K) = QILS(I,K) + QICN(I,K) - if (rnw(i,k) <= qc_min(1)) then - ncpr(i,k) = zero - elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) - endif - if (snw(i,k) <= qc_min(2)) then - ncps(i,k) = zero - elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = zero - elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - enddo - enddo - else - 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) - enddo - enddo - - call update_cld(im, lm, DT_MOIST, ALPHT_X, qc_min & - &, pdfflag, PLO, Q1, QLLS, QLCN & - &, QILS, QICN, TEMP, CLLS, CLCN & - &, SC_ICE, NCPI, NCPL) - -! if(lprnt) write(0,*)' aft update_cloud clls=',clls(ipr,:) - - 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) -! - if (rnw(i,k) <= qc_min(1)) then - ncpr(i,k) = zero - elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) - endif - if (snw(i,k) <= qc_min(2)) then - ncps(i,k) = zero - elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = zero - elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) - endif - enddo - enddo - deallocate(CNV_MFD,CNV_FICE,CNV_NDROP,CNV_NICE) -! 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) <= zero) NCPI(i,k) = zero - if (QL_TOT(i,k) <= zero) NCPL(i,k) = zero - 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) - qgl_io(i,k) = qgl(i,ll) - ncpr_io(i,k) = NCPR(i,ll) - ncps_io(i,k) = NCPS(i,ll) - ncgl_io(i,k) = NCGL(i,ll) - lwm_o(i,k) = QL_TOT(i,ll) - qi_o(i,k) = QI_TOT(i,ll) - END DO - END DO - if (skip_macro) then - DO K=1, LM - ll = lm-k+1 - DO I = 1,IM - CLLS_io(i,k) = max(zero, min(CLLS(i,ll)+CLCN(i,ll),one)) - enddo - enddo - else - DO K=1, LM - ll = lm-k+1 - DO I = 1,IM - CLLS_io(i,k) = CLLS(i,ll) - enddo - enddo - endif - 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) - qgl_io(i,k) = qgl(i,k) - ncpr_io(i,k) = NCPR(i,k) - ncps_io(i,k) = NCPS(i,k) - ncgl_io(i,k) = NCGL(i,k) - lwm_o(i,k) = QL_TOT(i,k) - qi_o(i,k) = QI_TOT(i,k) - END DO - END DO - if (skip_macro) then - DO K=1, LM - DO I = 1,IM - CLLS_io(i,k) = max(zero, min(CLLS(i,k)+CLCN(i,k),one)) - enddo - enddo - else - DO K=1, LM - DO I = 1,IM - CLLS_io(i,k) = CLLS(i,k) - enddo - enddo - endif - endif ! end of flipv if - - DO I = 1,IM - tx1 = LS_PRC2(i) + LS_SNR(i) - rn_o(i) = tx1 * dt_i * 0.001d0 - - if (rn_o(i) < rainmin) then - sr_o(i) = zero - else - sr_o(i) = max(zero, min(one, LS_SNR(i)/tx1)) - endif - ENDDO - - if (allocated(ALPHT_X)) deallocate (ALPHT_X) - -! if (lprnt) then -! write(0,*)' rn_o=',rn_o(ipr),' ls_prc2=',ls_prc2(ipr),' ls_snr=',ls_snr(ipr),' kdt=',kdt -! write(0,*)' end micro_mg_tend t_io= ', t_io(ipr,:) -! write(0,*)' end micro_mg_tend clls_io= ', clls_io(ipr,:) -! endif -! do k=1,lm -! do i=1,im -! dum(i,k) = clls_io(i,k) -! enddo -! enddo -! do k=2,lm-1 -! do i=1,im -! clls_io(i,k) = 0.25*dum(i,k-1) + 0.5*dum(i,k)+0.25*dum(i,k+1) -! enddo -! enddo -! do i=1,im -! clls_io(i,lm) = 0.5 * (dum(i,lm-1) + dum(i,lm)) -! enddo - - - -!======================================================================= - - end subroutine m_micro_driver -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!DONIF Calculate the Brunt_Vaisala frequency - -!=============================================================================== - subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & - nm, sph) - use machine , only : kind_phys - use physcons, grav => con_g, cp => con_cp, rgas => con_rd, & - fv => con_fvirt - 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, pcols, 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(in) :: sph(pcols,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) - - real(kind=kind_phys), parameter :: r=rgas, cpair=cp, g=grav, & - oneocp=1.0d0/cp, n2min=1.0d-8 - -!---------------------------Local storage------------------------------- - integer :: ix,kx - - real :: dtdp, n2 - -!----------------------------------------------------------------------------- -! 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)*(1.0d0+fv*sph(ix,kx+1)))) - 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.5d0 * (t(ix,kx) + t(ix,kx+1)) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0d0+0.5d0*fv*(sph(ix,kx)+sph(ix,kx+1)))) - dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) - n2 = g*g/ti(ix,kx) * (oneocp - 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)*(1.0d0+fv*sph(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.5d0 * (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 = 1.0d-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/gfsphysics/physics/machine.F b/gfsphysics/physics/machine.F deleted file mode 100644 index bd896dac9..000000000 --- a/gfsphysics/physics/machine.F +++ /dev/null @@ -1,45 +0,0 @@ - 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 & -#ifdef __PGI - &, kind_qdt_prec = 8 & -#else - &, kind_qdt_prec = 16 & -#endif - &, 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 & -#ifdef __PGI - &, kind_qdt_prec = 8 & -#else - &, kind_qdt_prec = 16 & -#endif - &, kind_rad = 4 & - &, kind_phys = 4 ,kind_taum=4 & - &, kind_grid = 4 & - &, kind_REAL = 4 &! used in cmp_comm - &, kind_INTEGER = 4 ! -,,- - -#endif - -#ifdef OVERLOAD_R4 - integer, parameter :: kind_dyn = 4 -#else - integer, parameter :: kind_dyn = 8 -#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/gfsphysics/physics/mersenne_twister.f b/gfsphysics/physics/mersenne_twister.f deleted file mode 100644 index b5c69cb85..000000000 --- a/gfsphysics/physics/mersenne_twister.f +++ /dev/null @@ -1,498 +0,0 @@ -!$$$ 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/gfsphysics/physics/mfpbl.f b/gfsphysics/physics/mfpbl.f deleted file mode 100644 index b510f658b..000000000 --- a/gfsphysics/physics/mfpbl.f +++ /dev/null @@ -1,392 +0,0 @@ -!> \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 HEDMF -!! \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/gfsphysics/physics/mfpblt.f b/gfsphysics/physics/mfpblt.f deleted file mode 100644 index 3a09ad13a..000000000 --- a/gfsphysics/physics/mfpblt.f +++ /dev/null @@ -1,440 +0,0 @@ - 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/gfsphysics/physics/mfpbltq.f b/gfsphysics/physics/mfpbltq.f deleted file mode 100644 index 8273214a5..000000000 --- a/gfsphysics/physics/mfpbltq.f +++ /dev/null @@ -1,440 +0,0 @@ - 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 -! - real(kind=kind_phys) dt2, dz, ce0, cm, - & factor, gocp, - & g, b1, f1, - & bb1, bb2, - & 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), 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(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 - thlu(i,1)= thlx(i,1) + vpert(i) - qtu(i,1) = qtx(i,1) - buo(i,1) = g * vpert(i) / 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. - 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) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) - 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)) 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/gfsphysics/physics/mfscu.f b/gfsphysics/physics/mfscu.f deleted file mode 100644 index 692950bd2..000000000 --- a/gfsphysics/physics/mfscu.f +++ /dev/null @@ -1,545 +0,0 @@ - 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/gfsphysics/physics/mfscuq.f b/gfsphysics/physics/mfscuq.f deleted file mode 100644 index cb7707004..000000000 --- a/gfsphysics/physics/mfscuq.f +++ /dev/null @@ -1,539 +0,0 @@ - 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/gfsphysics/physics/micro_mg2_0.F90 b/gfsphysics/physics/micro_mg2_0.F90 deleted file mode 100644 index ec44523e6..000000000 --- a/gfsphysics/physics/micro_mg2_0.F90 +++ /dev/null @@ -1,3391 +0,0 @@ -!>\file micro_mg2_0.F90 -!! This file contains Morrison-Gettelman MP version 2.0 - update of MG -!! microphysics with prognostic precipitation. - -!>\ingroup mg2mg3 -!>\defgroup mg2_0_mp Morrison-Gettelman MP version 2.0 -!! This module includes the MG microphysics version 2.0 - update of MG -!! microphysics with prognostic precipitation. -!! -!!\author Andrew Gettelman, Hugh Morrison, Sean Santos -!! e-mail: morrison@ucar.edu, andrew@ucar.edu -!!\n Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan -!! -!! - Anning Cheng adopted for FV3GFS 9/29/2017 -!! - Anning Cheng added GMAO ice conversion and Liu et al. Liquid water conversion -!! in 10/12/2017 -!! - S. Moorthi - Oct/Nov 2017 - optimized the code -!! - S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit -!! - Version 2 history: -!! - Sep 2011: Development begun -!! - Feb 2013: Added of prognostic precipitation -!! - Aug 2015: Published and released version (\cite Gettelman_2015_1 \cite Gettelman_2015_2 ) -module micro_mg2_0 -!--------------------------------------------------------------------------------- -! -! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice -! microphysics in cooperation with the MG liquid microphysics. This is -! controlled by the do_cldice variable. -! -! If do_cldice is false, then MG microphysics should not update CLDICE or -! NUMICE; it is assumed that the other microphysics scheme will have updated -! CLDICE and NUMICE. The other microphysics should handle the following -! processes that would have been done by MG: -! - Detrainment (liquid and ice) -! - Homogeneous ice nucleation -! - Heterogeneous ice nucleation -! - Bergeron process -! - Melting of ice -! - Freezing of cloud drops -! - Autoconversion (ice -> snow) -! - Growth/Sublimation of ice -! - Sedimentation of ice -! -! This option has not been updated since the introduction of prognostic -! precipitation, and probably should be adjusted to cover snow as well. -! -!--------------------------------------------------------------------------------- -! Based on micro_mg (restructuring of former cldwat2m_micro) -! 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 -!--------------------------------------------------------------------------------- -! Code comments added by HM, 093011 -! General code structure: -! -! Code is divided into two main subroutines: -! subroutine micro_mg_init --> initializes microphysics routine, should be called -! once at start of simulation -! subroutine micro_mg_tend --> main microphysics routine to be called each time step -! this also calls several smaller subroutines to calculate -! microphysical processes and other utilities -! -! List of external functions: -! qsat_water --> for calculating saturation vapor pressure with respect to liquid water -! qsat_ice --> for calculating saturation vapor pressure with respect to ice -! gamma --> standard mathematical gamma function -! ......................................................................... -! List of inputs through use statement in fortran90: -! Variable Name Description Units -! ......................................................................... -! gravit acceleration due to gravity m s-2 -! rair dry air gas constant for air J kg-1 K-1 -! tmelt temperature of melting point for water K -! cpair specific heat at constant pressure for dry air J kg-1 K-1 -! rh2o gas constant for water vapor J kg-1 K-1 -! latvap latent heat of vaporization J kg-1 -! latice latent heat of fusion J kg-1 -! qsat_water external function for calculating liquid water -! saturation vapor pressure/humidity - -! qsat_ice external function for calculating ice -! saturation vapor pressure/humidity pa -! rhmini relative humidity threshold parameter for -! nucleating ice - -! ......................................................................... -! NOTE: List of all inputs/outputs passed through the call/subroutine statement -! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. -!--------------------------------------------------------------------------------- - -! Procedures required: -! 1) An implementation of the gamma function (if not intrinsic). -! 2) saturation vapor pressure and specific humidity over water -! 3) svp over ice -use machine, only : r8 => kind_phys -use physcons, only : epsqs => con_eps, fv => con_fvirt -use funcphys, only : fpvsl, fpvsi - -!use wv_sat_methods, only: & -! qsat_water => wv_sat_qsat_water, & -! qsat_ice => wv_sat_qsat_ice - -! Parameters from the utilities module. -use micro_mg_utils, only : pi, omsm, qsmall, mincld, rhosn, rhoi, & - rhow, rhows, ac, bc, ai, bi, & - aj, bj, ar, br, as, bs, & - mi0, rising_factorial - -implicit none -private -save - -public :: micro_mg_init, micro_mg_tend, qcvar - -! Switches for specification rather than prediction of droplet and crystal number -! note: number will be adjusted as needed to keep mean size within bounds, -! even when specified droplet or ice number is used -! -! If constant cloud ice number is set (nicons = .true.), -! then all microphysical processes except mass transfer due to ice nucleation -! (mnuccd) are based on the fixed cloud ice number. Calculation of -! mnuccd follows from the prognosed ice crystal number ni. - -logical :: nccons ! nccons = .true. to specify constant cloud droplet number -logical :: nicons ! nicons = .true. to specify constant cloud ice number - -! specified ice and droplet number concentrations -! note: these are local in-cloud values, not grid-mean -real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3) -real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3) - -!========================================================= -! Private module parameters -!========================================================= - -!Range of cloudsat reflectivities (dBz) for analytic simulator -real(r8), parameter :: csmin = -30._r8 -real(r8), parameter :: csmax = 26._r8 -real(r8), parameter :: mindbz = -99._r8 -real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) - -! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs, ts_au, ts_au_min, qcvar - -! minimum mass of new crystal due to freezing of cloud droplets done -! externally (kg) -real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 -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, six=6._r8, half=0.5_r8, & - ten=10.0_r8, forty=40.0_r8, oneo6=one/six - -!========================================================= -! Constants set in initialization -!========================================================= - -! Set using arguments to micro_mg_init -real(r8) :: g ! gravity -real(r8) :: r ! dry air gas constant -real(r8) :: rv ! water vapor gas constant -real(r8) :: cpp ! specific heat of dry air -real(r8) :: tmelt ! freezing point of water (K) - -! latent heats of: -real(r8) :: xxlv ! vaporization -real(r8) :: xlf ! freezing -real(r8) :: xxls ! sublimation - -real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. - -! flags -logical :: microp_uniform, do_cldice, use_hetfrz_classnuc - -real(r8) :: rhosu ! typical 850mn air density - -real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C - -real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C -real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C - -! additional constants to help speed up code -real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1 -real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4 -real(r8) :: xxlv_squared, xxls_squared -real(r8) :: omeps - -character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method -real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor - -logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop -logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics -logical :: do_ice_gmao -logical :: do_liq_liu - -!=============================================================================== -contains -!=============================================================================== - -!>\ingroup mg2_0_mp -!! This subroutine calculates -subroutine micro_mg_init( & - kind, gravit, rair, rh2o, cpair, & - tmelt_in, latvap, latice, & - rhmini_in, micro_mg_dcs,ts_auto, mg_qcvar, & - microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & - micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & - allow_sed_supersat_in, do_sb_physics_in, & - do_ice_gmao_in, do_liq_liu_in, & - nccons_in, nicons_in, ncnst_in, ninst_in) - - use micro_mg_utils, only : micro_mg_utils_init - use wv_saturation, only : gestbl - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! initialize constants for MG microphysics - ! - ! Author: Andrew Gettelman Dec 2005 - ! - !----------------------------------------------------------------------- - - integer, intent(in) :: kind !< Kind used for reals - real(r8), intent(in) :: gravit - real(r8), intent(in) :: rair - real(r8), intent(in) :: rh2o - real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in !< Freezing point of water (K) - real(r8), intent(in) :: latvap - real(r8), intent(in) :: latice - real(r8), intent(in) :: rhmini_in !< Minimum rh for ice cloud fraction > 0. - real(r8), intent(in) :: micro_mg_dcs - real(r8), intent(in) :: ts_auto(2) - real(r8), intent(in) :: mg_qcvar - - logical, intent(in) :: microp_uniform_in !< .true. = configure uniform for sub-columns - !! .false. = use w/o sub-columns (standard) - logical, intent(in) :: do_cldice_in !< .true. = do all processes (standard) - !! .false. = skip all processes affecting cloud ice - logical, intent(in) :: use_hetfrz_classnuc_in !< use heterogeneous freezing - - character(len=16),intent(in) :: micro_mg_precip_frac_method_in !< type of precipitation fraction method - real(r8), intent(in) :: micro_mg_berg_eff_factor_in !< berg efficiency factor - logical, intent(in) :: allow_sed_supersat_in !< allow supersaturated conditions after sedimentation loop - logical, intent(in) :: do_sb_physics_in !< do SB autoconversion and accretion physics - logical, intent(in) :: do_ice_gmao_in - logical, intent(in) :: do_liq_liu_in - - logical, intent(in) :: nccons_in, nicons_in - real(r8), intent(in) :: ncnst_in, ninst_in - logical ip - real(r8):: tmn, tmx, trice - - - - !----------------------------------------------------------------------- - - dcs = micro_mg_dcs * 1.0e-6 - ts_au_min = ts_auto(1) - ts_au = ts_auto(2) - qcvar = mg_qcvar - - ! Initialize subordinate utilities module. - call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & - dcs) - - - ! declarations for MG code (transforms variable names) - - g = gravit ! gravity - r = rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) - rv = rh2o ! water vapor gas constant - cpp = cpair ! specific heat of dry air - tmelt = tmelt_in - rhmini = rhmini_in - micro_mg_precip_frac_method = micro_mg_precip_frac_method_in - micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in - allow_sed_supersat = allow_sed_supersat_in - do_sb_physics = do_sb_physics_in - do_ice_gmao = do_ice_gmao_in - do_liq_liu = do_liq_liu_in - - nccons = nccons_in - nicons = nicons_in - ncnst = ncnst_in - ninst = ninst_in - - ! latent heats - - xxlv = latvap ! latent heat vaporization - xlf = latice ! latent heat freezing - xxls = xxlv + xlf ! latent heat of sublimation - - ! flags - microp_uniform = microp_uniform_in - do_cldice = do_cldice_in - use_hetfrz_classnuc = use_hetfrz_classnuc_in - - ! typical air density at 850 mb - - rhosu = 85000._r8 / (rair * tmelt) - - ! Maximum temperature at which snow is allowed to exist - snowmelt = tmelt + two - ! Minimum temperature at which rain is allowed to exist - rainfrze = tmelt - forty - - ! Ice nucleation temperature - icenuct = tmelt - five - - ! Define constants to help speed up code (this limits calls to gamma function) - gamma_br_plus1 = gamma(br+one) - gamma_br_plus4 = gamma(br+four) - gamma_bs_plus1 = gamma(bs+one) - gamma_bs_plus4 = gamma(bs+four) - gamma_bi_plus1 = gamma(bi+one) - gamma_bi_plus4 = gamma(bi+four) - gamma_bj_plus1 = gamma(bj+one) - gamma_bj_plus4 = gamma(bj+four) - - xxlv_squared = xxlv * xxlv - xxls_squared = xxls * xxls - omeps = one - epsqs - tmn = 173.16_r8 - tmx = 375.16_r8 - trice = 35.00_r8 - ip = .true. - call gestbl(tmn ,tmx ,trice ,ip ,epsqs , latvap ,latice ,rh2o , & - cpair ,tmelt_in ) - - - -end subroutine micro_mg_init - -!=============================================================================== -!microphysics routine for each timestep goes here... - -!\ingroup mg2_0_mp -!> This subroutine is the main microphysics routine to be called each time step -!! -!! this also calls several smaller subroutines to calculate -!! microphysical processes and other utilities -subroutine micro_mg_tend ( & - mgncol, nlev, deltatin, & - t, q, & - qcn, qin, & - ncn, nin, & - qrn, qsn, & - nrn, nsn, & - relvar, accre_enhan_i, & - p, pdel, & - cldn, liqcldf, icecldf, qsatfac, & - qcsinksum_rate1ord, & - naai, npccnin, & - rndst, nacon, & - tlat, qvlat, & - qctend, qitend, & - nctend, nitend, & - qrtend, qstend, & - nrtend, nstend, & - effc, effc_fn, effi, & - sadice, sadsnow, & - prect, preci, & - nevapr, evapsnow, & - am_evp_st, & - prain, prodsnow, & - cmeout, deffi, & - pgamrad, lamcrad, & - qsout, dsout, & - lflx, iflx, & - rflx, sflx, qrout, & - reff_rain, reff_snow, & - qcsevap, qisevap, qvres, & - cmeitot, vtrmc, vtrmi, & - umr, ums, & - qcsedten, qisedten, & - qrsedten, qssedten, & - pratot, prctot, & - mnuccctot, mnuccttot, msacwitot, & - psacwstot, bergstot, bergtot, & - melttot, homotot, & - qcrestot, prcitot, praitot, & - qirestot, mnuccrtot, pracstot, & - meltsdttot, frzrdttot, mnuccdtot, & - nrout, nsout, & - refl, arefl, areflz, & - frefl, csrfl, acsrfl, & - fcsrfl, rercld, & - ncai, ncal, & - qrout2, qsout2, & - nrout2, nsout2, & - drout2, dsout2, & - freqs, freqr, & - nfice, qcrat, & - prer_evap, xlat, xlon, lprnt, iccn, nlball) - - ! Constituent properties. - use micro_mg_utils, only: mg_liq_props, & - mg_ice_props, & - mg_rain_props, & - mg_snow_props - - ! Size calculation functions. - use micro_mg_utils, only: size_dist_param_liq, & - size_dist_param_basic, & - avg_diameter - - ! Microphysical processes. - use micro_mg_utils, only: ice_deposition_sublimation, & - sb2001v2_liq_autoconversion, & - sb2001v2_accre_cld_water_rain, & - kk2000_liq_autoconversion, & - ice_autoconversion, & - immersion_freezing, & - contact_freezing, & - snow_self_aggregation, & - accrete_cloud_water_snow, & - secondary_ice_production, & - accrete_rain_snow, & - heterogeneous_rain_freezing, & - accrete_cloud_water_rain, & - self_collection_rain, & - accrete_cloud_ice_snow, & - evaporate_sublimate_precip, & - bergeron_process_snow, & - liu_liq_autoconversion, & - gmao_ice_autoconversion, & - size_dist_param_ice - - !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - - ! input arguments - integer, intent(in) :: mgncol ! number of microphysics columns - integer, intent(in) :: nlev ! number of layers - integer, intent(in) :: nlball(mgncol) ! sedimentation start level - real(r8), intent(in) :: xlat,xlon ! number of layers - real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) - real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) - - ! note: all input cloud variables are grid-averaged - real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg) - real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) - real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg) - real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg) - - real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg) - real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg) - real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg) - - real(r8) :: relvar(mgncol,nlev) ! cloud water relative variance (-) - real(r8) :: accre_enhan(mgncol,nlev)! optional accretion -! real(r8), intent(in) :: relvar_i ! cloud water relative variance (-) - real(r8), intent(in) :: accre_enhan_i ! optional accretion - ! enhancement factor (-) - - real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa) - real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa) - - real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units) - real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) - real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) - real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) - logical, intent(in) :: lprnt - integer, intent(in) :: iccn - - - ! used for scavenging - ! Inputs for aerosol activation - real(r8), intent(inout) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) - real(r8), intent(in) :: npccnin(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) -! real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - real(r8) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - - ! Note that for these variables, the dust bin is assumed to be the last index. - ! (For example, in CAM, the last dimension is always size 4.) - real(r8), intent(in) :: rndst(mgncol,nlev,10) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) - real(r8), intent(in) :: nacon(mgncol,nlev,10) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - - ! output arguments - - real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for - ! direct cw to precip conversion - real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) - real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) - real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) - real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) - real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) - real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) - - real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s) - real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s) - real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s)) - real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s)) - real(r8), intent(out) :: effc(mgncol,nlev) ! droplet effective radius (micron) - real(r8), intent(out) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 - real(r8), intent(out) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) - real(r8), intent(out) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3) - real(r8), intent(out) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3) - real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s) - real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) - real(r8), intent(out) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) - real(r8), intent(out) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) - real(r8), intent(out) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac) - real(r8), intent(out) :: prain(mgncol,nlev) ! production of rain + snow (1/s) - real(r8), intent(out) :: prodsnow(mgncol,nlev) ! production of snow (1/s) - real(r8), intent(out) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) - real(r8), intent(out) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) - real(r8), intent(out) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) - real(r8), intent(out) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) - real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8), intent(out) :: dsout(mgncol,nlev) ! snow diameter (m) - real(r8), intent(out) :: lflx(mgncol,2:nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: iflx(mgncol,2:nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: rflx(mgncol,2:nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8), intent(out) :: sflx(mgncol,2:nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) - real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) - real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) - real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) - real(r8), intent(out) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) - real(r8), intent(out) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sedimentation (1/s) - real(r8), intent(out) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) - real(r8), intent(out) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) - real(r8), intent(out) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) - real(r8), intent(out) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) - real(r8), intent(out) :: umr(mgncol,nlev) ! mass weighted rain fallspeed (m/s) - real(r8), intent(out) :: ums(mgncol,nlev) ! mass weighted snow fallspeed (m/s) - real(r8), intent(out) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) - real(r8), intent(out) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) - real(r8), intent(out) :: qrsedten(mgncol,nlev) ! qr sedimentation tendency (1/s) - real(r8), intent(out) :: qssedten(mgncol,nlev) ! qs sedimentation tendency (1/s) - - ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) - real(r8), intent(out) :: pratot(mgncol,nlev) ! accretion of cloud by rain - real(r8), intent(out) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain - real(r8), intent(out) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing - real(r8), intent(out) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing - real(r8), intent(out) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering - real(r8), intent(out) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow - real(r8), intent(out) :: bergstot(mgncol,nlev) ! bergeron process on snow - real(r8), intent(out) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice - real(r8), intent(out) :: melttot(mgncol,nlev) ! melting of cloud ice - real(r8), intent(out) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water - real(r8), intent(out) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat - real(r8), intent(out) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow - real(r8), intent(out) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow - real(r8), intent(out) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat - real(r8), intent(out) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - real(r8), intent(out) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) - real(r8), intent(out) :: meltsdttot(mgncol,nlev)! latent heating rate due to melting of snow (W/kg) - real(r8), intent(out) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) - real(r8), intent(out) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation - real(r8), intent(out) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) - real(r8), intent(out) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) - real(r8), intent(out) :: refl(mgncol,nlev) ! analytic radar reflectivity - real(r8), intent(out) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range - real(r8), intent(out) :: areflz(mgncol,nlev) ! average reflectivity in z. - real(r8), intent(out) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity - real(r8), intent(out) :: csrfl(mgncol,nlev) ! cloudsat reflectivity - real(r8), intent(out) :: acsrfl(mgncol,nlev) ! cloudsat average - real(r8), intent(out) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity - real(r8), intent(out) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud - real(r8), intent(out) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) - real(r8), intent(out) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) - real(r8), intent(out) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 - real(r8), intent(out) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 - real(r8), intent(out) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 - real(r8), intent(out) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 - real(r8), intent(out) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) - real(r8), intent(out) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) - real(r8), intent(out) :: freqs(mgncol,nlev) ! fractional occurrence of snow - real(r8), intent(out) :: freqr(mgncol,nlev) ! fractional occurrence of rain - real(r8), intent(out) :: nfice(mgncol,nlev) ! fractional occurrence of ice - real(r8), intent(out) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc) - - real(r8), intent(out) :: prer_evap(mgncol,nlev) - - - ! Tendencies calculated by external schemes that can replace MG's native - ! process tendencies. - - ! Used with CARMA cirrus microphysics - ! (or similar external microphysics model) - ! real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) - ! real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) - ! real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m) - - ! From external ice nucleation. - !real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) - !real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) - !real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) - - ! local workspace - ! all units mks unless otherwise stated - - ! local copies of input variables - real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) - real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) - real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) - real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) - real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) - real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) - real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) - - ! general purpose variables - real(r8) :: deltat ! sub-time step (s) - real(r8) :: oneodt ! one / deltat - real(r8) :: mtime ! the assumed ice nucleation timescale - - ! physical properties of the air at a given point - real(r8) :: rho(mgncol,nlev) ! density (kg m-3) - real(r8) :: rhoinv(mgncol,nlev) ! one / density (kg m-3) - real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor - real(r8) :: mu(mgncol,nlev) ! viscosity - real(r8) :: sc(mgncol,nlev) ! schmidt number - real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed - - ! cloud fractions - real(r8) :: precip_frac(mgncol,nlev)! precip fraction assuming maximum overlap - real(r8) :: cldm(mgncol,nlev) ! cloud fraction - real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction - real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction - real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor - - ! mass mixing ratios - real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid - real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: qsic(mgncol,nlev) ! in-precip snow - real(r8) :: qric(mgncol,nlev) ! in-precip rain - - ! number concentrations - real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet - real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: nsic(mgncol,nlev) ! in-precip snow - real(r8) :: nric(mgncol,nlev) ! in-precip rain - ! maximum allowed ni value - real(r8) :: nimax(mgncol,nlev) - - ! Size distribution parameters for: - ! cloud ice - real(r8) :: lami(mgncol,nlev) ! slope - real(r8) :: n0i(mgncol,nlev) ! intercept - ! cloud liquid - real(r8) :: lamc(mgncol,nlev) ! slope - real(r8) :: pgam(mgncol,nlev) ! spectral width parameter - ! snow - real(r8) :: lams(mgncol,nlev) ! slope - real(r8) :: n0s(mgncol,nlev) ! intercept - ! rain - real(r8) :: lamr(mgncol,nlev) ! slope - real(r8) :: n0r(mgncol,nlev) ! intercept - - ! Rates/tendencies due to: - - ! Instantaneous snow melting - real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstsm(mgncol,nlev) ! number concentration - ! Instantaneous rain freezing - real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstrf(mgncol,nlev) ! number concentration - - ! deposition of cloud ice - real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 - ! sublimation of cloud ice - real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 - ! ice nucleation - real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing - real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio - ! freezing of cloud water - real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccc(mgncol,nlev) ! number concentration - ! contact freezing of cloud water - real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnucct(mgncol,nlev) ! number concentration - ! deposition nucleation in mixed-phase clouds (from external scheme) - real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnudep(mgncol,nlev) ! number concentration - ! ice multiplication - real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio - real(r8) :: nsacwi(mgncol,nlev) ! number concentration - ! autoconversion of cloud droplets - real(r8) :: prc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) - real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) - ! self-aggregation of snow - real(r8) :: nsagg(mgncol,nlev) ! number concentration - ! self-collection of rain - real(r8) :: nragg(mgncol,nlev) ! number concentration - ! collection of droplets by snow - real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio - real(r8) :: npsacws(mgncol,nlev) ! number concentration - ! collection of rain by snow - real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio - real(r8) :: npracs(mgncol,nlev) ! number concentration - ! freezing of rain - real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccr(mgncol,nlev) ! number concentration - ! freezing of rain to form ice (mg add 4/26/13) - real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccri(mgncol,nlev) ! number concentration - ! accretion of droplets by rain - real(r8) :: pra(mgncol,nlev) ! mass mixing ratio - real(r8) :: npra(mgncol,nlev) ! number concentration - ! autoconversion of cloud ice to snow - real(r8) :: prci(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprci(mgncol,nlev) ! number concentration - ! accretion of cloud ice by snow - real(r8) :: prai(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprai(mgncol,nlev) ! number concentration - ! evaporation of rain - real(r8) :: pre(mgncol,nlev) ! mass mixing ratio - ! sublimation of snow - real(r8) :: prds(mgncol,nlev) ! mass mixing ratio - ! number evaporation - real(r8) :: nsubi(mgncol,nlev) ! cloud ice - real(r8) :: nsubc(mgncol,nlev) ! droplet - real(r8) :: nsubs(mgncol,nlev) ! snow - real(r8) :: nsubr(mgncol,nlev) ! rain - ! bergeron process - real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) - real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) - - - ! fallspeeds - ! number-weighted - real(r8) :: uns(mgncol,nlev) ! snow - real(r8) :: unr(mgncol,nlev) ! rain - ! air density corrected fallspeed parameters - real(r8) :: arn(mgncol,nlev) ! rain - real(r8) :: asn(mgncol,nlev) ! snow - real(r8) :: acn(mgncol,nlev) ! cloud droplet - real(r8) :: ain(mgncol,nlev) ! cloud ice - real(r8) :: ajn(mgncol,nlev) ! cloud small ice - - ! Mass of liquid droplets used with external heterogeneous freezing. - real(r8) :: mi0l(mgncol) - - ! saturation vapor pressures - real(r8) :: esl(mgncol,nlev) ! liquid - real(r8) :: esi(mgncol,nlev) ! ice - real(r8) :: esn ! checking for RH after rain evap - - ! saturation vapor mixing ratios - real(r8) :: qvl(mgncol,nlev) ! liquid - real(r8) :: qvi(mgncol,nlev) ! ice - real(r8) :: qvn ! checking for RH after rain evap - - ! relative humidity - real(r8) :: relhum(mgncol,nlev) - - ! parameters for cloud water and cloud ice sedimentation calculations - real(r8) :: fc(mgncol,nlev) - real(r8) :: fnc(mgncol,nlev) - real(r8) :: fi(mgncol,nlev) - real(r8) :: fni(mgncol,nlev) - - real(r8) :: fr(mgncol,nlev) - real(r8) :: fnr(mgncol,nlev) - real(r8) :: fs(mgncol,nlev) - real(r8) :: fns(mgncol,nlev) - - real(r8) :: faloutc(nlev) - real(r8) :: faloutnc(nlev) - real(r8) :: falouti(nlev) - real(r8) :: faloutni(nlev) - - real(r8) :: faloutr(nlev) - real(r8) :: faloutnr(nlev) - real(r8) :: falouts(nlev) - real(r8) :: faloutns(nlev) - - real(r8) :: faltndc - real(r8) :: faltndnc - real(r8) :: faltndi - real(r8) :: faltndni - real(r8) :: faltndqie - real(r8) :: faltndqce - - real(r8) :: faltndr - real(r8) :: faltndnr - real(r8) :: faltnds - real(r8) :: faltndns - - real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation - - ! dummy variables - real(r8) :: dum - real(r8) :: dum1 - real(r8) :: dum2 - real(r8) :: dum3 - real(r8) :: dumni0 - real(r8) :: dumns0 - real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho - ! dummies for checking RH - real(r8) :: qtmp - real(r8) :: ttmp - ! dummies for conservation check - real(r8) :: ratio - real(r8) :: tmpfrz - ! dummies for in-cloud variables - real(r8) :: dumc(mgncol,nlev) ! qc - real(r8) :: dumnc(mgncol,nlev) ! nc - real(r8) :: dumi(mgncol,nlev) ! qi - real(r8) :: dumni(mgncol,nlev) ! ni - real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio - real(r8) :: dumnr(mgncol,nlev) ! rain number concentration - real(r8) :: dums(mgncol,nlev) ! snow mixing ratio - real(r8) :: dumns(mgncol,nlev) ! snow number concentration - ! Array dummy variable - !real(r8) :: dum_2D(mgncol,nlev) - real(r8) :: pdel_inv(mgncol,nlev) - real(r8) :: ts_au_loc(mgncol) - - ! loop array variables - ! "i" and "k" are column/level iterators for internal (MG) variables - ! "n" is used for other looping (currently just sedimentation) - integer i, k, n - - ! number of sub-steps for loops over "n" (for sedimentation) - integer nstep, mdust, nlb, nstep_def - - ! Varaibles to scale fall velocity between small and regular ice regimes. - real(r8) :: irad, ifrac, tsfac -! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. -! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. -! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. - real(r8), parameter :: qimax=0.010, qimin=0.005, qiinv=one/(qimax-qimin) -! ts_au_min=180.0 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - - ! Process inputs - - ! assign variable deltat to deltatin - deltat = deltatin - oneodt = one / deltat -! nstep_def = max(1, nint(deltat/20)) - nstep_def = max(1, nint(deltat/5)) -! tsfac = log(ts_au/ts_au_min) * qiinv - - ! Copies of input concentrations that may be changed internally. - do k=1,nlev - do i=1,mgncol - qc(i,k) = qcn(i,k) - nc(i,k) = ncn(i,k) - qi(i,k) = qin(i,k) - ni(i,k) = nin(i,k) - qr(i,k) = qrn(i,k) - nr(i,k) = nrn(i,k) - qs(i,k) = qsn(i,k) - ns(i,k) = nsn(i,k) - enddo - enddo - - ! cldn: used to set cldm, unused for subcolumns - ! liqcldf: used to set lcldm, unused for subcolumns - ! icecldf: used to set icldm, unused for subcolumns - - if (microp_uniform) then - ! subcolumns, set cloud fraction variables to one - ! if cloud water or ice is present, if not present - ! set to mincld (mincld used instead of zero, to prevent - ! possible division by zero errors). - - do k=1,nlev - do i=1,mgncol - - if (qc(i,k) >= qsmall) then - lcldm(i,k) = one - else - lcldm(i,k) = mincld - endif - - if (qi(i,k) >= qsmall) then - icldm(i,k) = one - else - icldm(i,k) = mincld - endif - - cldm(i,k) = max(icldm(i,k), lcldm(i,k)) -! qsfm(i,k) = one - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - - else ! get cloud fraction, check for minimum - do k=1,nlev - do i=1,mgncol - cldm(i,k) = max(cldn(i,k), mincld) - lcldm(i,k) = max(liqcldf(i,k), mincld) - icldm(i,k) = max(icecldf(i,k), mincld) - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - end if - -! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' lcldm=',lcldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icecldf=',icecldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icldm=',icldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' qsfm=',qsfm(1,nlev-20:nlev) - - ! Initialize local variables - - ! local physical properties - do k=1,nlev - do i=1,mgncol -! rho(i,k) = p(i,k) / (r*t(i,k)*(one+fv*q(i,k))) - rho(i,k) = p(i,k) / (r*t(i,k)) - rhoinv(i,k) = one / rho(i,k) - dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k) - mu(i,k) = 1.496E-6_r8 * t(i,k)*sqrt(t(i,k)) / (t(i,k) + 120._r8) - sc(i,k) = mu(i,k) / (rho(i,k)*dv(i,k)) - - ! 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*rhoinv(i,k))**0.54_r8 - - arn(i,k) = ar*rhof(i,k) - asn(i,k) = as*rhof(i,k) - acn(i,k) = g*rhow/(18._r8*mu(i,k)) - tx1 = (rhosu*rhoinv(i,k))**0.35_r8 - ain(i,k) = ai*tx1 - ajn(i,k) = aj*tx1 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Get humidity and saturation vapor pressures - -! do k=1,nlev -! do i=1,mgncol -! relvar(i,k) = relvar_i - accre_enhan(i,k) = accre_enhan_i -! call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) - esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) - qvl(i,k) = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) - - - ! make sure when above freezing that esi=esl, not active yet - if (t(i,k) >= tmelt) then - esi(i,k) = esl(i,k) - qvi(i,k) = qvl(i,k) - else -! call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) - esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) - qvi(i,k) = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) - end if - - ! Scale the water saturation values to reflect subgrid scale - ! ice cloud fraction, where ice clouds begin forming at a - ! gridbox average relative humidity of rhmini (not 1). - ! - ! NOTE: For subcolumns and other non-subgrid clouds, qsfm will be 1. - qvi(i,k) = qsfm(i,k) * qvi(i,k) -! esi(i,k) = qsfm(i,k) * esi(i,k) - qvl(i,k) = qsfm(i,k) * qvl(i,k) -! esl(i,k) = qsfm(i,k) * esl(i,k) - - relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) - end do - end do - - - !=============================================== - - ! set mtime here to avoid answer-changing - mtime = deltat - - ! initialize microphysics output - do k=1,nlev - do i=1,mgncol - qcsevap(i,k) = zero - qisevap(i,k) = zero - qvres(i,k) = zero - cmeitot(i,k) = zero - vtrmc(i,k) = zero - vtrmi(i,k) = zero - qcsedten(i,k) = zero - qisedten(i,k) = zero - qrsedten(i,k) = zero - qssedten(i,k) = zero - - pratot(i,k) = zero - prctot(i,k) = zero - mnuccctot(i,k) = zero - mnuccttot(i,k) = zero - msacwitot(i,k) = zero - psacwstot(i,k) = zero - bergstot(i,k) = zero - bergtot(i,k) = zero - melttot(i,k) = zero - homotot(i,k) = zero - qcrestot(i,k) = zero - prcitot(i,k) = zero - praitot(i,k) = zero - qirestot(i,k) = zero - mnuccrtot(i,k) = zero - pracstot(i,k) = zero - meltsdttot(i,k) = zero - frzrdttot(i,k) = zero - mnuccdtot(i,k) = zero - - rflx(i,k+1) = zero - sflx(i,k+1) = zero - lflx(i,k+1) = zero - iflx(i,k+1) = zero - - ! initialize precip output - - qrout(i,k) = zero - qsout(i,k) = zero - nrout(i,k) = zero - nsout(i,k) = zero - - ! for refl calc - rainrt(i,k) = zero - - ! initialize rain size - rercld(i,k) = zero - - qcsinksum_rate1ord(i,k) = zero - - ! initialize variables for trop_mozart - nevapr(i,k) = zero - prer_evap(i,k) = zero - evapsnow(i,k) = zero - am_evp_st(i,k) = zero - prain(i,k) = zero - prodsnow(i,k) = zero - cmeout(i,k) = zero - - precip_frac(i,k) = mincld - - lamc(i,k) = zero - - ! initialize microphysical tendencies - - tlat(i,k) = zero - qvlat(i,k) = zero - qctend(i,k) = zero - qitend(i,k) = zero - qstend(i,k) = zero - qrtend(i,k) = zero - nctend(i,k) = zero - nitend(i,k) = zero - nrtend(i,k) = zero - nstend(i,k) = zero - - ! initialize in-cloud and in-precip quantities to zero - qcic(i,k) = zero - qiic(i,k) = zero - qsic(i,k) = zero - qric(i,k) = zero - - ncic(i,k) = zero - niic(i,k) = zero - nsic(i,k) = zero - nric(i,k) = zero - - ! initialize precip fallspeeds to zero - ums(i,k) = zero - uns(i,k) = zero - umr(i,k) = zero - unr(i,k) = zero - - ! initialize limiter for output - qcrat(i,k) = one - - ! Many outputs have to be initialized here at the top to work around - ! ifort problems, even if they are always overwritten later. - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - effi(i,k) = 25._r8 - sadice(i,k) = zero - sadsnow(i,k) = zero - deffi(i,k) = 50._r8 - - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout(i,k) = zero - dsout2(i,k) = zero - - freqr(i,k) = zero - freqs(i,k) = zero - - reff_rain(i,k) = zero - reff_snow(i,k) = zero - - refl(i,k) = -9999._r8 - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - csrfl(i,k) = zero - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - - ncal(i,k) = zero - ncai(i,k) = zero - - nfice(i,k) = zero - npccn(i,k) = zero - enddo - enddo - - if(iccn == 1) then - do k=1,nlev - do i=1,mgncol - npccn(i,k) = npccnin(i,k) - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) - enddo - enddo - endif - ! initialize precip at surface - - do i=1,mgncol - prect(i) = zero - preci(i) = zero - enddo - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! droplet activation - ! 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 (npccn) is read in from companion routine - - ! output activated liquid and ice (convert from #/kg -> #/m3) - !-------------------------------------------------- - where (qc >= qsmall) - npccn = max((npccnin*lcldm-nc)*oneodt, zero) - nc = max(nc + npccn*deltat, zero) - ncal = nc*rho/lcldm ! sghan minimum in #/cm3 - elsewhere - ncal = zero - end where - - if (iccn == 1) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 -! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half - ncai(i,k) = naai(i,k)*rho(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - elseif (iccn == 2) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = naai(i,k)*rho(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = ncai(i,k)*rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - do k=1,nlev - do i=1,mgncol - naai(i,k) = zero - ncai(i,k) = zero - enddo - enddo - endif - - - !=============================================== - - ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% - ! - ! NOTE: If using gridbox average values, condensation will not occur until rh=1, - ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid - ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus - ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. - - !------------------------------------------------------- - - if (do_cldice) then - where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8) - - !if NAAI > 0. then set numice = naai (as before) - !note: this is gridbox averaged - nnuccd = (naai-ni/icldm)/mtime*icldm - nnuccd = max(nnuccd, zero) - nimax = naai*icldm - - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - - mnuccd = nnuccd * mi0 - - elsewhere - nnuccd = zero - nimax = zero - mnuccd = zero - end where - - end if - - - !============================================================================= - do k=1,nlev - - do i=1,mgncol - - ! calculate instantaneous precip processes (melting and homogeneous freezing) - - ! melting of snow at +2 C - - if (t(i,k) > snowmelt) then - if (qs(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * qs(i,k) - if (t(i,k)+dum < snowmelt) then - dum = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) - else - dum = one - end if - - minstsm(i,k) = dum*qs(i,k) - ninstsm(i,k) = dum*ns(i,k) - - dum1 = - minstsm(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - - qs(i,k) = max(qs(i,k) - minstsm(i,k), zero) - ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) - qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) - nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) - end if - end if - - end do - end do -! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat - - do k=1,nlev - do i=1,mgncol - ! freezing of rain at -5 C - - if (t(i,k) < rainfrze) then - - if (qr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * qr(i,k) - if (t(i,k)+dum > rainfrze) then - dum = -(t(i,k)-rainfrze) * (cpp/xlf) - dum = min(one, max(zero, dum/qr(i,k))) - else - dum = one - end if - - minstrf(i,k) = dum*qr(i,k) - ninstrf(i,k) = dum*nr(i,k) - - ! heating tendency - dum1 = minstrf(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - frzrdttot(i,k) = frzrdttot(i,k) + dum1 - - qr(i,k) = max(qr(i,k) - minstrf(i,k), zero) - nr(i,k) = max(nr(i,k) - ninstrf(i,k), zero) - qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) - ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) - - end if - end if - end do - end do - -! if (lprnt) write(0,*)' tlat2=',tlat(1,:)*deltat - do k=1,nlev - do i=1,mgncol - ! 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 - - if (qc(i,k) >= qsmall) then - dum = one / lcldm(i,k) -! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - ncic(i,k) = max(nc(i,k)*dum, zero) - - ! specify droplet concentration - if (nccons) then - ncic(i,k) = ncnst * rhoinv(i,k) - end if - else - qcic(i,k) = zero - ncic(i,k) = zero - end if - - if (qi(i,k) >= qsmall) then - dum = one / icldm(i,k) -! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - niic(i,k) = max(ni(i,k)*dum, zero) - - ! switch for specification of cloud ice number - if (nicons) then - niic(i,k) = ninst * rhoinv(i,k) - end if - else - qiic(i,k) = zero - niic(i,k) = zero - end if - - end do - end do - - !======================================================================== - - ! for sub-columns cldm has already been set to 1 if cloud - ! water or ice is present, so precip_frac will be correctly set below - ! and nothing extra needs to be done here - - precip_frac = cldm - - micro_vert_loop: do k=1,nlev - - if (trim(micro_mg_precip_frac_method) == 'in_cloud') then - - if (k /= 1) then - where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) - precip_frac(:,k) = precip_frac(:,k-1) - end where - endif - - else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then - - ! calculate precip fraction based on maximum overlap assumption - - ! if rain or snow mix ratios are smaller than threshold, - ! then leave precip_frac as cloud fraction at current level - if (k /= 1) then - where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) - precip_frac(:,k) = max(precip_frac(:,k-1),precip_frac(:,k)) - end where - end if - - endif - - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get size distribution parameters based on in-cloud cloud water - ! these calculations also ensure consistency between number and mixing ratio - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! cloud liquid - !------------------------------------------- - - call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) - - - !======================================================================== - ! 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 - - if (.not. do_sb_physics) then - call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & - ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) - endif - - ! assign qric based on prognostic qr, using assumed precip fraction - ! note: this could be moved above for consistency with qcic and qiic calculations - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg - qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - nric(i,k) = nr(i,k) * dum - - - ! add autoconversion to precip from above to get provisional rain mixing ratio - ! and number concentration (qric and nric) - - if(qric(i,k) < qsmall) then - qric(i,k) = zero - nric(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nric(i,k) = max(nric(i,k),zero) - enddo - ! Get size distribution parameters for cloud ice - - call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & - lami(:,k), mgncol, n0=n0i(:,k)) - -! call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & -! lami(:,k), mgncol, n0=n0i(:,k)) - - ! Alternative autoconversion - if (do_sb_physics) then - if (do_liq_liu) then - call liu_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k),mgncol) - else - call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) - endif - endif - - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - if (do_cldice) then - do i=1,mgncol - if (qiic(i,k) >= qimax) then -! if (qi(i,k) >= qimax) then - ts_au_loc(i) = ts_au_min - elseif (qiic(i,k) <= qimin) then -! elseif (qi(i,k) <= qimin) then - ts_au_loc(i) = ts_au - else -! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv - ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv -! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) - endif - enddo - - if(do_ice_gmao) then - call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & - n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - else - call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & - dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - end if - !else - ! Add in the particles that we have already converted to snow, and - ! don't do any further autoconversion of ice. - !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) - !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) - end if - - ! note, currently we don't have this - ! inside the do_cldice block, should be changed later - ! assign qsic based on prognostic qs, using assumed precip fraction - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg -! qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - qsic(i,k) = min(qs(i,k)*dum, 0.10_r8) ! limit in-precip mixing ratios to 50 g/kg - nsic(i,k) = ns(i,k) * dum - - ! if precip mix ratio is zero so should number concentration - - if(qsic(i,k) < qsmall) then - qsic(i,k) = zero - nsic(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nsic(i,k) = max(nsic(i,k), zero) - enddo - - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & - lamr(:,k), mgncol, n0=n0r(:,k)) - - do i=1,mgncol - if (lamr(i,k) >= qsmall) then - dum = arn(i,k) / lamr(i,k)**br - dum1 = 9.1_r8*rhof(i,k) - - ! provisional rain number and mass weighted mean fallspeed (m/s) - - umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) - unr(i,k) = min(dum1, dum*gamma_br_plus1) - else - - umr(i,k) = zero - unr(i,k) = zero - endif - enddo - - !...................................................................... - ! snow - - call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & - lams(:,k), mgncol, n0=n0s(:,k)) - - do i=1,mgncol - if (lams(i,k) >= qsmall) then - - ! provisional snow number and mass weighted mean fallspeed (m/s) - - dum = asn(i,k) / lams(i,k)**bs - dum1 = 1.2_r8*rhof(i,k) - ums(i,k) = min(dum1, dum*gamma_bs_plus4*oneo6) - uns(i,k) = min(dum1, dum*gamma_bs_plus1) - - else - ums(i,k) = zero - uns(i,k) = zero - endif - enddo - - if (do_cldice) then - if (.not. use_hetfrz_classnuc) then - - ! heterogeneous freezing of cloud water - !---------------------------------------------- - - call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & - qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) - - ! make sure number of droplets frozen does not exceed available ice nuclei concentration - ! this prevents 'runaway' droplet freezing - - where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8) - where (nnuccc(:,k)*lcldm(:,k) > nnuccd(:,k)) - ! scale mixing ratio of droplet freezing with limit - mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) - nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) - end where - end where - - mdust = size(rndst,3) - call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & - nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & - relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) - - mnudep(:,k) = zero - nnudep(:,k) = zero - - !else - - ! Mass of droplets frozen is the average droplet mass, except - ! with two limiters: concentration must be at least 1/cm^3, and - ! mass must be at least the minimum defined above. - !mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) - !mi0l = max(mi0l_min, mi0l) - - !where (qcic(:,k) >= qsmall) - !nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) - !mnuccc(:,k) = nnuccc(:,k)*mi0l - - !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) - !mnucct(:,k) = nnucct(:,k)*mi0l - - !nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) - !mnudep(:,k) = nnudep(:,k)*mi0 - !elsewhere - !nnuccc(:,k) = 0._r8 - !mnuccc(:,k) = 0._r8 - - !nnucct(:,k) = 0._r8 - !mnucct(:,k) = 0._r8 - - !nnudep(:,k) = 0._r8 - !mnudep(:,k) = 0._r8 - !end where - - end if - - else - do i=1,mgncol - mnuccc(i,k) = zero - nnuccc(i,k) = zero - mnucct(i,k) = zero - nnucct(i,k) = zero - mnudep(i,k) = zero - nnudep(i,k) = zero - enddo - end if - - call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & - nsagg(:,k), mgncol) - - call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & - qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & - psacws(:,k), npsacws(:,k), mgncol) - - if (do_cldice) then - call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) - else - nsacwi(:,k) = zero - msacwi(:,k) = zero - end if - - call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pracs(:,k), npracs(:,k), mgncol) - - call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & - mnuccr(:,k), nnuccr(:,k), mgncol) - - if (do_sb_physics) then - call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & - rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) - else - call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & - ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) - endif - - call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) - - if (do_cldice) then - call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & - qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) - else - prai(:,k) = zero - nprai(:,k) = zero - end if - - call evaporate_sublimate_precip(t(:,k), rho(:,k), & - dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & - lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) - - call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & - qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & - bergs(:,k), mgncol) - - bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor - - !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! - if (do_cldice) then - - call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & - icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & - berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) - - do i=1,mgncol -! sublimation should not exceed available ice - ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) - - berg(i,k) = berg(i,k)*micro_mg_berg_eff_factor - - if (vap_dep(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then - nsubi(i,k) = vap_dep(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) - else - nsubi(i,k) = zero - endif - - ! bergeron process should not reduce nc unless - ! all ql is removed (which is handled elsewhere) - !in fact, nothing in this entire file makes nsubc nonzero. - - nsubc(i,k) = zero - enddo - - end if !do_cldice - !---PMC 12/3/12 - - do i=1,mgncol - - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - !=================================================================== - - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - - ! conservation of qc - !------------------------------------------------------------------- - - dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & - psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat - - if (dum > qc(i,k)) then - ratio = qc(i,k) / dum * omsm - - prc(i,k) = ratio * prc(i,k) - pra(i,k) = ratio * pra(i,k) - mnuccc(i,k) = ratio * mnuccc(i,k) - mnucct(i,k) = ratio * mnucct(i,k) - msacwi(i,k) = ratio * msacwi(i,k) - psacws(i,k) = ratio * psacws(i,k) - bergs(i,k) = ratio * bergs(i,k) - berg(i,k) = ratio * berg(i,k) - qcrat(i,k) = ratio - else - qcrat(i,k) = one - end if - - !PMC 12/3/12: ratio is also frac of step w/ liquid. - !thus we apply berg for "ratio" of timestep and vapor - !deposition for the remaining frac of the timestep. - if (qc(i,k) >= qsmall) then - vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) - end if - - end do - - do i=1,mgncol - - !================================================================= - ! apply limiter to ensure that ice/snow sublimation and rain evap - ! don't push conditions into supersaturation, and ice deposition/nucleation don't - ! push conditions into sub-saturation - ! note this is done after qc conservation since we don't know how large - ! vap_dep is before then - ! estimates are only approximate since other process terms haven't been limited - ! for conservation yet - - ! first limit ice deposition/nucleation vap_dep + mnuccd - - dum1 = vap_dep(i,k) + mnuccd(i,k) - if (dum1 > 1.e-20_r8) then - dum = (q(i,k)-qvi(i,k))/(one + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)*t(i,k)))*oneodt - dum = max(dum, zero) - if (dum1 > dum) then - ! Allocate the limited "dum" tendency to mnuccd and vap_dep - ! processes. Don't divide by cloud fraction; these are grid- - ! mean rates. - dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) - mnuccd(i,k) = dum*dum1 - vap_dep(i,k) = dum - mnuccd(i,k) - end if - end if - - end do - - do i=1,mgncol - - !=================================================================== - ! conservation of nc - !------------------------------------------------------------------- - dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & - npsacws(i,k)-nsubc(i,k))*lcldm(i,k) * deltat - - if (dum > nc(i,k)) then - ratio = nc(i,k) / dum * omsm - - nprc1(i,k) = ratio * nprc1(i,k) - npra(i,k) = ratio * npra(i,k) - nnuccc(i,k) = ratio * nnuccc(i,k) - nnucct(i,k) = ratio * nnucct(i,k) - npsacws(i,k) = ratio * npsacws(i,k) - nsubc(i,k) = ratio * nsubc(i,k) - end if - - mnuccri(i,k) = zero - nnuccri(i,k) = zero - - if (do_cldice) then - - ! freezing of rain to produce ice if mean rain size is smaller than Dcs - if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = zero - nnuccr(i,k) = zero - end if - end if - - end do - - do i=1,mgncol - - ! conservation of rain mixing ratio - !------------------------------------------------------------------- - dum1 = -pre(i,k) + pracs(i,k) + mnuccr(i,k) + mnuccri(i,k) - dum3 = dum1 * precip_frac(i,k) - dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) - dum = (dum3 - dum2) * deltat - - ! note that qrtend is included below because of instantaneous freezing/melt - if (dum > qr(i,k) .and. dum1 >= qsmall) then - ratio = (qr(i,k)*oneodt + dum2) / dum3 * omsm - pre(i,k) = ratio * pre(i,k) - pracs(i,k) = ratio * pracs(i,k) - mnuccr(i,k) = ratio * mnuccr(i,k) - mnuccri(i,k) = ratio * mnuccri(i,k) - end if - - end do - - do i=1,mgncol - - ! conservation of rain number - !------------------------------------------------------------------- - - ! Add evaporation of rain number. - if (pre(i,k) < zero) then - dum = max(-one, pre(i,k)*deltat/qr(i,k)) - nsubr(i,k) = dum*nr(i,k) * oneodt - else - nsubr(i,k) = zero - end if - - end do - - do i=1,mgncol - - dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) - dum2 = nprc(i,k)*lcldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > nr(i,k)) then - ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm - - nragg(i,k) = ratio * nragg(i,k) - npracs(i,k) = ratio * npracs(i,k) - nnuccr(i,k) = ratio * nnuccr(i,k) - nsubr(i,k) = ratio * nsubr(i,k) - nnuccri(i,k) = ratio * nnuccri(i,k) - end if - - end do - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of qi - !------------------------------------------------------------------- - - dum1 = (prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k) - dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & - + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k) & - + mnuccri(i,k)*precip_frac(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > qi(i,k)) then - ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm - - prci(i,k) = ratio * prci(i,k) - prai(i,k) = ratio * prai(i,k) - ice_sublim(i,k) = ratio * ice_sublim(i,k) - end if - - end do - - end if - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of ni - !------------------------------------------------------------------- - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if - dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) - dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & - + nnuccri(i,k)*precip_frac(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ni(i,k)) then - ratio = (ni(i,k)*oneodt + dum2) / dum1 * omsm - - nprci(i,k) = ratio * nprci(i,k) - nprai(i,k) = ratio * nprai(i,k) - nsubi(i,k) = ratio * nsubi(i,k) - end if - - end do - - end if - - do i=1,mgncol - - ! conservation of snow mixing ratio - !------------------------------------------------------------------- - dum1 = - prds(i,k) * precip_frac(i,k) - dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then - ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - - prds(i,k) = ratio * prds(i,k) - end if - - end do - - do i=1,mgncol - - ! conservation of snow number - !------------------------------------------------------------------- - ! calculate loss of number due to sublimation - ! for now neglect sublimation of ns - nsubs(i,k) = zero - - dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) - dum2 = nnuccr(i,k)*precip_frac(i,k) + nprci(i,k)*icldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ns(i,k)) then - ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm - - nsubs(i,k) = ratio * nsubs(i,k) - nsagg(i,k) = ratio * nsagg(i,k) - end if - - end do - - do i=1,mgncol - - ! next limit ice and snow sublimation and rain evaporation - ! get estimate of q and t at end of time step - ! don't include other microphysical processes since they haven't - ! been limited via conservation checks yet - - tx1 = pre(i,k) * precip_frac(i,k) - tx2 = prds(i,k) * precip_frac(i,k) - tx3 = tx1 + tx2 + ice_sublim(i,k) - if (tx3 < -1.e-20_r8) then - - tx4 = tx2 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) - qtmp = q(i,k) - (tx1 + tx4) * deltat - ttmp = t(i,k) + (tx1*xxlv + tx4*xxls) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - ! call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) - - ! modify ice/precip evaporation rate if q > qsat - if (qtmp > qvn) then - - tx4 = one / tx3 - dum1 = tx1 * tx4 - dum2 = tx2 * tx4 - ! recalculate q and t after vap_dep and mnuccd but without evap or sublim - tx5 = (vap_dep(i,k)+mnuccd(i,k)) * deltat - qtmp = q(i,k) - tx5 - ttmp = t(i,k) + tx5 * (xxls/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) - - dum = (qtmp-qvn) / (one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) - dum = min(dum, zero) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - if (precip_frac(i,k) > mincld) then - tx4 = oneodt / precip_frac(i,k) - else - tx4 = zero - endif - pre(i,k) = dum*dum1*tx4 - - ! do separately using RHI for prds and ice_sublim - !call qsat_ice(ttmp, p(i,k), esn, qvn) - esn = min(fpvsi(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) - - - dum = (qtmp-qvn) / (one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp)) - dum = min(dum, zero) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - prds(i,k) = dum*dum2*tx4 - - ! don't divide ice_sublim by cloud fraction since it is grid-averaged - dum1 = one - dum1 - dum2 - ice_sublim(i,k) = dum*dum1*oneodt - end if - end if - - end do - - ! Big "administration" loop enforces conservation, updates variables - ! that accumulate over substeps, and sets output variables. - - do i=1,mgncol - - ! get tendencies due to microphysical conversion processes - !========================================================== - ! note: tendencies are multiplied by appropriate cloud/precip - ! fraction to get grid-scale values - ! note: vap_dep is already grid-average values - - ! The net tendencies need to be added to rather than overwritten, - ! because they may have a value already set for instantaneous - ! melting/freezing. - - - qvlat(i,k) = qvlat(i,k) - (pre(i,k)+prds(i,k))*precip_frac(i,k)-& - vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) - - -! if (lprnt .and. k >= 60 ) & -! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& -! ' prds=',prds(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & -! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & -! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & -! ' mnuccr=',mnuccr(i,k), & -! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls - - tlat(i,k) = tlat(i,k) + ((pre(i,k)*precip_frac(i,k)) & - *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & - ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & - pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) - -! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) - - qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & - psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) - - if (do_cldice) then - qitend(i,k) = qitend(i,k) + & - (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & - prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & - mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) - end if - - qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) - - qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & - + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - - - cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! add output for cmei (accumulate) - cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! assign variables for trop_mozart, these are grid-average - !------------------------------------------------------------------- - ! evaporation/sublimation is stored here as positive term - - evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) - nevapr(i,k) = -pre(i,k) * precip_frac(i,k) - prer_evap(i,k) = -pre(i,k) * precip_frac(i,k) - - ! change to make sure prain is positive: do not remove snow from - ! prain used for wet deposition - prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& - pracs(i,k)+mnuccr(i,k))*precip_frac(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 = { rate of direct transfer of cloud water to rain & snow } - ! (no cloud ice or bergeron terms) - qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) - ! Avoid zero/near-zero division. - qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) - - - ! microphysics output, note this is grid-averaged - pratot(i,k) = pra(i,k) * lcldm(i,k) - prctot(i,k) = prc(i,k) * lcldm(i,k) - mnuccctot(i,k) = mnuccc(i,k) * lcldm(i,k) - mnuccttot(i,k) = mnucct(i,k) * lcldm(i,k) - msacwitot(i,k) = msacwi(i,k) * lcldm(i,k) - psacwstot(i,k) = psacws(i,k) * lcldm(i,k) - bergstot(i,k) = bergs(i,k) * lcldm(i,k) - bergtot(i,k) = berg(i,k) - prcitot(i,k) = prci(i,k) * icldm(i,k) - praitot(i,k) = prai(i,k) * icldm(i,k) - mnuccdtot(i,k) = mnuccd(i,k) * icldm(i,k) - - pracstot(i,k) = pracs(i,k) * precip_frac(i,k) - mnuccrtot(i,k) = mnuccr(i,k) * precip_frac(i,k) - - - nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & - - npra(i,k)-nprc1(i,k))*lcldm(i,k) - - if (do_cldice) then - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if - nitend(i,k) = nitend(i,k) + nnuccd(i,k)+ & - (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & - nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) - end if - - nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & - + nprci(i,k)*icldm(i,k) - - nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & - - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) - - ! make sure that ni at advanced time step does not exceed - ! maximum (existing N + source terms*dt), which is possible if mtime < deltat - ! note that currently mtime = deltat - !================================================================ - - if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then - nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) - end if - - end do - - ! End of "administration" loop - - end do micro_vert_loop ! end k loop - -! if (lprnt) write(0,*)' tlat3=',tlat(1,:)*deltat - !----------------------------------------------------- - ! convert rain/snow q and N for output to history, note, - ! output is for gridbox average - - do k=1,nlev - do i=1,mgncol - qrout(i,k) = qr(i,k) - nrout(i,k) = nr(i,k) * rho(i,k) - qsout(i,k) = qs(i,k) - nsout(i,k) = ns(i,k) * rho(i,k) - enddo - enddo - - ! calculate n0r and lamr from rain mass and number - ! divide by precip fraction to get in-precip (local) values of - ! rain mass and number, divide by rhow to get rain number in kg^-1 - - do k=1,nlev - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) - - enddo - ! Calculate rercld - - ! calculate mean size of combined rain and cloud water - - call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol, nlev) - - - ! Assign variables back to start-of-timestep values - ! Some state variables are changed before the main microphysics loop - ! to make "instantaneous" adjustments. Afterward, we must move those changes - ! back into the tendencies. - ! These processes: - ! - Droplet activation (npccn, impacts nc) - ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) - ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) - !================================================================================ - - do k=1,nlev - do i=1,mgncol - ! Re-apply droplet activation tendency - nc(i,k) = ncn(i,k) - nctend(i,k) = nctend(i,k) + npccn(i,k) - - ! Re-apply rain freezing and snow melting. - qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt - qs(i,k) = qsn(i,k) - - nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt - ns(i,k) = nsn(i,k) - - qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt - qr(i,k) = qrn(i,k) - - nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt - nr(i,k) = nrn(i,k) - - !............................................................................. - - !================================================================================ - - ! modify to include snow. in prain & evap (diagnostic here: for wet dep) - nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) - prain(i,k) = prain(i,k) + prodsnow(i,k) - - enddo - enddo - - do k=1,nlev - - do i=1,mgncol - - ! calculate sedimentation for cloud water and ice - !================================================================================ - - ! 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 - - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) * tx1 - dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) - else - dumc(i,k) = zero - dumnc(i,k) = zero - endif - if (icldm(i,k) > mincld) then - tx1 = one / icldm(i,k) - dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) * tx1 - dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx1, zero) - else - dumi(i,k) = zero - dumni(i,k) = zero - endif - if (precip_frac(i,k) > mincld) then - tx1 = one / precip_frac(i,k) - dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) * tx1 - dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) * tx1 - - dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)*tx1, zero) - dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)*tx1, zero) - else - dumr(i,k) = zero - dumr(i,k) = zero - dums(i,k) = zero - dumns(i,k) = zero - endif - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k) - end if - enddo - enddo - - do k=1,nlev - -! obtain new slope parameter to avoid possible singularity - - - call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & - lami(:,k), mgncol) - - call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) - -! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & -! lami(:,k), mgncol) -! fallspeed for rain - - call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & - lamr(:,k), mgncol) -! fallspeed for snow - call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & - lams(:,k), mgncol) - - enddo - - do k=1,nlev - do i=1,mgncol - - ! calculate number and mass weighted fall velocity for droplets and cloud ice - !------------------------------------------------------------------- - - grho = g*rho(i,k) - - if (dumc(i,k) >= qsmall) then - - tx1 = lamc(i,k)**bc - vtrmc(i,k) = acn(i,k)*gamma(four+bc+pgam(i,k)) & - / (tx1*gamma(pgam(i,k)+four)) - - fc(i,k) = grho*vtrmc(i,k) - - fnc(i,k) = grho* acn(i,k)*gamma(pgam(i,k)+one+bc) & - / (tx1*gamma(pgam(i,k)+one)) - else - fc(i,k) = zero - fnc(i,k) = zero - end if - - ! calculate number and mass weighted fall velocity for cloud ice - - if (dumi(i,k) >= qsmall) then - - tx3 = one / lami(i,k) - tx1 = ain(i,k) * tx3**bi - tx2 = 1.2_r8*rhof(i,k) - vtrmi(i,k) = min(tx1*gamma_bi_plus4*oneo6, tx2) - - fi(i,k) = grho * vtrmi(i,k) - fni(i,k) = grho * min(tx1*gamma_bi_plus1, tx2) - - ! adjust the ice fall velocity for smaller (r < 20 um) ice - ! particles (blend over 18-20 um) - irad = (1.5_r8 * 1e6_r8) * tx3 - ifrac = min(one, max(zero, (irad-18._r8)*half)) - - if (ifrac < one) then - tx1 = ajn(i,k) / lami(i,k)**bj - vtrmi(i,k) = ifrac*vtrmi(i,k) + (one-ifrac) * min(tx1*gamma_bj_plus4*oneo6, tx2) - - fi(i,k) = grho*vtrmi(i,k) - fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) - end if - else - fi(i,k) = zero - fni(i,k)= zero - end if - - - ! fallspeed for rain - -! if (lamr(i,k) >= qsmall) then - if (dumr(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - - tx1 = arn(i,k) / lamr(i,k)**br - tx2 = 9.1_r8*rhof(i,k) - umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) - unr(i,k) = min(tx1*gamma_br_plus1, tx2) - - fr(i,k) = grho * umr(i,k) - fnr(i,k) = grho * unr(i,k) - - else - fr(i,k) = zero - fnr(i,k) = zero - end if - - ! fallspeed for snow - - -! if (lams(i,k) >= qsmall) then - if (dums(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - tx1 = asn(i,k) / lams(i,k)**bs - tx2 = 1.2_r8*rhof(i,k) - ums(i,k) = min(tx1*gamma_bs_plus4*oneo6, tx2) - uns(i,k) = min(tx1*gamma_bs_plus1, tx2) - - fs(i,k) = grho * ums(i,k) - fns(i,k) = grho * uns(i,k) - - else - fs(i,k) = zero - fns(i,k) = zero - end if - - ! 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 - dumr(i,k) = qr(i,k) + qrtend(i,k)*deltat - dums(i,k) = qs(i,k) + qstend(i,k)*deltat - - dumnc(i,k) = nc(i,k) + nctend(i,k)*deltat - dumni(i,k) = ni(i,k) + nitend(i,k)*deltat - dumnr(i,k) = nr(i,k) + nrtend(i,k)*deltat - dumns(i,k) = ns(i,k) + nstend(i,k)*deltat - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero - - enddo - end do !!! vertical loop - - do k=1,nlev - do i=1,mgncol - pdel_inv(i,k) = one / pdel(i,k) - enddo - enddo -! if (lprnt) write(0,*)' bef sedimentation dumc=',dumc(i,nlev-10:nlev) - - ! initialize nstep for sedimentation sub-steps - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - do i=1,mgncol - nlb = nlball(i) - nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - - nstep = min(nstep, nstep_def) - - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - if (do_cldice) then - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumi(i,k) = tx5 / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = tx5 / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qisedten(i,k) = qisedten(i,k) + tx6 - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - - do k = 2,nlev - - ! 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 - - ! note: this is not an issue with precip, since we assume max overlap - - if (icldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - ! add fallout terms to eulerian tendencies - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = (tx5 + faloutni(k-1)*dum2) / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - - qisedten(i,k) = qisedten(i,k) + tx6 ! sedimentation tendency for output - - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice - qisevap(i,k) = qisevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxls - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - end do - - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - - prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) - - end do - end if - -! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - k = 1 - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumc(i,k) = tx5 / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = tx5 / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - ! sedimentation tendency for output - qcsedten(i,k) = qcsedten(i,k) + tx6 - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 - do k = 2,nlev - - if (lcldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = (tx5 + faloutnc(k-1)*dum2) / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - - qcsedten(i,k) = qcsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water - qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxlv - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here - end do - - prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) - - end do -! if (lprnt) write(0,*)' tlat5=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& -! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - -! if(lprnt) then -! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall -! write(0,*)' fr=',fr(i,:) -! write(0,*)' dumr=',dumr(i,:) -! endif - - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = tx5 / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = tx5 / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k) + tx6 - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 - - do k = 2,nlev - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = (tx5 + faloutr(k-1)*tx7) / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = (tx5 + faloutnr(k-1)*tx7) / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux - end do - - prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) - - end do - -! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = tx5 / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = tx5 / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qssedten(i,k) = qssedten(i,k) + tx6 - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 - - do k = 2,nlev - - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = (tx5 + falouts(k-1)*tx7) / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = (tx5 + faloutns(k-1)*tx7) / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - - qssedten(i,k) = qssedten(i,k) + tx6 ! sedimentation tendency for output - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 ! Snow Flux - end do !! k loop - - prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) - - end do !! nstep loop - - enddo ! end of i loop - ! end sedimentation - -! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! get new update for variables that includes sedimentation tendency - ! note : here dum variables are grid-average, NOT in-cloud - - do k=1,nlev - do i=1,mgncol - 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) - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) - end if - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero - - enddo - - enddo - - ! calculate instantaneous processes (melting, homogeneous freezing) - !==================================================================== - - ! melting of snow at +2 C - do k=1,nlev - - do i=1,mgncol - - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt - if (tx1 > zero) then - if (dums(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * dums(i,k) - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx1 = dum * oneodt - qstend(i,k) = qstend(i,k) - tx1*dums(i,k) - nstend(i,k) = nstend(i,k) - tx1*dumns(i,k) - qrtend(i,k) = qrtend(i,k) + tx1*dums(i,k) - nrtend(i,k) = nrtend(i,k) + tx1*dumns(i,k) - - dum1 = - xlf * tx1 * dums(i,k) - tlat(i,k) = tlat(i,k) + dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - end if - end if - enddo - enddo - do k=1,nlev - do i=1,mgncol - - ! freezing of rain at -5 C - - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - rainfrze - if (tx1 < zero) then - - if (dumr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * dumr(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - tx2 = dum * oneodt - qrtend(i,k) = qrtend(i,k) - tx2 * dumr(i,k) - nrtend(i,k) = nrtend(i,k) - tx2 * dumnr(i,k) - - ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice - ! depending on mean rain size - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (lamr(i,k) < one/Dcs) then - qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) - nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) - else - qitend(i,k) = qitend(i,k) + tx2 * dumr(i,k) - nitend(i,k) = nitend(i,k) + tx2 * dumnr(i,k) - end if - ! heating tendency - dum1 = xlf*dum*dumr(i,k)*oneodt - frzrdttot(i,k) = dum1 + frzrdttot(i,k) - tlat(i,k) = dum1 + tlat(i,k) - - end if - end if - - enddo - enddo - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - tmelt - if (tx1 > zero) then - if (dumi(i,k) > zero) then - - ! limit so that melting does not push temperature below freezing - !----------------------------------------------------------------- - dum = -dumi(i,k)*xlf/cpp - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - qctend(i,k) = qctend(i,k) + tx2*dumi(i,k) - - ! for output - melttot(i,k) = tx2*dumi(i,k) - - ! assume melting ice produces droplet - ! mean volume radius of 8 micron - - nctend(i,k) = nctend(i,k) + three*tx2*dumi(i,k)/(four*pi*5.12e-16_r8*rhow) - - qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt - nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt - tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) - end if - end if - enddo - enddo - -! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-10:nlev)*deltat -! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-10:nlev)*deltat - ! homogeneously freeze droplets at -40 C - !----------------------------------------------------------------- - - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - 233.15_r8 - if (tx1 < zero) then - if (dumc(i,k) > zero) then - - ! limit so that freezing does not push temperature above threshold - dum = (xlf/cpp) * dumc(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt * dumc(i,k) - qitend(i,k) = tx2 + qitend(i,k) - homotot(i,k) = tx2 ! for output - - ! 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) + tx2*(three/(four*pi*1.563e-14_r8* 500._r8)) - qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt - nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt - tlat(i,k) = tlat(i,k) + xlf*tx2 - end if - end if - enddo - enddo - ! 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 - do k=1,nlev - do i=1,mgncol - - qtmp = q(i,k) + qvlat(i,k) * deltat - ttmp = t(i,k) + tlat(i,k) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) - - - if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then - ! expression below is approximate since there may be ice deposition - dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - ! add to output cme - cmeout(i,k) = cmeout(i,k) + dum - ! now add to tendencies, partition between liquid and ice based on temperature - if (ttmp > 268.15_r8) then - dum1 = zero - ! now add to tendencies, partition between liquid and ice based on te - !------------------------------------------------------- - else if (ttmp < 238.15_r8) then - dum1 = one - else - dum1 = (268.15_r8-ttmp)/30._r8 - end if - - tx1 = xxls*dum1 + xxlv*(one-dum1) - dum = (qtmp-qvn)/(one+tx1*tx1*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - tx2 = dum*(one-dum1) - qctend(i,k) = qctend(i,k) + tx2 - qcrestot(i,k) = tx2 ! for output - qitend(i,k) = qitend(i,k) + dum*dum1 - qirestot(i,k) = dum*dum1 - qvlat(i,k) = qvlat(i,k) - dum - ! for output - qvres(i,k) = -dum - tlat(i,k) = tlat(i,k) + dum*tx1 - end if - enddo - enddo - end if - -! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat - ! 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 - do k=1,nlev - do i=1,mgncol - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - else - tx1 = zero - endif - if (icldm(i,k) > mincld) then - tx2 = one / icldm(i,k) - else - tx2 = zero - endif - if (precip_frac(i,k) > mincld) then - tx3 = one / precip_frac(i,k) - else - tx3 = zero - endif - 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 - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) * tx3 - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) * tx3 - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) * tx3 - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) * tx3 - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst * rhoinv(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst * rhoinv(i,k) - end if - - ! limit in-cloud mixing ratio 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) - dumc(i,k) = min(dumc(i,k), 10.e-3_r8) - dumi(i,k) = min(dumi(i,k), 10.e-3_r8) - ! limit in-precip mixing ratios - dumr(i,k) = min(dumr(i,k), 10.e-3_r8) - dums(i,k) = min(dums(i,k), 10.e-3_r8) - enddo - enddo - ! cloud ice effective radius - !----------------------------------------------------------------- - - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - if (dumi(i,k) >= qsmall) then - - tx1 = dumni(i,k) - call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & - lami(i,k), dumni0) - - if (dumni(i,k) /= tx1) then - ! adjust number conc if needed to keep mean size in reasonable range - nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k)) * oneodt - end if - - tx1 = one / lami(i,k) -! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 - effi(i,k) = (three*1.e6_r8) * tx1 - sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 - - else -! effi(i,k) = 25._r8 - effi(i,k) = 50._r8 - sadice(i,k) = zero - end if - - ! ice effective diameter for david mitchell's optics - deffi(i,k) = effi(i,k) * (rhoi+rhoi)/rhows - enddo - enddo - !else - !do k=1,nlev - !do i=1,mgncol - ! NOTE: If CARMA is doing the ice microphysics, then the ice effective - ! radius has already been determined from the size distribution. - !effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um - !deffi(i,k)=effi(i,k) * 2._r8 - !sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 - !enddo - !enddo - end if - - ! cloud droplet effective radius - !----------------------------------------------------------------- - do k=1,nlev - do i=1,mgncol - if (dumc(i,k) >= qsmall) then - - - ! switch for specification of droplet and crystal number - 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*rhoinv(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - - end if - - dum = dumnc(i,k) - - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - if (dum /= dumnc(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - end if - - effc(i,k) = (half*1.e6_r8) * (pgam(i,k)+three) / lamc(i,k) - !assign output fields for shape here - lamcrad(i,k) = lamc(i,k) - pgamrad(i,k) = pgam(i,k) - - - ! 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_r8 - - ! Pass in "false" adjust flag to prevent number from being changed within - ! size distribution subroutine. - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - effc_fn(i,k) = (half*1.e6_r8) * (pgam(i,k)+three)/lamc(i,k) - - else - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - end if - enddo - enddo - ! recalculate 'final' rain size distribution parameters - ! to ensure that rain size is in bounds, adjust rain number if needed - do k=1,nlev - do i=1,mgncol - - if (dumr(i,k) >= qsmall) then - - dum = dumnr(i,k) - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (dum /= dumnr(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt - end if - - end if - enddo - enddo - ! recalculate 'final' snow size distribution parameters - ! to ensure that snow size is in bounds, adjust snow number if needed - do k=1,nlev - do i=1,mgncol - if (dums(i,k) >= qsmall) then - - dum = dumns(i,k) - - call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & - lams(i,k), n0=dumns0) - - if (dum /= dumns(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k)) * oneodt - end if - - tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) - sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 - - end if - - - end do ! vertical k loop - enddo - do k=1,nlev - do i=1,mgncol - ! 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) * oneodt - if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat < qsmall) nitend(i,k) = -ni(i,k) * oneodt - if (qr(i,k)+qrtend(i,k)*deltat < qsmall) nrtend(i,k) = -nr(i,k) * oneodt - if (qs(i,k)+qstend(i,k)*deltat < qsmall) nstend(i,k) = -ns(i,k) * oneodt - - end do - - end do - - ! DO STUFF FOR OUTPUT: - !================================================== - - do k=1,nlev - do i=1,mgncol - - ! qc and qi are only used for output calculations past here, - ! so add qctend and qitend back in one more time - qc(i,k) = qc(i,k) + qctend(i,k)*deltat - qi(i,k) = qi(i,k) + qitend(i,k)*deltat - - ! averaging for snow and rain number and diameter - !-------------------------------------------------- - - ! drout2/dsout2: - ! diameter of rain and snow - ! dsout: - ! scaled diameter of snow (passed to radiation in CAM) - ! reff_rain/reff_snow: - ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual - - if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then - qrout2(i,k) = qrout(i,k) * precip_frac(i,k) - nrout2(i,k) = nrout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just drout2 times constants. - drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) - freqr(i,k) = precip_frac(i,k) - - reff_rain(i,k) = (1.e6_r8*three) * drout2(i,k) - else - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - freqr(i,k) = zero - reff_rain(i,k) = zero - endif - - if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then - qsout2(i,k) = qsout(i,k) * precip_frac(i,k) - nsout2(i,k) = nsout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just dsout2 times constants. - dsout2(i,k) = avg_diameter(qsout(i,k), nsout(i,k), rho(i,k), rhosn) - freqs(i,k) = precip_frac(i,k) - - dsout(i,k) = three*rhosn/rhows*dsout2(i,k) - - reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) - else - dsout(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout2(i,k) = zero - freqs(i,k) = zero - reff_snow(i,k) = zero - endif - - enddo - enddo - - ! analytic radar reflectivity - !-------------------------------------------------- - ! formulas from Matthew Shupe, NOAA/CERES - ! *****note: radar reflectivity is local (in-precip average) - ! units of mm^6/m^3 - - do k=1,nlev - do i = 1,mgncol - if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten) then - tx1 = rho(i,k) / lcldm(i,k) - tx2 = 1000._r8 * qc(i,k) * tx1 - dum = tx2 * tx2 * lcldm(i,k) & - /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)*tx1*1.e-6_r8*precip_frac(i,k)) -! dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & -! /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) - else - dum = zero - end if - if (qi(i,k) >= qsmall) then -! dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) - dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*10000._r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(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) - dum1 = dum1 + (qsout(i,k)*rho(i,k)*10000._r8)**(one/0.63_r8) - end if - - refl(i,k) = dum + dum1 - - ! add rain rate, but for 37 GHz formulation instead of 94 GHz - ! formula approximated from data of Matrasov (2007) - ! rainrt is the rain rate in mm/hr - ! reflectivity (dum) is in DBz - - if (rainrt(i,k) >= 0.001_r8) then - dum = rainrt(i,k) * rainrt(i,k) - dum = log10(dum*dum*dum) + 16._r8 - - ! convert from DBz to mm^6/m^3 - - dum = ten**(dum/ten) - else - ! don't include rain rate in R calculation for values less than 0.001 mm/hr - dum = zero - end if - - ! add to refl - - refl(i,k) = refl(i,k) + dum - - !output reflectivity in Z. - areflz(i,k) = refl(i,k) * precip_frac(i,k) - - ! convert back to DBz - - if (refl(i,k) > minrefl) then - refl(i,k) = ten*log10(refl(i,k)) - else - refl(i,k) = -9999._r8 - end if - - !set averaging flag - if (refl(i,k) > mindbz) then - arefl(i,k) = refl(i,k) * precip_frac(i,k) - frefl(i,k) = precip_frac(i,k) - else - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - end if - - ! bound cloudsat reflectivity - - csrfl(i,k) = min(csmax,refl(i,k)) - - !set averaging flag - if (csrfl(i,k) > csmin) then - acsrfl(i,k) = refl(i,k) * precip_frac(i,k) - fcsrfl(i,k) = precip_frac(i,k) - else - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - end if - - end do - end do - - do k=1,nlev - do i = 1,mgncol - !redefine fice here.... - tx2 = qsout(i,k) + qi(i,k) - tx1 = tx2 + qrout(i,k) + qc(i,k) - if ( tx2 > qsmall .and. tx1 > qsmall) then - nfice(i,k) = min(tx2/tx1, one) - else - nfice(i,k) = zero - endif - enddo - enddo - -end subroutine micro_mg_tend - -!======================================================================== -!OUTPUT CALCULATIONS -!======================================================================== - -!>\ingroup mg2_0_mp -!! This subroutine -subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) - integer, intent(in) :: mgncol, nlev - real(r8), dimension(mgncol,nlev), intent(in) :: lamr ! rain size parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: n0r ! rain size parameter (intercept) - real(r8), dimension(mgncol,nlev), intent(in) :: lamc ! size distribution parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: pgam ! droplet size parameter - real(r8), dimension(mgncol,nlev), intent(in) :: qric ! in-cloud rain mass mixing ratio - real(r8), dimension(mgncol,nlev), intent(in) :: qcic ! in-cloud cloud liquid - real(r8), dimension(mgncol,nlev), intent(in) :: ncic ! in-cloud droplet number concentration - - real(r8), dimension(mgncol,nlev), intent(inout) :: rercld ! effective radius calculation for rain + cloud - - ! combined size of precip & cloud drops - real(r8) :: Atmp - - integer :: i, k - - do k=1,nlev - do i=1,mgncol - ! Rain drops - if (lamr(i,k) > zero) then - Atmp = n0r(i,k) * (half*pi) / (lamr(i,k)*lamr(i,k)*lamr(i,k)) - else - Atmp = zero - end if - - ! Add cloud drops - if (lamc(i,k) > zero) then - Atmp = Atmp + ncic(i,k) * pi * rising_factorial(pgam(i,k)+one, 2) & - / (four*lamc(i,k)*lamc(i,k)) - end if - - if (Atmp > zero) then - rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) - end if - enddo - enddo -end subroutine calc_rercld - -!======================================================================== - -end module micro_mg2_0 diff --git a/gfsphysics/physics/micro_mg3_0.F90 b/gfsphysics/physics/micro_mg3_0.F90 deleted file mode 100644 index b170ccd70..000000000 --- a/gfsphysics/physics/micro_mg3_0.F90 +++ /dev/null @@ -1,4507 +0,0 @@ -module micro_mg3_0 -!--------------------------------------------------------------------------------- -! Purpose: -! MG microphysics version 3.0 - Update of MG microphysics with -! prognostic hail OR graupel. -! -! Author: Andrew Gettelman, Hugh Morrison -! -! -! Version 3 history: Sep 2016: development begun for hail, graupel -! This version:https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ -! -! Version 2 history: Sep 2011: Development begun. -! Feb 2013: Added of prognostic precipitation. -! Aug 2015: Published and released version -! Contributions from: Sean Santos, Peter Caldwell, Xiaohong Liu and Steve Ghan -! -! Anning Cheng adopted mg2 for FV3GFS 9/29/2017 -! add GMAO ice conversion and Liu et. al liquid water -! conversion in 10/12/2017 -! Anning showed promising results for FV3GFS on 10/15/2017 -! S. Moorthi - Oct/Nov 2017 - optimized the MG2 code -! S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit -! S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation -! other modifications to eliminate blowup. -! S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 -! S. Moorthi - Oct,29,2018 - change nlb from nlev/3 to levels with p/ps < 0.05 (nlball) -! -! invoked in CAM by specifying -microphys=mg3 -! -! References: -! -! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. -! -! Part I: Off line tests and comparisons with other schemes. -! -! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. -! -! -! -! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell -! -! Advanced Two-Moment Microphysics for Global Models. -! -! Part II: Global model solutions and Aerosol-Cloud Interactions. -! -! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. -! -! for questions contact Hugh Morrison, Andrew Gettelman -! e-mail: morrison@ucar.edu, andrew@ucar.edu -!--------------------------------------------------------------------------------- -! -! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice -! microphysics in cooperation with the MG liquid microphysics. This is -! controlled by the do_cldice variable. -! -! If do_cldice is false, then MG microphysics should not update CLDICE or -! NUMICE; it is assumed that the other microphysics scheme will have updated -! CLDICE and NUMICE. The other microphysics should handle the following -! processes that would have been done by MG: -! - Detrainment (liquid and ice) -! - Homogeneous ice nucleation -! - Heterogeneous ice nucleation -! - Bergeron process -! - Melting of ice -! - Freezing of cloud drops -! - Autoconversion (ice -> snow) -! - Growth/Sublimation of ice -! - Sedimentation of ice -! -! This option has not been updated since the introduction of prognostic -! precipitation, and probably should be adjusted to cover snow as well. -! -!--------------------------------------------------------------------------------- -!Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F -!--------------------------------------------------------------------------------- -! Based on micro_mg (restructuring of former cldwat2m_micro) -! 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 -!--------------------------------------------------------------------------------- -! Code comments added by HM, 093011 -! General code structure: -! -! Code is divided into two main subroutines: -! subroutine micro_mg_init --> initializes microphysics routine, should be called -! once at start of simulation -! subroutine micro_mg_tend --> main microphysics routine to be called each time step -! this also calls several smaller subroutines to calculate -! microphysical processes and other utilities -! -! List of external functions: -! qsat_water --> for calculating saturation vapor pressure with respect to liquid water -! qsat_ice --> for calculating saturation vapor pressure with respect to ice -! gamma --> standard mathematical gamma function -! ......................................................................... -! List of inputs through use statement in fortran90: -! Variable Name Description Units -! ......................................................................... -! gravit acceleration due to gravity m s-2 -! rair dry air gas constant for air J kg-1 K-1 -! tmelt temperature of melting point for water K -! cpair specific heat at constant pressure for dry air J kg-1 K-1 -! rh2o gas constant for water vapor J kg-1 K-1 -! latvap latent heat of vaporization J kg-1 -! latice latent heat of fusion J kg-1 -! qsat_water external function for calculating liquid water -! saturation vapor pressure/humidity - -! qsat_ice external function for calculating ice -! saturation vapor pressure/humidity pa -! rhmini relative humidity threshold parameter for -! nucleating ice - -! ......................................................................... -! NOTE: List of all inputs/outputs passed through the call/subroutine statement -! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. -!--------------------------------------------------------------------------------- - -! Procedures required: -! 1) An implementation of the gamma function (if not intrinsic). -! 2) saturation vapor pressure and specific humidity over water -! 3) svp over ice -use machine, only : r8 => kind_phys -use physcons, only : epsqs => con_eps, fv => con_fvirt -use funcphys, only : fpvsl, fpvsi - -!use wv_sat_methods, only: & -! qsat_water => wv_sat_qsat_water, & -! qsat_ice => wv_sat_qsat_ice - -! Parameters from the utilities module. -use micro_mg_utils, only : pi, omsm, qsmall, mincld, rhosn, rhoi, & - rhow, rhows, ac, bc, ai, bi, & - aj, bj, ar, br, as, bs, & -!++ag - ag, bg, ah, bh, rhog, rhoh, & -!--ag - mi0, rising_factorial - -implicit none -private -save - -public :: micro_mg_init, micro_mg_tend, qcvar - -! Switches for specification rather than prediction of droplet and crystal number -! note: number will be adjusted as needed to keep mean size within bounds, -! even when specified droplet or ice number is used -! -! If constant cloud ice number is set (nicons = .true.), -! then all microphysical processes except mass transfer due to ice nucleation -! (mnuccd) are based on the fixed cloud ice number. Calculation of -! mnuccd follows from the prognosed ice crystal number ni. - -logical :: nccons ! nccons = .true. to specify constant cloud droplet number -logical :: nicons ! nicons = .true. to specify constant cloud ice number -!++ag kt -logical :: ngcons ! ngcons = .true. to specify constant graupel number -!--ag kt - -! specified ice and droplet number concentrations -! note: these are local in-cloud values, not grid-mean -real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3) -real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3) -!++ag kt -real(r8) :: ngnst ! graupel num concentration when ngcons=.true. (m-3) -!--ag kt - -!========================================================= -! Private module parameters -!========================================================= - -!Range of cloudsat reflectivities (dBz) for analytic simulator -real(r8), parameter :: csmin = -30._r8 -real(r8), parameter :: csmax = 26._r8 -real(r8), parameter :: mindbz = -99._r8 -real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) - -! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs, ts_au, ts_au_min, qcvar - -! minimum mass of new crystal due to freezing of cloud droplets done -! externally (kg) -real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 - -! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. -real(r8), parameter :: sublim_factor = 0.0_r8 !number sublimation factor. - -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, six=6._r8, half=0.5_r8, & - ten=10.0_r8, forty=40.0_r8, oneo6=one/six - -!========================================================= -! Constants set in initialization -!========================================================= - -! Set using arguments to micro_mg_init -real(r8) :: g ! gravity -real(r8) :: r ! dry air gas constant -real(r8) :: rv ! water vapor gas constant -real(r8) :: cpp ! specific heat of dry air -real(r8) :: tmelt ! freezing point of water (K) - -! latent heats of: -real(r8) :: xxlv ! vaporization -real(r8) :: xlf ! freezing -real(r8) :: xxls ! sublimation - -real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. - -! flags -logical :: microp_uniform, do_cldice, use_hetfrz_classnuc, & -!++ag - do_hail, do_graupel -!--ag - -real(r8) :: rhosu ! typical 850mn air density - -real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C - -real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C -real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C - -real(r8) :: rhogtmp ! hail or graupel density (kg m-3) -real(r8) :: agtmp ! tmp ag/ah parameter -real(r8) :: bgtmp ! tmp fall speed parameter - -! additional constants to help speed up code -real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1, gamma_bg_plus1 -real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4, gamma_bg_plus4 -real(r8) :: xxlv_squared, xxls_squared -real(r8) :: omeps - -character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method -real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor - -logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop -logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics -logical :: do_ice_gmao -logical :: do_liq_liu - -!=============================================================================== -contains -!=============================================================================== - -subroutine micro_mg_init( & - kind, gravit, rair, rh2o, cpair, & - tmelt_in, latvap, latice, & - rhmini_in, micro_mg_dcs,ts_auto, mg_qcvar, & -!++ag - micro_mg_do_hail_in, micro_mg_do_graupel_in, & -!--ag - microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & - micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & - allow_sed_supersat_in, do_sb_physics_in, & - do_ice_gmao_in, do_liq_liu_in, & - nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in) -! nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, errstring) - - use micro_mg_utils, only : micro_mg_utils_init - use wv_saturation, only : gestbl - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! initialize constants for MG microphysics - ! - ! Author: Andrew Gettelman Dec 2005 - ! - !----------------------------------------------------------------------- - - integer, intent(in) :: kind ! Kind used for reals - real(r8), intent(in) :: gravit - real(r8), intent(in) :: rair - real(r8), intent(in) :: rh2o - real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) - real(r8), intent(in) :: latvap - real(r8), intent(in) :: latice - real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. - real(r8), intent(in) :: micro_mg_dcs - real(r8), intent(in) :: ts_auto(2) - real(r8), intent(in) :: mg_qcvar - -!++ag -!MG3 dense precipitating ice. Note, only 1 can be true, or both false. - logical, intent(in) :: micro_mg_do_graupel_in ! .true. = configure with graupel - ! .false. = no graupel (hail possible) - logical, intent(in) :: micro_mg_do_hail_in ! .true. = configure with hail - ! .false. = no hail (graupel possible) -!--ag - - logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns - ! .false. = use w/o sub-columns (standard) - logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) - ! .false. = skip all processes affecting cloud ice - logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing - - character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method - real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor - logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop - logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics - logical, intent(in) :: do_ice_gmao_in - logical, intent(in) :: do_liq_liu_in - - logical, intent(in) :: nccons_in, nicons_in, ngcons_in - real(r8), intent(in) :: ncnst_in, ninst_in, ngnst_in - logical ip - real(r8):: tmn, tmx, trice - - -! character(128), intent(out) :: errstring ! Output status (non-blank for error return) - - !----------------------------------------------------------------------- - - dcs = micro_mg_dcs * 1.0d-6 - ts_au_min = ts_auto(1) - ts_au = ts_auto(2) - qcvar = mg_qcvar - - ! Initialize subordinate utilities module. - call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & - dcs) -! dcs, errstring) - -! if (trim(errstring) /= "") return - - ! declarations for MG code (transforms variable names) - - g = gravit ! gravity - r = rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) -! write(0,*)' in micro_mg_utils_init=',' r=',r,' rair=',rair,' rh2o=',rh2o - rv = rh2o ! water vapor gas constant - cpp = cpair ! specific heat of dry air - tmelt = tmelt_in - rhmini = rhmini_in - micro_mg_precip_frac_method = micro_mg_precip_frac_method_in - micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in - allow_sed_supersat = allow_sed_supersat_in - do_sb_physics = do_sb_physics_in - do_ice_gmao = do_ice_gmao_in - do_liq_liu = do_liq_liu_in - - nccons = nccons_in - nicons = nicons_in - ncnst = ncnst_in - ninst = ninst_in -!++ag - ngcons = ngcons_in - ngnst = ngnst_in -!--ag - - ! latent heats - - xxlv = latvap ! latent heat vaporization - xlf = latice ! latent heat freezing - xxls = xxlv + xlf ! latent heat of sublimation - - ! flags - microp_uniform = microp_uniform_in - do_cldice = do_cldice_in - use_hetfrz_classnuc = use_hetfrz_classnuc_in -!++ag - do_hail = micro_mg_do_hail_in - do_graupel = micro_mg_do_graupel_in -! - if (do_hail) then - agtmp = ah - bgtmp = bh - rhogtmp = rhoh - elseif (do_graupel) then - agtmp = ag - bgtmp = bg - rhogtmp = rhog - else - agtmp = zero - bgtmp = zero - endif -!--ag - - ! typical air density at 850 mb - - rhosu = 85000._r8 / (rair * tmelt) - - ! Maximum temperature at which snow is allowed to exist - snowmelt = tmelt + two - ! Minimum temperature at which rain is allowed to exist - rainfrze = tmelt - forty - - ! Ice nucleation temperature - icenuct = tmelt - five - - ! Define constants to help speed up code (this limits calls to gamma function) - gamma_br_plus1 = gamma(br+one) - gamma_br_plus4 = gamma(br+four) - gamma_bs_plus1 = gamma(bs+one) - gamma_bs_plus4 = gamma(bs+four) - gamma_bi_plus1 = gamma(bi+one) - gamma_bi_plus4 = gamma(bi+four) - gamma_bj_plus1 = gamma(bj+one) - gamma_bj_plus4 = gamma(bj+four) -! - gamma_bg_plus1 = gamma(bgtmp+one) - gamma_bg_plus4 = gamma(bgtmp+four) - - xxlv_squared = xxlv * xxlv - xxls_squared = xxls * xxls - omeps = one - epsqs - tmn = 173.16_r8 - tmx = 375.16_r8 - trice = 35.00_r8 - ip = .true. - call gestbl(tmn ,tmx ,trice ,ip ,epsqs , latvap ,latice ,rh2o , & - cpair ,tmelt_in ) - - - -end subroutine micro_mg_init - -!=============================================================================== -!microphysics routine for each timestep goes here... - -subroutine micro_mg_tend ( & - mgncol, nlev, deltatin, & - t, q, & - qcn, qin, & - ncn, nin, & - qrn, qsn, & - nrn, nsn, & -!++ag - qgr, ngr, & -!--ag - relvar, accre_enhan_i, & - p, pdel, & - cldn, liqcldf, icecldf, qsatfac, & - qcsinksum_rate1ord, & - naai, npccnin, & - rndst, nacon, & - tlat, qvlat, & - qctend, qitend, & - nctend, nitend, & - qrtend, qstend, & - nrtend, nstend, & -!++ag - qgtend, ngtend, & -!--ag - effc, effc_fn, effi, & - sadice, sadsnow, & - prect, preci, & - nevapr, evapsnow, & - am_evp_st, & - prain, prodsnow, & - cmeout, deffi, & - pgamrad, lamcrad, & - qsout, dsout, & -!++ag - qgout, ngout, dgout, & -!--ag - lflx, iflx, & -!++ag - gflx, & -!--ag - rflx, sflx, qrout, & -!++ag - reff_rain, reff_snow, reff_grau, & -!--ag - - qcsevap, qisevap, qvres, & - cmeitot, vtrmc, vtrmi, & - umr, ums, & -!++ag - umg, qgsedten, & -!--ag - qcsedten, qisedten, & - qrsedten, qssedten, & - pratot, prctot, & - mnuccctot, mnuccttot, msacwitot, & - psacwstot, bergstot, bergtot, & - melttot, homotot, & - qcrestot, prcitot, praitot, & -!++ag - qirestot, mnuccrtot, mnuccritot, pracstot, & -!--ag - meltsdttot, frzrdttot, mnuccdtot, & -!++ag - pracgtot, psacwgtot, pgsacwtot, & - pgracstot, prdgtot, & - qmultgtot, qmultrgtot, psacrtot, & - npracgtot, nscngtot, ngracstot, & - nmultgtot, nmultrgtot, npsacwgtot, & -!--ag - nrout, nsout, & - refl, arefl, areflz, & - frefl, csrfl, acsrfl, & - fcsrfl, rercld, & - ncai, ncal, & - qrout2, qsout2, & - nrout2, nsout2, & - drout2, dsout2, & -!++ag - qgout2, ngout2, dgout2, freqg, & -!--ag - freqs, freqr, & - nfice, qcrat, & - prer_evap, xlat, xlon, lprnt, iccn, nlball) - - ! Constituent properties. - use micro_mg_utils, only: mg_liq_props, & - mg_ice_props, & - mg_rain_props, & -!++ag - mg_graupel_props,& -!--ag - mg_snow_props - - ! Size calculation functions. - use micro_mg_utils, only: size_dist_param_liq, & - size_dist_param_basic, & - avg_diameter - - ! Microphysical processes. - use micro_mg_utils, only: ice_deposition_sublimation, & - sb2001v2_liq_autoconversion, & - sb2001v2_accre_cld_water_rain, & - kk2000_liq_autoconversion, & - ice_autoconversion, & - immersion_freezing, & - contact_freezing, & - snow_self_aggregation, & - accrete_cloud_water_snow, & - secondary_ice_production, & - accrete_rain_snow, & - heterogeneous_rain_freezing, & - accrete_cloud_water_rain, & - self_collection_rain, & - accrete_cloud_ice_snow, & - evaporate_sublimate_precip, & - bergeron_process_snow, & - size_dist_param_ice, & -!++ag - graupel_collecting_snow, & - graupel_collecting_rain, & - graupel_collecting_cld_water, & - graupel_riming_liquid_snow, & - graupel_rain_riming_snow, & - graupel_rime_splintering, & - evaporate_sublimate_precip_graupel,& -! graupel_sublimate_evap -!--ag - liu_liq_autoconversion, & - gmao_ice_autoconversion - - !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - - ! input arguments - integer, intent(in) :: mgncol ! number of microphysics columns - integer, intent(in) :: nlev ! number of layers - integer, intent(in) :: nlball(mgncol) ! sedimentation start level - real(r8), intent(in) :: xlat,xlon ! number of layers - real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) - real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) - - ! note: all input cloud variables are grid-averaged - real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg) - real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) - real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg) - real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg) - - real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg) - real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg) - real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg) -!++ag - real(r8), intent(in) :: qgr(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg) - real(r8), intent(in) :: ngr(mgncol,nlev) ! graupel/hail number conc (1/kg) -!--ag - - real(r8) :: relvar(mgncol,nlev) ! cloud water relative variance (-) - real(r8) :: accre_enhan(mgncol,nlev)! optional accretion -! real(r8), intent(in) :: relvar_i ! cloud water relative variance (-) - real(r8), intent(in) :: accre_enhan_i ! optional accretion - ! enhancement factor (-) - - real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa) - real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa) - - real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units) - real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) - real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) - real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) - logical, intent(in) :: lprnt - integer, intent(in) :: iccn - - ! used for scavenging - ! Inputs for aerosol activation - real(r8), intent(inout) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) - real(r8), intent(in) :: npccnin(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) -! real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - real(r8) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - - ! Note that for these variables, the dust bin is assumed to be the last index. - ! (For example, in CAM, the last dimension is always size 4.) - real(r8), intent(in) :: rndst(mgncol,nlev,10) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) - real(r8), intent(in) :: nacon(mgncol,nlev,10) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - - ! output arguments - - real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for - ! direct cw to precip conversion - real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) - real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) - real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) - real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) - real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) - real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) - - real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s) - real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s) - real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s)) - real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s)) -!++ag - real(r8), intent(out) :: qgtend(mgncol,nlev) ! microphysical tendency qg (1/s) - real(r8), intent(out) :: ngtend(mgncol,nlev) ! microphysical tendency ng (1/(kg*s)) -!--ag - real(r8), intent(out) :: effc(mgncol,nlev) ! droplet effective radius (micron) - real(r8), intent(out) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 - real(r8), intent(out) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) - real(r8), intent(out) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3) - real(r8), intent(out) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3) - real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s) - real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) - real(r8), intent(out) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) - real(r8), intent(out) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) - real(r8), intent(out) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac) - real(r8), intent(out) :: prain(mgncol,nlev) ! production of rain + snow (1/s) - real(r8), intent(out) :: prodsnow(mgncol,nlev) ! production of snow (1/s) - real(r8), intent(out) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) - real(r8), intent(out) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) - real(r8), intent(out) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) - real(r8), intent(out) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) - real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8), intent(out) :: dsout(mgncol,nlev) ! snow diameter (m) - real(r8), intent(out) :: lflx(mgncol,2:nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: iflx(mgncol,2:nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: rflx(mgncol,2:nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8), intent(out) :: sflx(mgncol,2:nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) -!++ag - real(r8), intent(out) :: gflx(mgncol,2:nlev+1) ! grid-box average graupel/hail flux (kg m^-2 s^-1) -!--ag - real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) - real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) - real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) -!++ag - real(r8), intent(out) :: reff_grau(mgncol,nlev) ! graupel effective radius (micron) -!--ag - real(r8), intent(out) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) - real(r8), intent(out) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sedimentation (1/s) - real(r8), intent(out) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) - real(r8), intent(out) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) - real(r8), intent(out) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) - real(r8), intent(out) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) - real(r8), intent(out) :: umr(mgncol,nlev) ! mass weighted rain fallspeed (m/s) - real(r8), intent(out) :: ums(mgncol,nlev) ! mass weighted snow fallspeed (m/s) -!++ag - real(r8), intent(out) :: umg(mgncol,nlev) ! mass weighted graupel/hail fallspeed (m/s) - real(r8), intent(out) :: qgsedten(mgncol,nlev) ! qg sedimentation tendency (1/s) -!--ag - - real(r8), intent(out) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) - real(r8), intent(out) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) - real(r8), intent(out) :: qrsedten(mgncol,nlev) ! qr sedimentation tendency (1/s) - real(r8), intent(out) :: qssedten(mgncol,nlev) ! qs sedimentation tendency (1/s) - - ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) - real(r8), intent(out) :: pratot(mgncol,nlev) ! accretion of cloud by rain - real(r8), intent(out) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain - real(r8), intent(out) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing - real(r8), intent(out) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing - real(r8), intent(out) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering - real(r8), intent(out) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow - real(r8), intent(out) :: bergstot(mgncol,nlev) ! bergeron process on snow - real(r8), intent(out) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice - real(r8), intent(out) :: melttot(mgncol,nlev) ! melting of cloud ice - real(r8), intent(out) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water - real(r8), intent(out) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat - real(r8), intent(out) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow - real(r8), intent(out) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow - real(r8), intent(out) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat - real(r8), intent(out) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - real(r8), intent(out) :: mnuccritot(mgncol,nlev)! mixing ratio tendency due to heterogeneous freezing of rain to ice (1/s) - real(r8), intent(out) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) - real(r8), intent(out) :: meltsdttot(mgncol,nlev)! latent heating rate due to melting of snow (W/kg) - real(r8), intent(out) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) - real(r8), intent(out) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation -!++ag Hail/Graupel Tendencies - real(r8), intent(out) :: pracgtot(mgncol,nlev) ! change in q collection rain by graupel (precipf) - real(r8), intent(out) :: psacwgtot(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) - real(r8), intent(out) :: pgsacwtot(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) - real(r8), intent(out) :: pgracstot(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) - real(r8), intent(out) :: prdgtot(mgncol,nlev) ! dep of graupel (precipf) -! real(r8), intent(out) :: eprdgtot(mgncol,nlev) ! sub of graupel (precipf) - real(r8), intent(out) :: qmultgtot(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) - real(r8), intent(out) :: qmultrgtot(mgncol,nlev)! change q due to ice mult rain/graupel (precipf) - real(r8), intent(out) :: psacrtot(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) - real(r8), intent(out) :: npracgtot(mgncol,nlev) ! change n collection rain by graupel (precipf) - real(r8), intent(out) :: nscngtot(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) - real(r8), intent(out) :: ngracstot(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) - real(r8), intent(out) :: nmultgtot(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) - real(r8), intent(out) :: nmultrgtot(mgncol,nlev)! ice mult due to acc rain by graupel (precipf) - real(r8), intent(out) :: npsacwgtot(mgncol,nlev)! change n collection droplets by graupel (lcldm?) -!--ag - real(r8), intent(out) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) - real(r8), intent(out) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) - real(r8), intent(out) :: refl(mgncol,nlev) ! analytic radar reflectivity - real(r8), intent(out) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range - real(r8), intent(out) :: areflz(mgncol,nlev) ! average reflectivity in z. - real(r8), intent(out) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity - real(r8), intent(out) :: csrfl(mgncol,nlev) ! cloudsat reflectivity - real(r8), intent(out) :: acsrfl(mgncol,nlev) ! cloudsat average - real(r8), intent(out) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity - real(r8), intent(out) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud - real(r8), intent(out) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) - real(r8), intent(out) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) - real(r8), intent(out) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 - real(r8), intent(out) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 - real(r8), intent(out) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 - real(r8), intent(out) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 - real(r8), intent(out) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) - real(r8), intent(out) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) - real(r8), intent(out) :: freqs(mgncol,nlev) ! fractional occurrence of snow - real(r8), intent(out) :: freqr(mgncol,nlev) ! fractional occurrence of rain - real(r8), intent(out) :: nfice(mgncol,nlev) ! fractional occurrence of ice - real(r8), intent(out) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc) -!++ag - real(r8), intent(out) :: qgout(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg) - real(r8), intent(out) :: dgout(mgncol,nlev) ! graupel/hail diameter (m) - real(r8), intent(out) :: ngout(mgncol,nlev) ! graupel/hail number concentration (1/m3) -!Not sure if these are needed since graupel/hail is prognostic? - real(r8), intent(out) :: qgout2(mgncol,nlev) ! copy of qgout as used to compute dgout2 - real(r8), intent(out) :: ngout2(mgncol,nlev) ! copy of ngout as used to compute dgout2 - real(r8), intent(out) :: dgout2(mgncol,nlev) ! mean graupel/hail particle diameter (m) - real(r8), intent(out) :: freqg(mgncol,nlev) ! fractional occurrence of graupel - -!--ag - - real(r8), intent(out) :: prer_evap(mgncol,nlev) - - - ! Tendencies calculated by external schemes that can replace MG's native - ! process tendencies. - - ! Used with CARMA cirrus microphysics - ! (or similar external microphysics model) - ! real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) - ! real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) - ! real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m) - - ! From external ice nucleation. - !real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) - !real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) - !real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) - - ! local workspace - ! all units mks unless otherwise stated - - ! local copies of input variables - real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) - real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) - real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) - real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) - real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) - real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) - real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) -!++ag - real(r8) :: qg(mgncol,nlev) ! graupel mixing ratio (kg/kg) - real(r8) :: ng(mgncol,nlev) ! graupel number concentration (1/kg) -! real(r8) :: rhogtmp ! hail or graupel density (kg m-3) - -!--ag - - ! general purpose variables - real(r8) :: deltat ! sub-time step (s) - real(r8) :: oneodt ! one / deltat - real(r8) :: mtime ! the assumed ice nucleation timescale - - ! physical properties of the air at a given point - real(r8) :: rho(mgncol,nlev) ! density (kg m-3) - real(r8) :: rhoinv(mgncol,nlev) ! one / density (kg m-3) - real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor - real(r8) :: mu(mgncol,nlev) ! viscosity - real(r8) :: sc(mgncol,nlev) ! schmidt number - real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed - - ! cloud fractions - real(r8) :: precip_frac(mgncol,nlev)! precip fraction assuming maximum overlap - real(r8) :: cldm(mgncol,nlev) ! cloud fraction - real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction - real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction - real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor - - ! mass mixing ratios - real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid - real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: qsic(mgncol,nlev) ! in-precip snow - real(r8) :: qric(mgncol,nlev) ! in-precip rain -!++ag - real(r8) :: qgic(mgncol,nlev) ! in-precip graupel/hail -!++ag - - - ! number concentrations - real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet - real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: nsic(mgncol,nlev) ! in-precip snow - real(r8) :: nric(mgncol,nlev) ! in-precip rain -!++ag - real(r8) :: ngic(mgncol,nlev) ! in-precip graupel/hail -!++ag - - ! maximum allowed ni value - real(r8) :: nimax(mgncol,nlev) - - ! Size distribution parameters for: - ! cloud ice - real(r8) :: lami(mgncol,nlev) ! slope - real(r8) :: n0i(mgncol,nlev) ! intercept - ! cloud liquid - real(r8) :: lamc(mgncol,nlev) ! slope - real(r8) :: pgam(mgncol,nlev) ! spectral width parameter - ! snow - real(r8) :: lams(mgncol,nlev) ! slope - real(r8) :: n0s(mgncol,nlev) ! intercept - ! rain - real(r8) :: lamr(mgncol,nlev) ! slope - real(r8) :: n0r(mgncol,nlev) ! intercept -!++ag - ! graupel/hail - real(r8) :: lamg(mgncol,nlev) ! slope - real(r8) :: n0g(mgncol,nlev) ! intercept -! real(r8) :: bgtmp ! tmp fall speed parameter -!--ag - - ! Rates/tendencies due to: - - ! Instantaneous snow melting - real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstsm(mgncol,nlev) ! number concentration -!++ag - ! Instantaneous graupel melting - real(r8) :: minstgm(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstgm(mgncol,nlev) ! number concentration -!--ag - - ! Instantaneous rain freezing - real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstrf(mgncol,nlev) ! number concentration - - ! deposition of cloud ice - real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 - ! sublimation of cloud ice - real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 - ! ice nucleation - real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing - real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio - ! freezing of cloud water - real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccc(mgncol,nlev) ! number concentration - ! contact freezing of cloud water - real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnucct(mgncol,nlev) ! number concentration - ! deposition nucleation in mixed-phase clouds (from external scheme) - real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnudep(mgncol,nlev) ! number concentration - ! ice multiplication - real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio - real(r8) :: nsacwi(mgncol,nlev) ! number concentration - ! autoconversion of cloud droplets - real(r8) :: prc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) - real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) - ! self-aggregation of snow - real(r8) :: nsagg(mgncol,nlev) ! number concentration - ! self-collection of rain - real(r8) :: nragg(mgncol,nlev) ! number concentration - ! collection of droplets by snow - real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio - real(r8) :: npsacws(mgncol,nlev) ! number concentration - ! collection of rain by snow - real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio - real(r8) :: npracs(mgncol,nlev) ! number concentration - ! freezing of rain - real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccr(mgncol,nlev) ! number concentration - ! freezing of rain to form ice (mg add 4/26/13) - real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccri(mgncol,nlev) ! number concentration - ! accretion of droplets by rain - real(r8) :: pra(mgncol,nlev) ! mass mixing ratio - real(r8) :: npra(mgncol,nlev) ! number concentration - ! autoconversion of cloud ice to snow - real(r8) :: prci(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprci(mgncol,nlev) ! number concentration - ! accretion of cloud ice by snow - real(r8) :: prai(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprai(mgncol,nlev) ! number concentration - ! evaporation of rain - real(r8) :: pre(mgncol,nlev) ! mass mixing ratio - ! sublimation of snow - real(r8) :: prds(mgncol,nlev) ! mass mixing ratio - ! number evaporation - real(r8) :: nsubi(mgncol,nlev) ! cloud ice - real(r8) :: nsubc(mgncol,nlev) ! droplet - real(r8) :: nsubs(mgncol,nlev) ! snow - real(r8) :: nsubr(mgncol,nlev) ! rain - ! bergeron process - real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) - real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) - -!++ag - !graupel/hail processes - real(r8) :: npracg(mgncol,nlev) ! change n collection rain by graupel (precipf) - real(r8) :: nscng(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) - real(r8) :: ngracs(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) - real(r8) :: nmultg(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) - real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel (precipf) - real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm) - - real(r8) :: psacr(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) - real(r8) :: pracg(mgncol,nlev) ! change in q collection rain by graupel (precipf) - real(r8) :: psacwg(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) - real(r8) :: pgsacw(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) - real(r8) :: pgracs(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) - real(r8) :: prdg(mgncol,nlev) ! dep of graupel (precipf) -! real(r8) :: eprdg(mgncol,nlev) ! evap/sub of graupel (precipf) - real(r8) :: qmultg(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) - real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf) -!--ag - - - ! fallspeeds - ! number-weighted - real(r8) :: uns(mgncol,nlev) ! snow - real(r8) :: unr(mgncol,nlev) ! rain -!++ag - real(r8) :: ung(mgncol,nlev) ! graupel/hail -!--ag - ! air density corrected fallspeed parameters - real(r8) :: arn(mgncol,nlev) ! rain - real(r8) :: asn(mgncol,nlev) ! snow -!++a - real(r8) :: agn(mgncol,nlev) ! graupel -!--ag - real(r8) :: acn(mgncol,nlev) ! cloud droplet - real(r8) :: ain(mgncol,nlev) ! cloud ice - real(r8) :: ajn(mgncol,nlev) ! cloud small ice - - ! Mass of liquid droplets used with external heterogeneous freezing. - real(r8) :: mi0l(mgncol) - - ! saturation vapor pressures - real(r8) :: esl(mgncol,nlev) ! liquid - real(r8) :: esi(mgncol,nlev) ! ice - real(r8) :: esn ! checking for RH after rain evap - - ! saturation vapor mixing ratios - real(r8) :: qvl(mgncol,nlev) ! liquid - real(r8) :: qvi(mgncol,nlev) ! ice - real(r8) :: qvn ! checking for RH after rain evap - - ! relative humidity - real(r8) :: relhum(mgncol,nlev) - - ! parameters for cloud water and cloud ice sedimentation calculations - real(r8) :: fc(mgncol,nlev) - real(r8) :: fnc(mgncol,nlev) - real(r8) :: fi(mgncol,nlev) - real(r8) :: fni(mgncol,nlev) - -!++ag - real(r8) :: fg(mgncol,nlev) - real(r8) :: fng(mgncol,nlev) -!--ag - - real(r8) :: fr(mgncol,nlev) - real(r8) :: fnr(mgncol,nlev) - real(r8) :: fs(mgncol,nlev) - real(r8) :: fns(mgncol,nlev) - - real(r8) :: faloutc(nlev) - real(r8) :: faloutnc(nlev) - real(r8) :: falouti(nlev) - real(r8) :: faloutni(nlev) - - real(r8) :: faloutr(nlev) - real(r8) :: faloutnr(nlev) - real(r8) :: falouts(nlev) - real(r8) :: faloutns(nlev) - - real(r8) :: faltndc - real(r8) :: faltndnc - real(r8) :: faltndi - real(r8) :: faltndni - real(r8) :: faltndqie - real(r8) :: faltndqce - - real(r8) :: faltndr - real(r8) :: faltndnr - real(r8) :: faltnds - real(r8) :: faltndns - -!++ag - real(r8) :: faloutg(nlev) - real(r8) :: faloutng(nlev) - real(r8) :: faltndg - real(r8) :: faltndng -!--ag - - real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation - - ! dummy variables - real(r8) :: dum - real(r8) :: dum1 - real(r8) :: dum2 -!++ag - real(r8) :: dum3 -!--ag - real(r8) :: dumni0 - real(r8) :: dumns0 - real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho - ! dummies for checking RH - real(r8) :: qtmp - real(r8) :: ttmp - ! dummies for conservation check - real(r8) :: ratio - real(r8) :: tmpfrz - ! dummies for in-cloud variables - real(r8) :: dumc(mgncol,nlev) ! qc - real(r8) :: dumnc(mgncol,nlev) ! nc - real(r8) :: dumi(mgncol,nlev) ! qi - real(r8) :: dumni(mgncol,nlev) ! ni - real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio - real(r8) :: dumnr(mgncol,nlev) ! rain number concentration - real(r8) :: dums(mgncol,nlev) ! snow mixing ratio - real(r8) :: dumns(mgncol,nlev) ! snow number concentration -!++ag - real(r8) :: dumg(mgncol,nlev) ! graupel mixing ratio - real(r8) :: dumng(mgncol,nlev) ! graupel number concentration -!--ag - ! Array dummy variable -! real(r8) :: dum_2D(mgncol,nlev) - real(r8) :: pdel_inv(mgncol,nlev) - real(r8) :: ts_au_loc(mgncol) - - ! loop array variables - ! "i" and "k" are column/level iterators for internal (MG) variables - ! "n" is used for other looping (currently just sedimentation) - integer i, k, n - - ! number of sub-steps for loops over "n" (for sedimentation) - integer nstep, mdust, nlb, nstep_def - - ! Varaibles to scale fall velocity between small and regular ice regimes. -! real(r8) :: irad, ifrac, tsfac - real(r8) :: irad, ifrac -! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. -! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.true. -! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. -! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & -! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) -! ts_au_min=180.0 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - - ! Process inputs - - ! assign variable deltat to deltatin - deltat = deltatin - oneodt = one / deltat -! nstep_def = max(1, nint(deltat/20)) - nstep_def = max(1, nint(deltat/5)) -! tsfac = log(ts_au/ts_au_min) * qiinv - - ! Copies of input concentrations that may be changed internally. - do k=1,nlev - do i=1,mgncol - qc(i,k) = qcn(i,k) - nc(i,k) = ncn(i,k) - qi(i,k) = qin(i,k) - ni(i,k) = nin(i,k) - qr(i,k) = qrn(i,k) - nr(i,k) = nrn(i,k) - qs(i,k) = qsn(i,k) - ns(i,k) = nsn(i,k) -!++ag - qg(i,k) = qgr(i,k) - ng(i,k) = ngr(i,k) - enddo - enddo - - ! cldn: used to set cldm, unused for subcolumns - ! liqcldf: used to set lcldm, unused for subcolumns - ! icecldf: used to set icldm, unused for subcolumns - - if (microp_uniform) then - ! subcolumns, set cloud fraction variables to one - ! if cloud water or ice is present, if not present - ! set to mincld (mincld used instead of zero, to prevent - ! possible division by zero errors). - - do k=1,nlev - do i=1,mgncol - - if (qc(i,k) >= qsmall) then - lcldm(i,k) = one - else - lcldm(i,k) = mincld - endif - - if (qi(i,k) >= qsmall) then - icldm(i,k) = one - else - icldm(i,k) = mincld - endif - - cldm(i,k) = max(icldm(i,k), lcldm(i,k)) -! qsfm(i,k) = one - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - - else ! get cloud fraction, check for minimum - do k=1,nlev - do i=1,mgncol - cldm(i,k) = max(cldn(i,k), mincld) - lcldm(i,k) = max(liqcldf(i,k), mincld) - icldm(i,k) = max(icecldf(i,k), mincld) - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - end if - -! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' lcldm=',lcldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icecldf=',icecldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icldm=',icldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' qsfm=',qsfm(1,nlev-20:nlev) - - ! Initialize local variables - - ! local physical properties - -! write(0,*)' in mg2 T=',t(1,:) -! write(0,*)' in mg2 P=',p(1,:),' r=',r - do k=1,nlev - do i=1,mgncol -! rho(i,k) = p(i,k) / (r*t(i,k)*(one+fv*q(i,k))) - rho(i,k) = p(i,k) / (r*t(i,k)) - rhoinv(i,k) = one / rho(i,k) - dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k) - mu(i,k) = 1.496E-6_r8 * t(i,k)*sqrt(t(i,k)) / (t(i,k) + 120._r8) - sc(i,k) = mu(i,k) / (rho(i,k)*dv(i,k)) - - ! 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*rhoinv(i,k))**0.54_r8 - - arn(i,k) = ar * rhof(i,k) - asn(i,k) = as * rhof(i,k) -!++ag if do hail then agn = ah *rhof else ag*rhof - agn(i,k) = agtmp * rhof(i,k) - acn(i,k) = g*rhow/(18._r8*mu(i,k)) - tx1 = (rhosu*rhoinv(i,k))**0.35_r8 - ain(i,k) = ai * tx1 - ajn(i,k) = aj * tx1 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Get humidity and saturation vapor pressures - -! do k=1,nlev -! do i=1,mgncol -! relvar(i,k) = relvar_i - accre_enhan(i,k) = accre_enhan_i -! call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) - esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) - qvl(i,k) = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) - - - ! make sure when above freezing that esi=esl, not active yet - if (t(i,k) >= tmelt) then - esi(i,k) = esl(i,k) - qvi(i,k) = qvl(i,k) - else -! call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) - esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) - qvi(i,k) = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) - end if - - ! Scale the water saturation values to reflect subgrid scale - ! ice cloud fraction, where ice clouds begin forming at a - ! gridbox average relative humidity of rhmini (not 1). - ! - ! NOTE: For subcolumns and other non-subgrid clouds, qsfm will be 1. - qvi(i,k) = qsfm(i,k) * qvi(i,k) -! esi(i,k) = qsfm(i,k) * esi(i,k) - qvl(i,k) = qsfm(i,k) * qvl(i,k) -! esl(i,k) = qsfm(i,k) * esl(i,k) - - relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) - end do - end do - - !=============================================== - - ! set mtime here to avoid answer-changing - mtime = deltat - - ! initialize microphysics output - do k=1,nlev - do i=1,mgncol - qcsevap(i,k) = zero - qisevap(i,k) = zero - qvres(i,k) = zero - cmeitot(i,k) = zero - vtrmc(i,k) = zero - vtrmi(i,k) = zero - qcsedten(i,k) = zero - qisedten(i,k) = zero - qrsedten(i,k) = zero - qssedten(i,k) = zero -!++ag - qgsedten(i,k) = zero -!--ag - - - pratot(i,k) = zero - prctot(i,k) = zero - mnuccctot(i,k) = zero - mnuccttot(i,k) = zero - msacwitot(i,k) = zero - psacwstot(i,k) = zero - bergstot(i,k) = zero - bergtot(i,k) = zero - melttot(i,k) = zero - homotot(i,k) = zero - qcrestot(i,k) = zero - prcitot(i,k) = zero - praitot(i,k) = zero - qirestot(i,k) = zero - mnuccrtot(i,k) = zero -!++ag - mnuccritot(i,k) = zero -!--ag - - pracstot(i,k) = zero - meltsdttot(i,k) = zero - frzrdttot(i,k) = zero - mnuccdtot(i,k) = zero - -!++ag - psacrtot(i,k) = zero - pracgtot(i,k) = zero - psacwgtot(i,k) = zero - pgsacwtot(i,k) = zero - pgracstot(i,k) = zero - prdgtot(i,k) = zero -! eprdgtot(i,k) = zero - qmultgtot(i,k) = zero - qmultrgtot(i,k) = zero - npracgtot(i,k) = zero - nscngtot(i,k) = zero - ngracstot(i,k) = zero - nmultgtot(i,k) = zero - nmultrgtot(i,k) = zero - npsacwgtot(i,k) = zero -!need to zero these out to be totally switchable (for conservation) - psacr(i,k) = zero - pracg(i,k) = zero - psacwg(i,k) = zero - pgsacw(i,k) = zero - pgracs(i,k) = zero - - prdg(i,k) = zero -! eprdg(i,k) = zero - qmultg(i,k) = zero - qmultrg(i,k) = zero - npracg(i,k) = zero - nscng(i,k) = zero - ngracs(i,k) = zero - nmultg(i,k) = zero - nmultrg(i,k) = zero - npsacwg(i,k) = zero -!--ag - rflx(i,k+1) = zero - sflx(i,k+1) = zero - lflx(i,k+1) = zero - iflx(i,k+1) = zero -!++ag - gflx(i,k+1) = zero -!--ag - - ! initialize precip output - - qrout(i,k) = zero - qsout(i,k) = zero - nrout(i,k) = zero - nsout(i,k) = zero -!++ag - qgout(i,k) = zero - ngout(i,k) = zero - dgout(i,k) = zero -!--ag - - ! for refl calc - rainrt(i,k) = zero - - ! initialize rain size - rercld(i,k) = zero - - qcsinksum_rate1ord(i,k) = zero - - ! initialize variables for trop_mozart - nevapr(i,k) = zero - prer_evap(i,k) = zero - evapsnow(i,k) = zero - am_evp_st(i,k) = zero - prain(i,k) = zero - prodsnow(i,k) = zero - cmeout(i,k) = zero - - precip_frac(i,k) = mincld - - lamc(i,k) = zero - - ! initialize microphysical tendencies - - tlat(i,k) = zero - qvlat(i,k) = zero - qctend(i,k) = zero - qitend(i,k) = zero - qstend(i,k) = zero - qrtend(i,k) = zero - nctend(i,k) = zero - nitend(i,k) = zero - nrtend(i,k) = zero - nstend(i,k) = zero -!++ag - qgtend(i,k) = zero - ngtend(i,k) = zero -!--ag - - ! initialize in-cloud and in-precip quantities to zero - qcic(i,k) = zero - qiic(i,k) = zero - qsic(i,k) = zero - qric(i,k) = zero -!++ag - qgic(i,k) = zero -!--ag - - - ncic(i,k) = zero - niic(i,k) = zero - nsic(i,k) = zero - nric(i,k) = zero -!++ag - ngic(i,k) = zero -!--ag - ! initialize precip fallspeeds to zero - ums(i,k) = zero - uns(i,k) = zero - umr(i,k) = zero - unr(i,k) = zero -!++ag - umg(i,k) = zero - ung(i,k) = zero -!--ag - - ! initialize limiter for output - qcrat(i,k) = one - - ! Many outputs have to be initialized here at the top to work around - ! ifort problems, even if they are always overwritten later. - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - effi(i,k) = 25._r8 - sadice(i,k) = zero - sadsnow(i,k) = zero - deffi(i,k) = 50._r8 - - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout(i,k) = zero - dsout2(i,k) = zero -!++ag - qgout2(i,k) = zero - ngout2(i,k) = zero - freqg(i,k) = zero - dgout2(i,k) = zero -!--ag - - freqr(i,k) = zero - freqs(i,k) = zero - - reff_rain(i,k) = zero - reff_snow(i,k) = zero -!++ag - reff_grau(i,k) = zero - lamg(i,k) = zero - n0g(i,k) = zero -!--ag - - refl(i,k) = -9999._r8 - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - csrfl(i,k) = zero - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - - ncal(i,k) = zero - ncai(i,k) = zero - - nfice(i,k) = zero - npccn(i,k) = zero - enddo - enddo -! - if (iccn == 1) then - do k=1,nlev - do i=1,mgncol - npccn(i,k) = npccnin(i,k) - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) - enddo - enddo - endif - - ! initialize precip at surface - - do i=1,mgncol - prect(i) = zero - preci(i) = zero - enddo - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! droplet activation - ! 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 (npccn) is read in from companion routine - - ! output activated liquid and ice (convert from #/kg -> #/m3) - !-------------------------------------------------- -! where (qc >= qsmall .and. lcldm > mincld) -! where (qc >= qsmall) -! npccn = max((npccnin*lcldm-nc)*oneodt, zero) -! nc = max(nc + npccn*deltat, zero) -! ncal = nc*rho/lcldm ! sghan minimum in #/cm3 -! elsewhere -! ncal = zero -! end where - -! if (lprnt) write(0,*)' nc1=',nc(1,:) - do k=1,nlev - do i=1,mgncol - if (qc(i,k) > qsmall .and. lcldm(i,k) >= mincld) then - npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) - nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, zero) - ncal(i,k) = nc(i,k) * rho(i,k) / lcldm(i,k) - else - ncal(i,k) = 0.0 - endif - enddo - enddo - - if (iccn == 1) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 -! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half - ncai(i,k) = naai(i,k)*rho(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - elseif (iccn == 2) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = naai(i,k)*rho(i,k) - ncai(i,k) = min(ncai(i,k), 710.0e3_r8) - naai(i,k) = ncai(i,k)*rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = ncai(i,k)*rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - - endif - - - !=============================================== - - ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% - ! - ! NOTE: If using gridbox average values, condensation will not occur until rh=1, - ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid - ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus - ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. - - !------------------------------------------------------- - - if (do_cldice) then - where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8) -! where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8 & -! .and. icldm > mincld ) - - !if NAAI > 0. then set numice = naai (as before) - !note: this is gridbox averaged - nnuccd = (naai-ni/icldm)/mtime*icldm - nnuccd = max(nnuccd, zero) - nimax = naai*icldm - - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - - mnuccd = nnuccd * mi0 - - elsewhere - nnuccd = zero - nimax = zero - mnuccd = zero - end where - - end if - - - !============================================================================= - do k=1,nlev - - do i=1,mgncol - - ! calculate instantaneous precip processes (melting and homogeneous freezing) - - ! melting of snow at +2 C - - if (t(i,k) > snowmelt) then - if (qs(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * qs(i,k) - if (t(i,k)+dum < snowmelt) then - dum = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) - else - dum = one - end if - - minstsm(i,k) = dum*qs(i,k) - ninstsm(i,k) = dum*ns(i,k) - - dum1 = - minstsm(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - -! if (lprnt .and. k >=40) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& -! ' minstsm=',minstsm(i,k),' qs=',qs(i,k),' xlf=',xlf,' oneodt=',oneodt, & -! ' snowmelt=',snowmelt,' t=',t(i,k),' dum=',dum,' k=',k - - qs(i,k) = max(qs(i,k) - minstsm(i,k), zero) - ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) - qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) - nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) - end if - end if - - end do - end do -! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qg1=',qg(1,:) - -!++ag - - if (do_graupel .or. do_hail) then -! melting of graupel at +2 C - - do k=1,nlev - do i=1,mgncol - - if (t(i,k) > snowmelt) then - if (qg(i,k) > zero) then - -! make sure melting graupel doesn't reduce temperature below threshold - dum = -(xlf/cpp) * qg(i,k) - if (t(i,k)+dum < snowmelt) then - dum = max(zero, min(one, (cpp/xlf)*(t(i,k)-snowmelt)/qg(i,k))) - else - dum = one - end if - - minstgm(i,k) = dum*qg(i,k) - ninstgm(i,k) = dum*ng(i,k) - - dum1 = - minstgm(i,k) * (xlf*oneodt) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - -! if (lprnt .and. k >=40) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& -! ' minstgm=',minstgm(i,k),' qg=',qg(i,k),' xlf=',xlf,' oneodt=',oneodt, & -! ' snowmelt=',snowmelt,' t=',t(i,k),' k=',k,' cpp=',cpp - - qg(i,k) = max(qg(i,k) - minstgm(i,k), zero) - ng(i,k) = max(ng(i,k) - ninstgm(i,k), zero) - qr(i,k) = max(qr(i,k) + minstgm(i,k), zero) - nr(i,k) = max(nr(i,k) + ninstgm(i,k), zero) - end if - end if - - end do - end do - endif - -! if (lprnt) write(0,*)' tlat1g=',tlat(1,:)*deltat -!--ag - - do k=1,nlev - do i=1,mgncol - ! freezing of rain at -5 C - - if (t(i,k) < rainfrze) then - - if (qr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * qr(i,k) - if (t(i,k)+dum > rainfrze) then - dum = -(t(i,k)-rainfrze) * (cpp/xlf) - dum = min(one, max(zero, dum/qr(i,k))) - else - dum = one - end if - - minstrf(i,k) = dum*qr(i,k) - ninstrf(i,k) = dum*nr(i,k) - - ! heating tendency - dum1 = minstrf(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - frzrdttot(i,k) = frzrdttot(i,k) + dum1 - - qr(i,k) = max(qr(i,k) - minstrf(i,k), zero) - nr(i,k) = max(nr(i,k) - ninstrf(i,k), zero) - -!++ag -! freeze rain to graupel not snow. - if(do_hail .or. do_graupel) then - qg(i,k) = max(qg(i,k) + minstrf(i,k), zero) - ng(i,k) = max(ng(i,k) + ninstrf(i,k), zero) - else - qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) - ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) - end if -!--ag - - end if - end if - end do - end do - -! if (lprnt) then -! write(0,*)' tlat2=',tlat(1,:)*deltat -! write(0,*)' lcldm=',lcldm(1,:) -! write(0,*)' qc=',qc(1,:) -! write(0,*)' nc=',nc(1,:) -! write(0,*)' qg2=',qg(1,:) -! endif - - do k=1,nlev - do i=1,mgncol - ! 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 - -! if (qc(i,k) >= qsmall .and. lcldm(i,k) > mincld) then - if (qc(i,k) >= qsmall) then - ! limit in-cloud values to 0.005 kg/kg - dum = one / lcldm(i,k) -! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - ncic(i,k) = max(nc(i,k)*dum, zero) - - ! specify droplet concentration - if (nccons) then - ncic(i,k) = ncnst * rhoinv(i,k) - end if - else - qcic(i,k) = zero - ncic(i,k) = zero - end if - -! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then - if (qi(i,k) >= qsmall) then - dum = one / icldm(i,k) -! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - niic(i,k) = max(ni(i,k)*dum, zero) - - ! switch for specification of cloud ice number - if (nicons) then - niic(i,k) = ninst * rhoinv(i,k) - end if - else - qiic(i,k) = zero - niic(i,k) = zero - end if - - end do - end do - - !======================================================================== - - ! for sub-columns cldm has already been set to 1 if cloud - ! water or ice is present, so precip_frac will be correctly set below - ! and nothing extra needs to be done here - - precip_frac = cldm - - micro_vert_loop: do k=1,nlev - - if (trim(micro_mg_precip_frac_method) == 'in_cloud') then - - if (k /= 1) then - where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) - precip_frac(:,k) = precip_frac(:,k-1) - end where - endif - - else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then - -!++ag add graupel to precip frac? - ! calculate precip fraction based on maximum overlap assumption - - ! if rain or snow mix ratios are smaller than threshold, - ! then leave precip_frac as cloud fraction at current level - if (k /= 1) then -!++ag -! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) -!--ag - where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) - precip_frac(:,k) = max(precip_frac(:,k-1), precip_frac(:,k)) - end where - end if - - endif - - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get size distribution parameters based on in-cloud cloud water - ! these calculations also ensure consistency between number and mixing ratio - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! cloud liquid - !------------------------------------------- - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' qcic=',qcic(1,k),' ncic=',ncic(1,k),' rho=',rho(1,k),' k=',k -! endif - call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' k=',k -! endif - - - !======================================================================== - ! 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 - - if (.not. do_sb_physics) then - call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & - ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) - endif - - ! assign qric based on prognostic qr, using assumed precip fraction - ! note: this could be moved above for consistency with qcic and qiic calculations - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg - qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - nric(i,k) = nr(i,k) * dum - - - ! add autoconversion to precip from above to get provisional rain mixing ratio - ! and number concentration (qric and nric) - - if(qric(i,k) < qsmall) then - qric(i,k) = zero - nric(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nric(i,k) = max(nric(i,k),zero) - enddo - ! Get size distribution parameters for cloud ice - - call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & - lami(:,k), mgncol, n0=n0i(:,k)) - - ! Alternative autoconversion - if (do_sb_physics) then - if (do_liq_liu) then - call liu_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k),mgncol) - else - call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) - endif - endif - - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - if (do_cldice) then - do i=1,mgncol - if (qiic(i,k) >= qimax) then -! if (qi(i,k) >= qimax) then - ts_au_loc(i) = ts_au_min - elseif (qiic(i,k) <= qimin) then -! elseif (qi(i,k) <= qimin) then - ts_au_loc(i) = ts_au - else -! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv - ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv -! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) - endif -! if (ts_au_loc(i) > ts_au_min) ts_au_loc(i) = ts_au_loc(i)*min(five,sqrt(p(i,nlev)/p(i,k))) - enddo -! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qiic=',qiic(1,k),& -! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qi=',qi(1,k),& -! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' qimin=',qimin,' qimax=',qimax -! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' tsfac=',tsfac,' qimin=',qimin,' qimax=',qimax - - if(do_ice_gmao) then - call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & - n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - else - call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & - dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - end if - !else - ! Add in the particles that we have already converted to snow, and - ! don't do any further autoconversion of ice. - !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) - !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) - end if - - ! note, currently we don't have this - ! inside the do_cldice block, should be changed later - ! assign qsic based on prognostic qs, using assumed precip fraction - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg - qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - nsic(i,k) = ns(i,k) * dum - - ! if precip mix ratio is zero so should number concentration - - if(qsic(i,k) < qsmall) then - qsic(i,k) = zero - nsic(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nsic(i,k) = max(nsic(i,k), zero) - -!++ also do this for graupel, which is assumed to be 'precip_frac' - qgic(i,k) = min(qg(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg) - ngic(i,k) = ng(i,k) * dum - - ! if precip mix ratio is zero so should number concentration - if (qgic(i,k) < qsmall) then - qgic(i,k) = zero - ngic(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - ngic(i,k) = max(ngic(i,k), zero) -!--ag - enddo - - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & - lamr(:,k), mgncol, n0=n0r(:,k)) - - do i=1,mgncol - if (lamr(i,k) >= qsmall) then - dum = arn(i,k) / lamr(i,k)**br - dum1 = 9.1_r8*rhof(i,k) - - ! provisional rain number and mass weighted mean fallspeed (m/s) - - umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) - unr(i,k) = min(dum1, dum*gamma_br_plus1) - else - - umr(i,k) = zero - unr(i,k) = zero - endif - enddo - - !...................................................................... - ! snow - - call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & - lams(:,k), mgncol, n0=n0s(:,k)) - - do i=1,mgncol - if (lams(i,k) >= qsmall) then - - ! provisional snow number and mass weighted mean fallspeed (m/s) - - dum = asn(i,k) / lams(i,k)**bs - dum1 = 1.2_r8*rhof(i,k) - ums(i,k) = min(dum1, dum*gamma_bs_plus4*oneo6) - uns(i,k) = min(dum1, dum*gamma_bs_plus1) - - else - ums(i,k) = zero - uns(i,k) = zero - endif - enddo - - if (do_graupel .or. do_hail) then -!++ag -!use correct bg or bh (bgtmp=bg or bh) - !...................................................................... - ! graupel/hail - -!++AG SET rhog here and for mg_graupel_props? -! For now: rhog is constant. Set to same in micro_mg_utils.F90 -! Ideally: find a method to set once. (Hail = 400, Graupel = 500 from M2005) - -!mg,snow_props or mg_graupel props? - - call size_dist_param_basic(mg_graupel_props, qgic(:,k), ngic(:,k), & - lamg(:,k), mgncol, n0=n0g(:,k)) - - do i=1,mgncol - if (lamg(i,k) >= qsmall) then - - ! provisional graupel/hail number and mass weighted mean fallspeed (m/s) - - dum = agn(i,k) / lamg(i,k)**bgtmp - dum1 = 20._r8*rhof(i,k) - umg(i,k) = min(dum1, dum*gamma_bg_plus4*oneo6) - ung(i,k) = min(dum1, dum*gamma_bg_plus1) -! umg(i,k) = min(dum1, dum*gamma(four+bgtmp)*oneo6) -! ung(i,k) = min(dum1, dum*gamma(one+bgtmp)) - - else - umg(i,k) = zero - ung(i,k) = zero - endif - enddo -!--ag - endif - - if (do_cldice) then - if (.not. use_hetfrz_classnuc) then - - ! heterogeneous freezing of cloud water - !---------------------------------------------- - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' qcic=',qcic(1,k),' ncic=',ncic(1,k),' t=',t(1,k),' k=',k,& -! ' relvar=',relvar(1,k) -! endif - - call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & - qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' mnuccca=',mnuccc(1,k),' lcldm=',lcldm(1,k),' nnuccc=',nnuccc(1,k),' k=',k -! endif - - ! make sure number of droplets frozen does not exceed available ice nuclei concentration - ! this prevents 'runaway' droplet freezing - -! where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8 .and. lcldm(:,k) > mincld) - where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8) - where (nnuccc(:,k)*lcldm(:,k) > nnuccd(:,k)) - ! scale mixing ratio of droplet freezing with limit - mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) - nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) - end where - end where - -! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnuccc=',mnuccc(1,60:65) -! if (lprnt .and. k >= 100) write(0,*)' mnuccc=',mnuccc(1,k) -! if (lprnt) write(0,*)' mnuccc=',mnuccc(1,k) - - mdust = size(rndst,3) - call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & - nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & - relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) - -! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnucct=',mnucct(1,:) -! if (lprnt .and. k >= 100 ) write(0,*)' mnucct=',mnucct(1,k) -! if (lprnt) write(0,*)' mnucct=',mnucct(1,k) - - mnudep(:,k) = zero - nnudep(:,k) = zero - - !else - - ! Mass of droplets frozen is the average droplet mass, except - ! with two limiters: concentration must be at least 1/cm^3, and - ! mass must be at least the minimum defined above. - !mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) - !mi0l = max(mi0l_min, mi0l) - - !where (qcic(:,k) >= qsmall) - !nnuccc(:,k) = frzimm(:,k)*1.0e6_r8*rhoinv(:,k) - !mnuccc(:,k) = nnuccc(:,k)*mi0l - - !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8*rhoinv(:,k) - !mnucct(:,k) = nnucct(:,k)*mi0l - - !nnudep(:,k) = frzdep(:,k)*1.0e6_r8*rhoinv(:,k) - !mnudep(:,k) = nnudep(:,k)*mi0 - !elsewhere - !nnuccc(:,k) = zero - !mnuccc(:,k) = zero - - !nnucct(:,k) = zero - !mnucct(:,k) = zero - - !nnudep(:,k) = zero - !mnudep(:,k) = zero - !end where - - end if - - else - do i=1,mgncol - mnuccc(i,k) = zero - nnuccc(i,k) = zero - mnucct(i,k) = zero - nnucct(i,k) = zero - mnudep(i,k) = zero - nnudep(i,k) = zero - enddo - end if - - call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & - nsagg(:,k), mgncol) - - call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & - qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & - psacws(:,k), npsacws(:,k), mgncol) - - if (do_cldice) then - call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) - else - nsacwi(:,k) = zero - msacwi(:,k) = zero - end if - - call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pracs(:,k), npracs(:,k), mgncol) - - call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & - mnuccr(:,k), nnuccr(:,k), mgncol) - - if (do_sb_physics) then - call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & - rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) - else - call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & - ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) - endif - - call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) - - if (do_cldice) then - call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & - qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) - else - prai(:,k) = zero - nprai(:,k) = zero - end if - -!++ag Moved below graupel conditional, now two different versions -! if (.not. (do_hail .or. do_graupel)) then -! call evaporate_sublimate_precip(t(:,k), rho(:,k), & -! dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & -! lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & -! qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & -! pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) -! endif -!--ag - - call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & - qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & - bergs(:,k), mgncol) -! if(lprnt) write(0,*)' bergs1=',bergs(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor -! if(lprnt) write(0,*)' t=',t(1,k),' rho=',rho(1,k),' dv=',dv(1,k),' mu=',mu(1,k),& -! 'qcic=',qcic(1,k),' qsic=',qsic(1,k),' qvl=',qvl(1,k),' qvi=',qvi(1,k), & -! ' mu=',mu(1,k),' sc=',sc(1,k),' asn=',asn(1,k),' lams=',lams(1,k),' n0s=',n0s(1,k) - - bergs(:,k) = bergs(:,k) * micro_mg_berg_eff_factor - - !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! - if (do_cldice) then - - call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & - icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & - berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) - -! if(lprnt) write(0,*)' t=',t(1,k),' k=',k,' q=',q(1,k),' qi=',qi(1,k),& -! ' ni=',ni(1,k),' icldm=',icldm(1,k),' rho=',rho(1,k),' dv=',dv(1,k),& -! ' qvl=',qvl(1,k),' qvi=',qvi(1,k),' berg=',berg(1,k),' vap_dep=',& -! vap_dep(1,k),' ice_sublim=',ice_sublim(1,k) -! if(lprnt) write(0,*)' berg1=',berg(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor - do i=1,mgncol -! sublimation should not exceed available ice - ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) - berg(i,k) = berg(i,k) * micro_mg_berg_eff_factor - if (ice_sublim(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then - nsubi(i,k) = sublim_factor * ice_sublim(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) - else - nsubi(i,k) = zero - endif - - ! bergeron process should not reduce nc unless - ! all ql is removed (which is handled elsewhere) - !in fact, nothing in this entire file makes nsubc nonzero. - nsubc(i,k) = zero - end do - - end if !do_cldice - !---PMC 12/3/12 - -!++ag Process rate calls for graupel here. -! (Should this be in do_cldice loop?) -!=================================================================== - - if(do_hail .or. do_graupel) then - call graupel_collecting_snow(qsic(:,k),qric(:,k),umr(:,k),ums(:,k), & - rho(:,k),lamr(:,k),n0r(:,k),lams(:,k),n0s(:,k), psacr(:,k), mgncol) - - call graupel_collecting_cld_water(qgic(:,k),qcic(:,k),ncic(:,k),rho(:,k), & - n0g(:,k),lamg(:,k),bgtmp,agn(:,k), psacwg(:,k), npsacwg(:,k), mgncol) - - call graupel_riming_liquid_snow(psacws(:,k),qsic(:,k),qcic(:,k),nsic(:,k), & - rho(:,k),rhosn,rhogtmp,asn(:,k),lams(:,k),n0s(:,k),deltat, & - pgsacw(:,k),nscng(:,k),mgncol) - -! if(lprnt .and. k >=100) then -! if(lprnt) then -! write(0,*)' k=',k,' qric=',qric(1,k),' qgic=',qgic(1,k),' umg=',umg(1,k),' umr=',umr(1,k),& -! ' ung=',ung(1,k),' unr=',unr(1,k),' rho=',rho(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k),& -! ' n0g=',n0g(1,k),' lamg=',lamg(1,k),' pracg=',pracg(1,k) -! endif - call graupel_collecting_rain(qric(:,k),qgic(:,k),umg(:,k), & - umr(:,k),ung(:,k),unr(:,k),rho(:,k),n0r(:,k),lamr(:,k),n0g(:,k), & - lamg(:,k), pracg(:,k),npracg(:,k),mgncol) -! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg=',pracg(1,k),' npracg=',npracg(1,k) - -!AG note: Graupel rain riming snow changes -! pracs, npracs, (accretion of rain by snow) psacr (collection of snow by rain) - -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& -! ' qsic=',qsic(1,k),' qric=',qric(1,k),' nric=',nric(1,k),' nsic=',nsic(1,k), & -! ' n0s=',n0s(1,k),' lams=',lams(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k), & -! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) - - call graupel_rain_riming_snow(pracs(:,k),npracs(:,k),psacr(:,k),qsic(:,k), & - qric(:,k),nric(:,k),nsic(:,k),n0s(:,k),lams(:,k),n0r(:,k),lamr(:,k), & - deltat,pgracs(:,k),ngracs(:,k),mgncol) -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& -! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) - - call graupel_rime_splintering(t(:,k),qcic(:,k),qric(:,k),qgic(:,k), & - psacwg(:,k),pracg(:,k),qmultg(:,k),nmultg(:,k),qmultrg(:,k), & - nmultrg(:,k),mgncol) - -! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg2=',pracg(1,k) -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracg2=',pracg(1,k) - - call evaporate_sublimate_precip_graupel(t(:,k), rho(:,k), & - dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & - lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), agn(:,k), bgtmp, & - qcic(:,k), qiic(:,k), qric(:,k), qsic(:,k), qgic(:,k), & - lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), lamg(:,k), n0g(:,k), & - pre(:,k), prds(:,k), prdg(:,k), am_evp_st(:,k), mgncol) - -!!Not used: part of above -!! call graupel_sublimate_evap(t(:,k),q(:,k),qgic(:,k),rho(:,k),n0g(:,k), & -!! lamg(:,k),qvi(:,k),dv(:,k),mu(:,k),sc(:,k),bgtmp,agn(:,k), & -!! prdg(:,k),eprdg(:,k),mgncol) - -!Checks for Debugging - -! if (minval(qmultg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, qmultg < 0 : min=",minval(qmultg(:,k)) -! -! if (minval(qmultrg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, qmultrg < 0 : min=",minval(qmultrg(:,k)) -! -! if (minval(pgracs(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, pgracs < 0 : min=",minval(pgracs(:,k)) -! -! if (minval(psacwg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, psacwg < 0 : min=",minval(psacwg(:,k)) -! -! if (minval(npsacwg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, npsacwg < 0 : min=",minval(npsacwg(:,k)) -! -! if (minval(pracg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, pracg < 0 : min=",minval(pracg(:,k)) -! -! if (maxval(prdg(:,k)).gt.0._r8) & -! write(iulog,*) "OOPS, prdg > 0 : max=",maxval(prdg(:,k)) -! -! if (minval(nmultg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nmultg < 0 : min=",minval(nmultg(:,k)) -! -! if (minval(nmultrg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nmultrg < 0 : min=",minval(nmultrg(:,k)) -! -! if (minval(ngracs(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, ngracs < 0 : min=",minval(ngracs(:,k)) -! -! if (minval(psacr(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, psacr < 0 : min=",minval(psacr(:,k)) -! -! if (minval(nscng(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nscng < 0 : min=",minval(nscng(:,k)) - - else -! Routine without Graupel (original) - call evaporate_sublimate_precip(t(:,k), rho(:,k), & - dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & - lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) - - - end if ! end do_graupel/hail loop -!--ag - - do i=1,mgncol - - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - !=================================================================== - - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - - ! conservation of qc - !------------------------------------------------------------------- - -!++ag Add graupel tendencies for qc to equation ON -! dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & -! psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat - dum = ( (prc(i,k) + pra(i,k) + mnuccc(i,k) + mnucct(i,k) + msacwi(i,k) & - + psacws(i,k) + bergs(i,k) + qmultg(i,k) + psacwg(i,k) + pgsacw(i,k))*lcldm(i,k) & - + berg(i,k) ) * deltat -!--ag - - if (dum > qc(i,k) .and. abs(dum) > qsmall) then -!++ag -! ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & -! msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm - - ratio = qc(i,k) / dum * omsm - - qmultg(i,k) = ratio * qmultg(i,k) - psacwg(i,k) = ratio * psacwg(i,k) - pgsacw(i,k) = ratio * pgsacw(i,k) -!--ag - prc(i,k) = ratio * prc(i,k) - pra(i,k) = ratio * pra(i,k) - mnuccc(i,k) = ratio * mnuccc(i,k) - mnucct(i,k) = ratio * mnucct(i,k) - msacwi(i,k) = ratio * msacwi(i,k) - psacws(i,k) = ratio * psacws(i,k) - bergs(i,k) = ratio * bergs(i,k) - berg(i,k) = ratio * berg(i,k) - qcrat(i,k) = ratio - else - qcrat(i,k) = one - end if - -! if(lprnt) write(0,*)' bergs2=',bergs(1,k),' k=',k,' ratio=',ratio - - !PMC 12/3/12: ratio is also frac of step w/ liquid. - !thus we apply berg for "ratio" of timestep and vapor - !deposition for the remaining frac of the timestep. - if (qc(i,k) >= qsmall) then - vap_dep(i,k) = vap_dep(i,k) * (one-qcrat(i,k)) - end if - - end do - - do i=1,mgncol - - !================================================================= - ! apply limiter to ensure that ice/snow sublimation and rain evap - ! don't push conditions into supersaturation, and ice deposition/nucleation don't - ! push conditions into sub-saturation - ! note this is done after qc conservation since we don't know how large - ! vap_dep is before then - ! estimates are only approximate since other process terms haven't been limited - ! for conservation yet - - ! first limit ice deposition/nucleation vap_dep + mnuccd - - dum1 = vap_dep(i,k) + mnuccd(i,k) - if (dum1 > 1.e-20_r8) then - dum = (q(i,k)-qvi(i,k))/(one + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)*t(i,k)))*oneodt - dum = max(dum, zero) - if (dum1 > dum) then - ! Allocate the limited "dum" tendency to mnuccd and vap_dep - ! processes. Don't divide by cloud fraction; these are grid- - ! mean rates. - dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) - mnuccd(i,k) = dum*dum1 - vap_dep(i,k) = dum - mnuccd(i,k) - end if - end if - - end do - - do i=1,mgncol - - !=================================================================== - ! conservation of nc - !------------------------------------------------------------------- -!++ag NEW ONE ON -! dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & -! npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat - dum = (nprc1(i,k) + npra(i,k) + nnuccc(i,k) + nnucct(i,k) & - + npsacws(i,k) - nsubc(i,k) + npsacwg(i,k))*lcldm(i,k)*deltat -!--ag - - if (dum > nc(i,k) .and. abs(dum) > qsmall) then - ratio = nc(i,k) / dum * omsm -!++ag - npsacwg(i,k) = ratio * npsacwg(i,k) -!--ag - - nprc1(i,k) = ratio * nprc1(i,k) - npra(i,k) = ratio * npra(i,k) - nnuccc(i,k) = ratio * nnuccc(i,k) - nnucct(i,k) = ratio * nnucct(i,k) - npsacws(i,k) = ratio * npsacws(i,k) - nsubc(i,k) = ratio * nsubc(i,k) - end if - - mnuccri(i,k) = zero - nnuccri(i,k) = zero - - if (do_cldice) then - - ! freezing of rain to produce ice if mean rain size is smaller than Dcs - if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = zero - nnuccr(i,k) = zero - end if - end if - - end do - - do i=1,mgncol - - ! conservation of rain mixing ratio - !------------------------------------------------------------------- -!++ag Implemented change for graupel - dum1 = - pre(i,k) + pracs(i,k) + mnuccr(i,k) + mnuccri(i,k) & - + qmultrg(i,k) + pracg(i,k) + pgracs(i,k) - dum3 = dum1 * precip_frac(i,k) - dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) - dum = (dum3 - dum2) * deltat -!--ag - - ! note that qrtend is included below because of instantaneous freezing/melt - if (dum > qr(i,k) .and. dum1 >= qsmall .and. abs(dum3) > qsmall) then - ratio = (qr(i,k)*oneodt + dum2) / dum3 * omsm -!++ag - qmultrg(i,k) = ratio * qmultrg(i,k) - pracg(i,k) = ratio * pracg(i,k) - pgracs(i,k) = ratio * pgracs(i,k) -!--ag - pre(i,k) = ratio * pre(i,k) - pracs(i,k) = ratio * pracs(i,k) - mnuccr(i,k) = ratio * mnuccr(i,k) - mnuccri(i,k) = ratio * mnuccri(i,k) - end if - - end do - - do i=1,mgncol - - ! conservation of rain number - !------------------------------------------------------------------- - - ! Add evaporation of rain number. - if (pre(i,k) < zero) then - dum = max(-one, pre(i,k)*deltat/qr(i,k)) - nsubr(i,k) = dum*nr(i,k) * oneodt - else - nsubr(i,k) = zero - end if - - end do - - do i=1,mgncol - -!++ag IMplemented change for graupel -! dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) -! nprc(i,k)*lcldm(i,k))*deltat - - dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k) & - +npracg(i,k)+ngracs(i,k))*precip_frac(i,k) - dum2 = nprc(i,k)*lcldm(i,k) - dum = (dum1 - dum2) * deltat -!--ag - - if (dum > nr(i,k) .and. abs(dum1) > qsmall) then - ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm - -!++ag - npracg(i,k) = ratio * npracg(i,k) - ngracs(i,k) = ratio * ngracs(i,k) -!--ag - nragg(i,k) = ratio * nragg(i,k) - npracs(i,k) = ratio * npracs(i,k) - nnuccr(i,k) = ratio * nnuccr(i,k) - nsubr(i,k) = ratio * nsubr(i,k) - nnuccri(i,k) = ratio * nnuccri(i,k) - end if - - end do - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of qi - !------------------------------------------------------------------- - -!++ag - - dum1 = (prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k) -! dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & -! + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k) & -! + mnuccri(i,k)*precip_frac(i,k) - dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & - + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k) & - + (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k) - dum = (dum1 - dum2) * deltat -!-ag - - if (dum > qi(i,k) .and. abs(dum1) > qsmall) then - ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm - -!++ag -! Only sink terms are limited. -! qmultg(i,k) = ratio * qmultg(i,k) -! qmultrg(i,k) = ratio * qmultrg(i,k) -!--ag - prci(i,k) = ratio * prci(i,k) - prai(i,k) = ratio * prai(i,k) - ice_sublim(i,k) = ratio * ice_sublim(i,k) - end if - - end do - - end if - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of ni - !------------------------------------------------------------------- - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if -!++ag - dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) -! dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & -! + nnuccri(i,k)*precip_frac(i,k) - dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & - + (nmultrg(i,k)+nnuccri(i,k))*precip_frac(i,k) -!--ag - dum = (dum1 - dum2) * deltat - - if (dum > ni(i,k) .and. abs(dum1) > qsmall) then - ratio = (ni(i,k)*oneodt + dum2) / dum1 * omsm - - nprci(i,k) = ratio * nprci(i,k) - nprai(i,k) = ratio * nprai(i,k) - nsubi(i,k) = ratio * nsubi(i,k) - end if - - end do - - end if - - do i=1,mgncol - - ! conservation of snow mixing ratio - !------------------------------------------------------------------- -!++ag - if (do_hail .or. do_graupel) then -!NOTE: mnuccr is moved to graupel when active -!psacr is a positive value, but a loss for snow -!HM: psacr is positive in dum (two negatives) - - dum1 = (psacr(i,k) - prds(i,k)) * precip_frac(i,k) - dum2 = pracs(i,k)*precip_frac(i,k) & - + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - if (dum > qs(i,k) .and. psacr(i,k)-prds(i,k) >= qsmall) then - ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - psacr(i,k) = ratio * psacr(i,k) - prds(i,k) = ratio * prds(i,k) - endif - else - dum1 = - prds(i,k) * precip_frac(i,k) - dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then - ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - prds(i,k) = ratio * prds(i,k) - endif - endif - -!--ag -! dum1 = - prds(i,k) * precip_frac(i,k) -! dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & -! + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - -! dum = (dum1 - dum2) * deltat - -! if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then -! ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - -! prds(i,k) = ratio * prds(i,k) -! end if - - end do - - do i=1,mgncol - - ! conservation of snow number - !------------------------------------------------------------------- - ! calculate loss of number due to sublimation - ! for now neglect sublimation of ns - nsubs(i,k) = zero - - ratio = one -!++ag Watch sign of nscng and ngracs. What is sign of nnuccr? Negative? Should be a source here. - - if (do_hail .or. do_graupel) then -! dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) -! dum2 = nprci(i,k)*icldm(i,k) + nscng(i,k)*lcldm(i,k) -! dum = (dum1 - dum2) * deltat -! check here - this is slightly different from ag version - moorthi - - dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) & - - nscng(i,k)*lcldm(i,k) - dum2 = nprci(i,k)*icldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ns(i,k) .and. abs(dum1) > qsmall) then - ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm - nscng(i,k) = ratio * nscng(i,k) - ngracs(i,k) = ratio * ngracs(i,k) - end if - - else - dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) - dum2 = nnuccr(i,k)*precip_frac(i,k) + nprci(i,k)*icldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ns(i,k) .and. abs(dum1) > qsmall) then - ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm - end if - endif - nsubs(i,k) = ratio * nsubs(i,k) - nsagg(i,k) = ratio * nsagg(i,k) - - end do - -!++ag Graupel Conservation Checks -!------------------------------------------------------------------- - if (do_hail .or. do_graupel) then -! conservation of graupel mass -!------------------------------------------------------------------- - do i=1,mgncol - - dum1 = -prdg(i,k) * precip_frac(i,k) - dum2 = (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > qg(i,k) .and. abs(dum1) > qsmall) then - -! hm added -! note: prdg is always negative (like prds), so it needs to be subtracted in ratio - ratio = (qg(i,k)*oneodt + dum2) / dum1 * omsm - - prdg(i,k) = ratio * prdg(i,k) - - end if - - end do - -! conservation of graupel number: not needed, no sinks -!------------------------------------------------------------------- - end if -!--ag - - - do i=1,mgncol - - ! next limit ice and snow sublimation and rain evaporation - ! get estimate of q and t at end of time step - ! don't include other microphysical processes since they haven't - ! been limited via conservation checks yet - -!++ag need to add graupel sublimation/evap here too (prdg)? May not need eprdg? -!++ag - tx1 = pre(i,k) * precip_frac(i,k) - tx2 = prds(i,k) * precip_frac(i,k) - tx6 = prdg(i,k) * precip_frac(i,k) - tx5 = tx2 + tx6 - tx3 = tx1 + tx5 + ice_sublim(i,k) - - if (tx3 < -1.e-20_r8) then - - tx4 = tx5 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) - qtmp = q(i,k) - (tx1 + tx4) * deltat - ttmp = t(i,k) + (tx1*xxlv + tx4*xxls) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - ! call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn/(p(i,k)-omeps*esn) - - ! modify ice/precip evaporation rate if q > qsat - if (qtmp > qvn) then - - tx4 = one / tx3 - dum1 = tx1 * tx4 - dum2 = tx2 * tx4 -!++ag - dum3 = tx6 * tx4 -!--ag - ! recalculate q and t after vap_dep and mnuccd but without evap or sublim - tx5 = (vap_dep(i,k)+mnuccd(i,k)) * deltat - qtmp = q(i,k) - tx5 - ttmp = t(i,k) + tx5 * (xxls/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn / (p(i,k)-omeps*esn) - - dum = min(zero, (qtmp-qvn)/(one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp))) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - if (precip_frac(i,k) > mincld) then - tx4 = oneodt / precip_frac(i,k) - else - tx4 = zero - endif - pre(i,k) = dum*dum1*tx4 - - ! do separately using RHI for prds and ice_sublim - !call qsat_ice(ttmp, p(i,k), esn, qvn) - esn = min(fpvsi(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn / (p(i,k)-omeps*esn) - - - dum = min(zero, (qtmp-qvn)/(one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp))) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - prds(i,k) = dum*dum2*tx4 -!++ag - prdg(i,k) = dum*dum3*tx4 -!--ag -!++ag - ! don't divide ice_sublim by cloud fraction since it is grid-averaged -! dum1 = one - dum1 - dum2 - dum1 = one - dum1 - dum2 - dum3 -!--ag - ice_sublim(i,k) = dum*dum1*oneodt - end if - end if - - end do - - ! Big "administration" loop enforces conservation, updates variables - ! that accumulate over substeps, and sets output variables. - - do i=1,mgncol - - ! get tendencies due to microphysical conversion processes - !========================================================== - ! note: tendencies are multiplied by appropriate cloud/precip - ! fraction to get grid-scale values - ! note: vap_dep is already grid-average values - - ! The net tendencies need to be added to rather than overwritten, - ! because they may have a value already set for instantaneous - ! melting/freezing. - -!++ag -! qvlat(i,k) = qvlat(i,k) - (pre(i,k)+prds(i,k))*precip_frac(i,k)-& -! vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) - - qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k) & - -vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) & - -prdg(i,k)*precip_frac(i,k) - -! tlat(i,k) = tlat(i,k) + ((pre(i,k)*precip_frac(i,k)) & -! *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & -! ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & -! pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) - -! if (lprnt .and. k >= 60 .and. k <=65) & -! if (lprnt .and. k >= 100 ) & -! if (lprnt .and. abs(k-81) <5) & -! if (lprnt .and. k >= 60 ) & -! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& -! ' prds=',prds(i,k),' prdg=',prdg(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & -! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & -! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & -! ' psacwg=',psacwg(i,k),' qmultg=',qmultg(i,k),' pgsacw=',pgsacw(i,k),' mnuccr=',mnuccr(i,k), & -! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' pracg=',pracg(i,k),' pgracs=',pgracs(i,k), & -! ' qmultrg=',qmultrg(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls - - - tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & - ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+ & - mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & - ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacwg(i,k)+ & - qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ & - (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ & - berg(i,k))*xlf) - -! if (lprnt .and. k >= 100 ) write(0,*)' k=',k,' tlat=',tlat(i,k) -! if (lprnt) write(0,*)' k=',k,' tlat=',tlat(i,k) -! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) - -! qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & -! psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) - - qctend(i,k) = qctend(i,k) + & - (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k) - & - psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k) - if (do_cldice) then -! qitend(i,k) = qitend(i,k) + & -! (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & -! prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & -! mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) - - qitend(i,k) = qitend(i,k)+ & - (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k)) * lcldm(i,k) & - + (-prci(i,k)-prai(i,k)) * icldm(i,k) & - + vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+mnuccd(i,k) & - + (mnuccri(i,k)+qmultrg(i,k)) * precip_frac(i,k) - - end if - -! qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & -! mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) - - qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k)-qmultrg(i,k)-pracg(i,k)-pgracs(i,k))*precip_frac(i,k) - - -! qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & -! + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - - if (do_hail.or.do_graupel) then - qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) - - qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & - + (prds(i,k)+pracs(i,k)-psacr(i,k))*precip_frac(i,k) - - else - !necessary since mnuccr moved to graupel - qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & - + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - - end if -!--ag - - - cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! add output for cmei (accumulate) - cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! assign variables for trop_mozart, these are grid-average - !------------------------------------------------------------------- - ! evaporation/sublimation is stored here as positive term - -!++add evaporation/sublimation of graupel too? YES: After conservation checks. - -!++ag -!ADD GRAUPEL to evapsnow: prdg. (sign? same as prds: negative, so this is a positive number) -! evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) - evapsnow(i,k) = (-prds(i,k)-prdg(i,k)) * precip_frac(i,k) -!--ag - nevapr(i,k) = -pre(i,k) * precip_frac(i,k) - prer_evap(i,k) = -pre(i,k) * precip_frac(i,k) - - ! change to make sure prain is positive: do not remove snow from - ! prain used for wet deposition - -!++AG NEED TO MAKE CONSISTENT WITH BUDGETS - prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k) & - - (pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k) - if (do_hail .or. do_graupel) then -! Subtract PSACR here or not? Ask Hugh - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & - pracs(i,k)*precip_frac(i,k) - else - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & - (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - end if - - ! 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 = { rate of direct transfer of cloud water to rain & snow } - ! (no cloud ice or bergeron terms) - -!++AG NEED TO MAKE CONSITANT: PGSACW, PSACWG (check budgets)? More sink terms? Check. No. Just loss to precip. -!Ask Hugh -! qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) - qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) -!--ag - ! Avoid zero/near-zero division. - qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) - - - ! microphysics output, note this is grid-averaged - pratot(i,k) = pra(i,k) * lcldm(i,k) - prctot(i,k) = prc(i,k) * lcldm(i,k) - mnuccctot(i,k) = mnuccc(i,k) * lcldm(i,k) - mnuccttot(i,k) = mnucct(i,k) * lcldm(i,k) - msacwitot(i,k) = msacwi(i,k) * lcldm(i,k) - psacwstot(i,k) = psacws(i,k) * lcldm(i,k) - bergstot(i,k) = bergs(i,k) * lcldm(i,k) - bergtot(i,k) = berg(i,k) - prcitot(i,k) = prci(i,k) * icldm(i,k) - praitot(i,k) = prai(i,k) * icldm(i,k) - mnuccdtot(i,k) = mnuccd(i,k) * icldm(i,k) - - pracstot(i,k) = pracs(i,k) * precip_frac(i,k) - mnuccrtot(i,k) = mnuccr(i,k) * precip_frac(i,k) -!++ag - mnuccritot(i,k) = mnuccri(i,k) * precip_frac(i,k) -!--ag - -!++ag Hail/Graupel tendencies for output - psacrtot(i,k) = psacr(i,k) * precip_frac(i,k) - pracgtot(i,k) = pracg(i,k) * precip_frac(i,k) - psacwgtot(i,k) = psacwg(i,k) * lcldm(i,k) - pgsacwtot(i,k) = pgsacw(i,k) * lcldm(i,k) - pgracstot(i,k) = pgracs(i,k) * precip_frac(i,k) - prdgtot(i,k) = prdg(i,k) * precip_frac(i,k) - qmultgtot(i,k) = qmultg(i,k) * lcldm(i,k) - qmultrgtot(i,k) = qmultrg(i,k) * precip_frac(i,k) - npracgtot(i,k) = npracg(i,k) * precip_frac(i,k) - nscngtot(i,k) = nscng(i,k) * lcldm(i,k) - ngracstot(i,k) = ngracs(i,k) * precip_frac(i,k) - nmultgtot(i,k) = nmultg(i,k) * lcldm(i,k) - nmultrgtot(i,k) = nmultrg(i,k) * precip_frac(i,k) - npsacwgtot(i,k) = npsacwg(i,k) * lcldm(i,k) -!--ag - -!++ag -! nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & -! - npra(i,k)-nprc1(i,k))*lcldm(i,k) - - nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & - -npra(i,k)-nprc1(i,k)-npsacwg(i,k))*lcldm(i,k) - - if (do_cldice) then - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if -! nitend(i,k) = nitend(i,k) + nnuccd(i,k)+ & -! (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & -! nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) - - nitend(i,k) = nitend(i,k) + nnuccd(i,k) & - + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & - + (nsubi(i,k)-nprci(i,k)-nprai(i,k))*icldm(i,k) & - + (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k) - end if - - if(do_graupel.or.do_hail) then -! nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & -! + nprci(i,k)*icldm(i,k) - - nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)-ngracs(i,k))*precip_frac(i,k) & - + nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k) - - ngtend(i,k) = ngtend(i,k) + nscng(i,k)*lcldm(i,k) & - + (ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k) - - else - !necessary since mnuccr moved to graupel - nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & - + nprci(i,k)*icldm(i,k) - - end if - -! nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & -! - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) - - nrtend(i,k) = nrtend(i,k)+ nprc(i,k)*lcldm(i,k) & - + (nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & - -nnuccri(i,k)+nragg(i,k)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k) -!--ag - - ! make sure that ni at advanced time step does not exceed - ! maximum (existing N + source terms*dt), which is possible if mtime < deltat - ! note that currently mtime = deltat - !================================================================ - - if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then - nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) - end if - - end do - - ! End of "administration" loop - - end do micro_vert_loop ! end k loop - -! if (lprnt) write(0,*)' tlat3=',tlat(1,:)*deltat - !----------------------------------------------------- - ! convert rain/snow q and N for output to history, note, - ! output is for gridbox average - - do k=1,nlev - do i=1,mgncol - qrout(i,k) = qr(i,k) - nrout(i,k) = nr(i,k) * rho(i,k) - qsout(i,k) = qs(i,k) - nsout(i,k) = ns(i,k) * rho(i,k) -!++ag - qgout(i,k) = qg(i,k) - ngout(i,k) = ng(i,k) * rho(i,k) -!--ag - enddo - enddo - - ! calculate n0r and lamr from rain mass and number - ! divide by precip fraction to get in-precip (local) values of - ! rain mass and number, divide by rhow to get rain number in kg^-1 - - do k=1,nlev - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) - - enddo - ! Calculate rercld - - ! calculate mean size of combined rain and cloud water - - call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol, nlev) - - - ! Assign variables back to start-of-timestep values - ! Some state variables are changed before the main microphysics loop - ! to make "instantaneous" adjustments. Afterward, we must move those changes - ! back into the tendencies. - ! These processes: - ! - Droplet activation (npccn, impacts nc) - ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) - ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) - !================================================================================ - - do k=1,nlev - do i=1,mgncol - ! Re-apply droplet activation tendency - nc(i,k) = ncn(i,k) - nctend(i,k) = nctend(i,k) + npccn(i,k) - - ! Re-apply rain freezing and snow melting. - qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt - qs(i,k) = qsn(i,k) - - nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt - ns(i,k) = nsn(i,k) - - qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt - qr(i,k) = qrn(i,k) - - nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt - nr(i,k) = nrn(i,k) - -!++ag Re-apply graupel freezing/melting - qgtend(i,k) = qgtend(i,k) + (qg(i,k)-qgr(i,k)) * oneodt - qg(i,k) = qgr(i,k) - -! if (maxval(dum_2D-qg).gt.0._r8) & -! write(iulog,*) "OOPS, qg diff > 0 : max=",maxval(dum_2D-qg) -! if (minval(dum_2D-qg).lt.0._r8) & -! write(iulog,*) "OOPS, qg diff < 0 : min=",minval(dum_2D-qg) -! -! write(iulog,*) "Max qgtend: 1st = ",maxval(qgtend) -! write(iulog,*) "Min qgtend: 1st = ",minval(qgtend) -! write(iulog,*) "Max qvtend: 1st = ",maxval(qvlat) -! write(iulog,*) "Min qvtend: 1st = ",minval(qvlat) - - ngtend(i,k) = ngtend(i,k) + (ng(i,k)-ngr(i,k)) * oneodt - ng(i,k) = ngr(i,k) -!--ag - - !............................................................................. - - !================================================================================ - - ! modify to include snow. in prain & evap (diagnostic here: for wet dep) - nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) - prain(i,k) = prain(i,k) + prodsnow(i,k) - - - enddo - enddo - - do k=1,nlev - - do i=1,mgncol - - ! calculate sedimentation for cloud water and ice -!++ag ! and Graupel (mg3) - !================================================================================ - - ! 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 - - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) * tx1 - dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k) - end if - else - dumc(i,k) = zero - dumnc(i,k) = zero - endif - if (icldm(i,k) > mincld) then - tx1 = one / icldm(i,k) - dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) * tx1 - dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx1, zero) - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k) - end if - else - dumi(i,k) = zero - dumni(i,k) = zero - endif - if (precip_frac(i,k) > mincld) then - tx1 = one / precip_frac(i,k) - dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) * tx1 - dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) * tx1 - - dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)*tx1, zero) - dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)*tx1, zero) - -!++ag Add graupel - dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 -! Moorthi testing - if (dumg(i,k) > 0.01_r8) then - tx2 = dumg(i,k) - 0.01_r8 - dumg(i,k) = 0.01_r8 - dums(i,k) = dums(i,k) + tx2 - qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt - qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt - endif -! Moorthi testing - - dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)*tx1, zero) - ! switch for specification of droplet and crystal number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k) - endif -!--ag - else - dumr(i,k) = zero - dumr(i,k) = zero - dums(i,k) = zero - dumns(i,k) = zero -!++ag Add graupel - dumg(i,k) = zero - dumng(i,k) = zero - endif -!--ag - enddo - enddo - - do k=1,nlev - -! obtain new slope parameter to avoid possible singularity - - call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & - lami(:,k), mgncol) - - call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) - -! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & -! lami(:,k), mgncol) -! fallspeed for rain - - call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & - lamr(:,k), mgncol) -! fallspeed for snow - call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & - lams(:,k), mgncol) -! fallspeed for graupel/hail - if (do_graupel .or. do_hail) then - call size_dist_param_basic(mg_graupel_props, dumg(:,k), dumng(:,k), & - lamg(:,k), mgncol) - endif - enddo - - do k=1,nlev - do i=1,mgncol - - ! calculate number and mass weighted fall velocity for droplets and cloud ice - !------------------------------------------------------------------- - - grho = g*rho(i,k) - - if (dumc(i,k) >= qsmall) then - - tx1 = lamc(i,k)**bc - vtrmc(i,k) = acn(i,k)*gamma(pgam(i,k)+four+bc) & - / (tx1*gamma(pgam(i,k)+four)) - - fc(i,k) = grho * vtrmc(i,k) - fnc(i,k) = grho * acn(i,k)*gamma(pgam(i,k)+one+bc) & - / (tx1*gamma(pgam(i,k)+one)) - else - fc(i,k) = zero - fnc(i,k) = zero - end if - - ! calculate number and mass weighted fall velocity for cloud ice - - if (dumi(i,k) >= qsmall) then - - tx3 = one / lami(i,k) - tx1 = ain(i,k) * tx3**bi - tx2 = 1.2_r8*rhof(i,k) - vtrmi(i,k) = min(tx1*gamma_bi_plus4*oneo6, tx2) - - fi(i,k) = grho * vtrmi(i,k) - fni(i,k) = grho * min(tx1*gamma_bi_plus1, tx2) - - ! adjust the ice fall velocity for smaller (r < 20 um) ice - ! particles (blend over 18-20 um) - irad = (1.5_r8 * 1e6_r8) * tx3 - ifrac = min(one, max(zero, (irad-18._r8)*half)) - - if (ifrac < one) then - tx1 = ajn(i,k) / lami(i,k)**bj - vtrmi(i,k) = ifrac*vtrmi(i,k) + (one-ifrac) * min(tx1*gamma_bj_plus4*oneo6, tx2) - - fi(i,k) = grho * vtrmi(i,k) - fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) - end if - else - fi(i,k) = zero - fni(i,k)= zero - end if - - ! fallspeed for rain - -! if (lamr(i,k) >= qsmall) then - if (dumr(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - - tx1 = arn(i,k) / lamr(i,k)**br - tx2 = 9.1_r8*rhof(i,k) - umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) - unr(i,k) = min(tx1*gamma_br_plus1, tx2) - - fr(i,k) = grho * umr(i,k) - fnr(i,k) = grho * unr(i,k) - - else - fr(i,k) = zero - fnr(i,k) = zero - end if - - ! fallspeed for snow - -! if (lams(i,k) >= qsmall) then - if (dums(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - tx1 = asn(i,k) / lams(i,k)**bs - tx2 = 1.2_r8*rhof(i,k) - ums(i,k) = min(tx1*gamma_bs_plus4*oneo6, tx2) - uns(i,k) = min(tx1*gamma_bs_plus1, tx2) - - fs(i,k) = grho * ums(i,k) - fns(i,k) = grho * uns(i,k) - - else - fs(i,k) = zero - fns(i,k) = zero - end if - - if (do_graupel .or. do_hail) then -!++ag - ! fallspeed for graupel - - -! if (lamg(i,k) >= qsmall) then - if (dumg(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s) - tx1 = agn(i,k) / lamg(i,k)**bgtmp - tx2 = 20._r8 * rhof(i,k) - umg(i,k) = min(tx1*gamma_bg_plus4*oneo6, tx2) - ung(i,k) = min(tx1*gamma_bg_plus1, tx2) - - fg(i,k) = grho * umg(i,k) - fng(i,k) = grho * ung(i,k) - - else - fg(i,k) = zero - fng(i,k) = zero - end if - endif - - ! 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 - dumr(i,k) = qr(i,k) + qrtend(i,k)*deltat - dums(i,k) = qs(i,k) + qstend(i,k)*deltat - - dumnc(i,k) = nc(i,k) + nctend(i,k)*deltat - dumni(i,k) = ni(i,k) + nitend(i,k)*deltat - dumnr(i,k) = nr(i,k) + nrtend(i,k)*deltat - dumns(i,k) = ns(i,k) + nstend(i,k)*deltat -!++ag - dumg(i,k) = qg(i,k) + qgtend(i,k)*deltat - dumng(i,k) = ng(i,k) + ngtend(i,k)*deltat -!--ag - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero - if (dumg(i,k) < qsmall) dumng(i,k) = zero - - enddo - end do !!! vertical loop - - do k=1,nlev - do i=1,mgncol - pdel_inv(i,k) = one / pdel(i,k) - enddo - enddo -! if (lprnt) write(0,*)' bef sedimentation dumc=',dumc(i,nlev-10:nlev) - - ! initialize nstep for sedimentation sub-steps - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - do i=1,mgncol - nlb = nlball(i) - nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - if (do_cldice) then - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumi(i,k) = tx5 / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = tx5 / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qisedten(i,k) = qisedten(i,k) + tx6 - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - - do k = 2,nlev - - ! 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 - - ! note: this is not an issue with precip, since we assume max overlap - - if (icldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - ! add fallout terms to eulerian tendencies - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = (tx5 + faloutni(k-1)*dum2) / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - - qisedten(i,k) = qisedten(i,k) + tx6 ! sedimentation tendency for output - - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice - qisevap(i,k) = qisevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxls - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - end do - - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - - prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) - - end do - end if - -! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - k = 1 - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumc(i,k) = tx5 / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = tx5 / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - ! sedimentation tendency for output - qcsedten(i,k) = qcsedten(i,k) + tx6 - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 - do k = 2,nlev - - if (lcldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = (tx5 + faloutnc(k-1)*dum2) / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - - qcsedten(i,k) = qcsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water - qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxlv - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here - end do - - prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) - - end do -! if (lprnt) write(0,*)' tlat5=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& -! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - -! if(lprnt) then -! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall -! write(0,*)' fr=',fr(i,:) -! write(0,*)' dumr=',dumr(i,:) -! endif - - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = tx5 / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = tx5 / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k) + tx6 - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 - - do k = 2,nlev - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = (tx5 + faloutr(k-1)*tx7) / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = (tx5 + faloutnr(k-1)*tx7) / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - qrsedten(i,k) = qrsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux - end do - - prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) - - end do - -! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = tx5 / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = tx5 / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qssedten(i,k) = qssedten(i,k) + tx6 - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 - - do k = 2,nlev - - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = (tx5 + falouts(k-1)*tx7) / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = (tx5 + faloutns(k-1)*tx7) / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - - qssedten(i,k) = qssedten(i,k) + tx6 ! sedimentation tendency for output - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 ! Snow Flux - end do !! k loop - - prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) - - end do !! nstep loop - -! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) -! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) - - if (do_graupel .or. do_hail) then -!++ag Graupel Sedimentation - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fg(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fng(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumg(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumg(i,k) = tx5 / (one + fg(i,k)*tx7) - tx6 = (dumg(i,k)-tx5) * oneodt - qgtend(i,k) = qgtend(i,k) + tx6 - tx5 = dumng(i,k) - dumng(i,k) = tx5 / (one + fng(i,k)*tx7) - ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qgsedten(i,k) = qgsedten(i,k) + tx6 - - faloutg(k) = fg(i,k) * dumg(i,k) - faloutng(k) = fng(i,k) * dumng(i,k) - - gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - - do k = 2,nlev - - tx5 = dumg(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumg(i,k) = (tx5 + faloutg(k-1)*tx7) / (one + fg(i,k)*tx7) - tx6 = (dumg(i,k)-tx5) * oneodt - ! add fallout terms to eulerian tendencies - qgtend(i,k) = qgtend(i,k) + tx6 - tx5 = dumng(i,k) - dumng(i,k) = (tx5 + faloutng(k-1)*tx7) / (one + fng(i,k)*tx7) - ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt - - - qgsedten(i,k) = qgsedten(i,k) + tx6 ! sedimentation tendency for output - - - faloutg(k) = fg(i,k) * dumg(i,k) - faloutng(k) = fng(i,k) * dumng(i,k) - - gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - end do - - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - - prect(i) = prect(i) + faloutg(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + faloutg(nlev) * (tx3*0.001_r8) - - end do !! nstep loop - endif -! if (lprnt) write(0,*)' qgtnds=',qgtend(1,:) -!--ag - enddo ! end of i loop - ! end sedimentation - -! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! get new update for variables that includes sedimentation tendency - ! note : here dum variables are grid-average, NOT in-cloud - - do k=1,nlev - do i=1,mgncol - 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) - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) - -!++ag - dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) -! Moorthi testing - if (dumg(i,k) > 0.01_r8) then - tx2 = dumg(i,k) - 0.01_r8 - dumg(i,k) = 0.01_r8 - dums(i,k) = dums(i,k) + tx2 - qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt - qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt - endif -! Moorthi testing - dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) -!--ag - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) - end if - -!++ag - ! switch for specification of graupel number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) - end if -!--ag - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero -!++ag - if (dumg(i,k) < qsmall) dumng(i,k) = zero -!--ag - - enddo - - enddo - - ! calculate instantaneous processes (melting, homogeneous freezing) - !==================================================================== - - ! melting of snow at +2 C - do k=1,nlev - - do i=1,mgncol - - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt - if (tx1 > zero) then - if (dums(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * dums(i,k) - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - qstend(i,k) = qstend(i,k) - tx2*dums(i,k) - nstend(i,k) = nstend(i,k) - tx2*dumns(i,k) - qrtend(i,k) = qrtend(i,k) + tx2*dums(i,k) - nrtend(i,k) = nrtend(i,k) + tx2*dumns(i,k) - - dum1 = - xlf * tx2 * dums(i,k) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if - enddo - enddo - - if (do_graupel .or. do_hail) then -!++ag - - ! melting of graupel at +2 C - - do k=1,nlev - - do i=1,mgncol - - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt - if (tx1 > zero) then - if (dumg(i,k) > zero) then - - ! make sure melting graupel doesn't reduce temperature below threshold - dum = -(xlf/cpp) * dumg(i,k) - if (tx1+dum < zero) then - dum = max(zero, min(one, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - - qgtend(i,k) = qgtend(i,k) - tx2*dumg(i,k) - ngtend(i,k) = ngtend(i,k) - tx2*dumng(i,k) - qrtend(i,k) = qrtend(i,k) + tx2*dumg(i,k) - nrtend(i,k) = nrtend(i,k) + tx2*dumng(i,k) - - dum1 = - xlf*tx2*dumg(i,k) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if - enddo - enddo - -!--ag - endif - - do k=1,nlev - do i=1,mgncol - - ! freezing of rain at -5 C - - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - rainfrze - if (tx1 < zero) then - - if (dumr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * dumr(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - tx2 = dum * oneodt - qrtend(i,k) = qrtend(i,k) - tx2 * dumr(i,k) - nrtend(i,k) = nrtend(i,k) - tx2 * dumnr(i,k) - - ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice - ! depending on mean rain size - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (lamr(i,k) < one/Dcs) then -!++ag freeze rain to graupel - if (do_hail .or. do_graupel) then - qgtend(i,k) = qgtend(i,k) + tx2 * dumr(i,k) - ngtend(i,k) = ngtend(i,k) + tx2 * dumnr(i,k) - else - qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) - nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) - end if -!--ag - else - qitend(i,k) = qitend(i,k) + tx2 * dumr(i,k) - nitend(i,k) = nitend(i,k) + tx2 * dumnr(i,k) - end if - ! heating tendency - dum1 = xlf*dum*dumr(i,k)*oneodt - frzrdttot(i,k) = dum1 + frzrdttot(i,k) - tlat(i,k) = dum1 + tlat(i,k) - - end if - end if - - enddo - enddo - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - tmelt - if (tx1 > zero) then - if (dumi(i,k) > zero) then - - ! limit so that melting does not push temperature below freezing - !----------------------------------------------------------------- - dum = -dumi(i,k)*xlf/cpp - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - qctend(i,k) = qctend(i,k) + tx2*dumi(i,k) - - ! for output - melttot(i,k) = tx2*dumi(i,k) - - ! assume melting ice produces droplet - ! mean volume radius of 8 micron - - nctend(i,k) = nctend(i,k) + three*tx2*dumi(i,k)/(four*pi*5.12e-16_r8*rhow) - - qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt - nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt - tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) - end if - end if - enddo - enddo - -! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-45:nlev)*deltat -! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-45:nlev)*deltat - - ! homogeneously freeze droplets at -40 C - !----------------------------------------------------------------- - - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - 233.15_r8 - if (tx1 < zero) then - if (dumc(i,k) > zero) then - - ! limit so that freezing does not push temperature above threshold - dum = (xlf/cpp) * dumc(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt * dumc(i,k) - qitend(i,k) = tx2 + qitend(i,k) - homotot(i,k) = tx2 ! for output - - ! 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) + tx2*(three/(four*pi*1.563e-14_r8* 500._r8)) - qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt - nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt - tlat(i,k) = tlat(i,k) + xlf*tx2 - end if - end if - enddo - enddo - ! 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 - do k=1,nlev - do i=1,mgncol - - qtmp = q(i,k) + qvlat(i,k) * deltat - ttmp = t(i,k) + tlat(i,k) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn/(p(i,k)-omeps*esn) - - - if (qtmp > qvn .and. qvn > zero .and. allow_sed_supersat) then - ! expression below is approximate since there may be ice deposition - dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - ! add to output cme - cmeout(i,k) = cmeout(i,k) + dum - ! now add to tendencies, partition between liquid and ice based on temperature - if (ttmp > 268.15_r8) then - dum1 = zero - ! now add to tendencies, partition between liquid and ice based on te - !------------------------------------------------------- - else if (ttmp < 238.15_r8) then - dum1 = one - else - dum1 = (268.15_r8-ttmp)/30._r8 - end if - - tx1 = xxls*dum1 + xxlv*(one-dum1) - dum = (qtmp-qvn)/(one+tx1*tx1*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - tx2 = dum*(one-dum1) - qctend(i,k) = qctend(i,k) + tx2 - qcrestot(i,k) = tx2 ! for output - qitend(i,k) = qitend(i,k) + dum*dum1 - qirestot(i,k) = dum*dum1 - qvlat(i,k) = qvlat(i,k) - dum - ! for output - qvres(i,k) = -dum - tlat(i,k) = tlat(i,k) + dum*tx1 - end if - enddo - enddo - end if - -! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat - - ! 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 - do k=1,nlev - do i=1,mgncol - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - else - tx1 = zero - endif - if (icldm(i,k) > mincld) then - tx2 = one / icldm(i,k) - else - tx2 = zero - endif - if (precip_frac(i,k) > mincld) then - tx3 = one / precip_frac(i,k) - else - tx3 = zero - endif - 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 - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) * tx3 - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) * tx3 - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) * tx3 - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) * tx3 - -!++ag - dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) * tx3 - dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) * tx3 -!--ag - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst * rhoinv(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst * rhoinv(i,k) - end if - -!++ag - ! switch for specification of graupel number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) - end if -!--ag - - ! limit in-cloud mixing ratio 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) - dumc(i,k) = min(dumc(i,k), 10.e-3_r8) - dumi(i,k) = min(dumi(i,k), 10.e-3_r8) - ! limit in-precip mixing ratios - dumr(i,k) = min(dumr(i,k), 10.e-3_r8) - dums(i,k) = min(dums(i,k), 10.e-3_r8) -!++ag - dumg(i,k) = min(dumg(i,k), 10.e-3_r8) -!--ag - enddo - enddo - ! cloud ice effective radius - !----------------------------------------------------------------- - - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - if (dumi(i,k) >= qsmall) then - - tx1 = dumni(i,k) - call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & - lami(i,k), dumni0) - - if (dumni(i,k) /= tx1) then - ! adjust number conc if needed to keep mean size in reasonable range - nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k)) * oneodt - end if - - tx1 = one / lami(i,k) -! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 - effi(i,k) = (three*1.e6_r8) * tx1 - sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 - - else - effi(i,k) = 50._r8 - sadice(i,k) = zero - end if - - ! ice effective diameter for david mitchell's optics - deffi(i,k) = effi(i,k) * (rhoi+rhoi)/rhows - enddo - enddo - !else - !do k=1,nlev - !do i=1,mgncol - ! NOTE: If CARMA is doing the ice microphysics, then the ice effective - ! radius has already been determined from the size distribution. - !effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um - !deffi(i,k)=effi(i,k) * 2._r8 - !sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 - !enddo - !enddo - end if - - ! cloud droplet effective radius - !----------------------------------------------------------------- - do k=1,nlev - do i=1,mgncol - if (dumc(i,k) >= qsmall) then - - - ! switch for specification of droplet and crystal number - 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*rhoinv(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - - end if - - dum = dumnc(i,k) - - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - if (dum /= dumnc(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - end if - - effc(i,k) = (half*1.e6_r8) * (pgam(i,k)+three) / lamc(i,k) - !assign output fields for shape here - lamcrad(i,k) = lamc(i,k) - pgamrad(i,k) = pgam(i,k) - - - ! 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_r8 - - ! Pass in "false" adjust flag to prevent number from being changed within - ! size distribution subroutine. - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - effc_fn(i,k) = (half*1.e6_r8) * (pgam(i,k)+three)/lamc(i,k) - - else - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - end if - enddo - enddo - ! recalculate 'final' rain size distribution parameters - ! to ensure that rain size is in bounds, adjust rain number if needed - do k=1,nlev - do i=1,mgncol - - if (dumr(i,k) >= qsmall) then - - dum = dumnr(i,k) - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (dum /= dumnr(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt - end if - - end if - enddo - enddo - ! recalculate 'final' snow size distribution parameters - ! to ensure that snow size is in bounds, adjust snow number if needed - do k=1,nlev - do i=1,mgncol - if (dums(i,k) >= qsmall) then - - dum = dumns(i,k) - - call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & - lams(i,k), n0=dumns0) - - if (dum /= dumns(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k)) * oneodt - end if - - tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) - sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 - - end if - - - end do ! vertical k loop - enddo - do k=1,nlev - do i=1,mgncol - ! 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) * oneodt - if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat < qsmall) nitend(i,k) = -ni(i,k) * oneodt - if (qr(i,k)+qrtend(i,k)*deltat < qsmall) nrtend(i,k) = -nr(i,k) * oneodt - if (qs(i,k)+qstend(i,k)*deltat < qsmall) nstend(i,k) = -ns(i,k) * oneodt -!++ag - if (qg(i,k)+qgtend(i,k)*deltat < qsmall) ngtend(i,k) = -ng(i,k) * oneodt -!--ag - - end do - - end do - - ! DO STUFF FOR OUTPUT: - !================================================== - - do k=1,nlev - do i=1,mgncol - - ! qc and qi are only used for output calculations past here, - ! so add qctend and qitend back in one more time - qc(i,k) = qc(i,k) + qctend(i,k)*deltat - qi(i,k) = qi(i,k) + qitend(i,k)*deltat - - ! averaging for snow and rain number and diameter - !-------------------------------------------------- - - ! drout2/dsout2: - ! diameter of rain and snow - ! dsout: - ! scaled diameter of snow (passed to radiation in CAM) - ! reff_rain/reff_snow: - ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual - - if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then - qrout2(i,k) = qrout(i,k) * precip_frac(i,k) - nrout2(i,k) = nrout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just drout2 times constants. - drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) - freqr(i,k) = precip_frac(i,k) - - reff_rain(i,k) = (1.e6_r8*1.5_r8) * drout2(i,k) - else - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - freqr(i,k) = zero - reff_rain(i,k) = zero - endif - - if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then - qsout2(i,k) = qsout(i,k) * precip_frac(i,k) - nsout2(i,k) = nsout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just dsout2 times constants. - dsout2(i,k) = avg_diameter(qsout(i,k), nsout(i,k), rho(i,k), rhosn) - freqs(i,k) = precip_frac(i,k) - - dsout(i,k) = three*rhosn/rhows*dsout2(i,k) - - reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) - else - dsout(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout2(i,k) = zero - freqs(i,k) = zero - reff_snow(i,k) = zero - endif - - enddo - enddo - - ! analytic radar reflectivity - !-------------------------------------------------- - ! formulas from Matthew Shupe, NOAA/CERES - ! *****note: radar reflectivity is local (in-precip average) - ! units of mm^6/m^3 - - do k=1,nlev - do i = 1,mgncol -! if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten .and. lcldm(i,k) > mincld) then - if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten) then - tx1 = rho(i,k) / lcldm(i,k) - tx2 = 1000._r8 * qc(i,k) * tx1 - dum = tx2 * tx2 * lcldm(i,k) & - /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)*tx1*1.e-6_r8*precip_frac(i,k)) -! dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & -! /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) - else - dum = zero - end if -! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then - if (qi(i,k) >= qsmall) then -! dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) - dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*10000._r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(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) - dum1 = dum1 + (qsout(i,k)*rho(i,k)*10000._r8)**(one/0.63_r8) - end if - - refl(i,k) = dum + dum1 - - ! add rain rate, but for 37 GHz formulation instead of 94 GHz - ! formula approximated from data of Matrasov (2007) - ! rainrt is the rain rate in mm/hr - ! reflectivity (dum) is in DBz - - if (rainrt(i,k) >= 0.001_r8) then - dum = rainrt(i,k) * rainrt(i,k) - dum = log10(dum*dum*dum) + 16._r8 - - ! convert from DBz to mm^6/m^3 - - dum = ten**(dum/ten) - else - ! don't include rain rate in R calculation for values less than 0.001 mm/hr - dum = zero - end if - - ! add to refl - - refl(i,k) = refl(i,k) + dum - - !output reflectivity in Z. - areflz(i,k) = refl(i,k) * precip_frac(i,k) - - ! convert back to DBz - - if (refl(i,k) > minrefl) then - refl(i,k) = ten*log10(refl(i,k)) - else - refl(i,k) = -9999._r8 - end if - - !set averaging flag - if (refl(i,k) > mindbz) then - arefl(i,k) = refl(i,k) * precip_frac(i,k) - frefl(i,k) = precip_frac(i,k) - else - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - end if - - ! bound cloudsat reflectivity - - csrfl(i,k) = min(csmax,refl(i,k)) - - !set averaging flag - if (csrfl(i,k) > csmin) then - acsrfl(i,k) = refl(i,k) * precip_frac(i,k) - fcsrfl(i,k) = precip_frac(i,k) - else - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - end if - - end do - end do - - do k=1,nlev - do i = 1,mgncol - !redefine fice here.... - tx2 = qsout(i,k) + qi(i,k) - tx1 = tx2 + qrout(i,k) + qc(i,k) - if ( tx2 > qsmall .and. tx1 > qsmall) then - nfice(i,k) = min(tx2/tx1, one) - else - nfice(i,k) = zero - endif - enddo - enddo - -end subroutine micro_mg_tend - -!======================================================================== -!OUTPUT CALCULATIONS -!======================================================================== - -subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) - integer, intent(in) :: mgncol, nlev - real(r8), dimension(mgncol,nlev), intent(in) :: lamr ! rain size parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: n0r ! rain size parameter (intercept) - real(r8), dimension(mgncol,nlev), intent(in) :: lamc ! size distribution parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: pgam ! droplet size parameter - real(r8), dimension(mgncol,nlev), intent(in) :: qric ! in-cloud rain mass mixing ratio - real(r8), dimension(mgncol,nlev), intent(in) :: qcic ! in-cloud cloud liquid - real(r8), dimension(mgncol,nlev), intent(in) :: ncic ! in-cloud droplet number concentration - - real(r8), dimension(mgncol,nlev), intent(inout) :: rercld ! effective radius calculation for rain + cloud - - ! combined size of precip & cloud drops - real(r8) :: Atmp - - integer :: i, k - - do k=1,nlev - do i=1,mgncol - ! Rain drops - if (lamr(i,k) > zero) then - Atmp = n0r(i,k) * (half*pi) / (lamr(i,k)*lamr(i,k)*lamr(i,k)) - else - Atmp = zero - end if - - ! Add cloud drops - if (lamc(i,k) > zero) then - Atmp = Atmp + ncic(i,k) * pi * rising_factorial(pgam(i,k)+one, 2) & - / (four*lamc(i,k)*lamc(i,k)) - end if - - if (Atmp > zero) then - rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) - end if - enddo - enddo -end subroutine calc_rercld - -!======================================================================== - -end module micro_mg3_0 diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 deleted file mode 100644 index ffd13c2d5..000000000 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ /dev/null @@ -1,2730 +0,0 @@ -!>\file micro_mg_utils.F90 -!! This file contains process rates and utility functions used by the -!! MG microphysics. - -!>\ingroup mg2mg3 -!>\defgroup micro_mg_utils_mod Morrison-Gettelman MP utils Module -!! This module contains process rates and utility functions used by the MG -!! microphysics. -!! -!! Original MG authors: Andrew Gettelman, Hugh Morrison -!! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan -!! -!! Separated from MG 1.5 by B. Eaton. -!! -!! Separated module switched to MG 2.0 and further changes by S. Santos. -!! -!! Anning Cheng changed for FV3GFS 9/29/2017 -!! added ac_time as an input -!! -!! S. Moorthi - Feb 2018 : code optimization -!! -!! This version: https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ -!! -!! for questions contact Hugh Morrison, Andrew Gettelman -!! e-mail: morrison@ucar.edu, andrew@ucar.edu -module micro_mg_utils - -!-------------------------------------------------------------------------- -! -! List of required external functions that must be supplied: -! gamma --> standard mathematical gamma function (if gamma is an -! intrinsic, define HAVE_GAMMA_INTRINSICS) -! -!-------------------------------------------------------------------------- -! -! Constants that must be specified in the "init" method (module variables): -! -! kind kind of reals (to verify correct linkage only) - -! gravit acceleration due to gravity m s-2 -! rair dry air gas constant for air J kg-1 K-1 -! rh2o gas constant for water vapor J kg-1 K-1 -! cpair specific heat at constant pressure for dry air J kg-1 K-1 -! tmelt temperature of melting point for water K -! latvap latent heat of vaporization J kg-1 -! latice latent heat of fusion J kg-1 -! -!-------------------------------------------------------------------------- - -! 8 byte real and integer -use machine, only : r8 => kind_phys -use machine, only : i8 => kind_phys -implicit none -private -save - -public :: & - micro_mg_utils_init, & - size_dist_param_liq, & - size_dist_param_basic, & - avg_diameter, & - rising_factorial, & - ice_deposition_sublimation, & - sb2001v2_liq_autoconversion, & - sb2001v2_accre_cld_water_rain, & - kk2000_liq_autoconversion, & - ice_autoconversion, & - immersion_freezing, & - contact_freezing, & - snow_self_aggregation, & - accrete_cloud_water_snow, & - secondary_ice_production, & - accrete_rain_snow, & - heterogeneous_rain_freezing, & - accrete_cloud_water_rain, & - self_collection_rain, & - accrete_cloud_ice_snow, & - evaporate_sublimate_precip, & - bergeron_process_snow, & - liu_liq_autoconversion, & - gmao_ice_autoconversion, & - size_dist_param_ice, & -!++ag - graupel_collecting_snow, & - graupel_collecting_rain, & - graupel_collecting_cld_water, & - graupel_riming_liquid_snow, & - graupel_rain_riming_snow, & - graupel_rime_splintering, & - evaporate_sublimate_precip_graupel -! graupel_sublimate_evap -!--ag - - -public :: MGHydrometeorProps - -type :: MGHydrometeorProps - ! Density (kg/m^3) - real(r8) :: rho - ! Information for size calculations. - ! Basic calculation of mean size is: - ! lambda = (shape_coef*nic/qic)^(1/eff_dim) - ! Then lambda is constrained by bounds. - real(r8) :: eff_dim - real(r8) :: shape_coef - real(r8) :: lambda_bounds(2) - ! Minimum average particle mass (kg). - ! Limit is applied at the beginning of the size distribution calculations. - real(r8) :: min_mean_mass -end type MGHydrometeorProps - -interface MGHydrometeorProps - module procedure NewMGHydrometeorProps -end interface - -type(MGHydrometeorProps), public :: mg_liq_props -type(MGHydrometeorProps), public :: mg_ice_props -type(MGHydrometeorProps), public :: mg_rain_props -type(MGHydrometeorProps), public :: mg_snow_props -!++ag -type(MGHydrometeorProps), public :: mg_graupel_props -!--ag - -interface size_dist_param_liq - module procedure size_dist_param_liq_vect - module procedure size_dist_param_liq_line -end interface -interface size_dist_param_basic - module procedure size_dist_param_basic_vect - module procedure size_dist_param_basic_line -end interface - -interface size_dist_param_ice - module procedure size_dist_param_ice_vect - module procedure size_dist_param_ice_line -end interface - -!================================================= -! Public module parameters (mostly for MG itself) -!================================================= - -!> Pi to 20 digits; more than enough to reach the limit of double precision. -real(r8), parameter, public :: pi = 3.14159265358979323846_r8 - -!> "One minus small number": number near unity for round-off issues. -!real(r8), parameter, public :: omsm = 1._r8 - 1.e-5_r8 -real(r8), parameter, public :: omsm = 1._r8 - 1.e-6_r8 - -!> Smallest mixing ratio considered in microphysics. -real(r8), parameter, public :: qsmall = 1.e-18_r8 - -!> minimum allowed cloud fraction - real(r8), parameter, public :: mincld = 0.000001_r8 -!real(r8), parameter, public :: mincld = 0.0001_r8 -!real(r8), parameter, public :: mincld = 0.0_r8 - -real(r8), parameter, public :: rhosn = 250._r8 !< bulk density snow -real(r8), parameter, public :: rhoi = 500._r8 !< bulk density ice -real(r8), parameter, public :: rhow = 1000._r8 !< bulk density liquid -real(r8), parameter, public :: rhows = 917._r8 !< bulk density water solid - -!++ag -!Hail and Graupel (set in MG3) -real(r8), parameter, public :: rhog = 500._r8 -real(r8), parameter, public :: rhoh = 400._r8 -!--ag - -! fall speed parameters, V = aD^b (V is in m/s) -! droplets -real(r8), parameter, public :: ac = 3.e7_r8 -real(r8), parameter, public :: bc = 2._r8 -! snow -real(r8), parameter, public :: as = 11.72_r8 -real(r8), parameter, public :: bs = 0.41_r8 -! cloud ice -real(r8), parameter, public :: ai = 700._r8 -real(r8), parameter, public :: bi = 1._r8 -! small cloud ice (r< 10 um) - sphere, bulk density -real(r8), parameter, public :: aj = ac*((rhoi/rhows)**(bc/3._r8))*rhows/rhow -real(r8), parameter, public :: bj = bc -! rain -real(r8), parameter, public :: ar = 841.99667_r8 -real(r8), parameter, public :: br = 0.8_r8 -!++ag -! graupel -real(r8), parameter, public :: ag = 19.3_r8 -real(r8), parameter, public :: bg = 0.37_r8 -! hail -real(r8), parameter, public :: ah = 114.5_r8 -real(r8), parameter, public :: bh = 0.5_r8 -!--ag - -!> mass of new crystal due to aerosol freezing and growth (kg) -!! Make this consistent with the lower bound, to support UTLS and -!! stratospheric ice, and the smaller ice size limit. -real(r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 - -!++ag -! mass of new graupel particle (assume same as mi0 for now, may want to make bigger?) -!real(r8), parameter, public :: mg0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 -!or set based on M2005: -real(r8), parameter, public :: mg0 = 1.6e-10_r8 -! radius of contact nuclei -real(r8), parameter, public :: mmult = 4._r8/3._r8*pi*rhoi*(5.e-6_r8)**3 -!--ag - -!================================================= -! Private module parameters -!================================================= - -! Signaling NaN bit pattern that represents a limiter that's turned off. -integer(i8), parameter :: limiter_off = int(Z'7FF1111111111111', i8) - -! alternate threshold used for some in-cloud mmr -real(r8), parameter :: icsmall = 1.e-8_r8 - -! particle mass-diameter relationship -! currently we assume spherical particles for cloud ice/snow -! m = cD^d -! exponent -real(r8), parameter :: dsph = 3._r8 - -! Bounds for mean diameter for different constituents. -real(r8), parameter :: lam_bnd_rain(2) = 1._r8/[500.e-6_r8, 20.e-6_r8] -real(r8), parameter :: lam_bnd_snow(2) = 1._r8/[2000.e-6_r8, 10.e-6_r8] - -! Minimum average mass of particles. -real(r8), parameter :: min_mean_mass_liq = 1.e-20_r8 -real(r8), parameter :: min_mean_mass_ice = 1.e-20_r8 - -! ventilation parameters -! for snow -real(r8), parameter :: f1s = 0.86_r8 -real(r8), parameter :: f2s = 0.28_r8 -! for rain -real(r8), parameter :: f1r = 0.78_r8 -real(r8), parameter :: f2r = 0.308_r8 - -! collection efficiencies -! aggregation of cloud ice and snow -!real(r8), parameter :: eii = 0.5_r8 -!real(r8), parameter :: eii = 0.1_r8 - real(r8), parameter :: eii = 0.2_r8 -!++ag -! collection efficiency, ice-droplet collisions -real(r8), parameter, public :: ecid = 0.7_r8 -! collection efficiency between droplets/rain and snow/rain -real(r8), parameter, public :: ecr = 1.0_r8 -!--ag - -! immersion freezing parameters, bigg 1953 -real(r8), parameter :: bimm = 100._r8 -real(r8), parameter :: aimm = 0.66_r8 - -! Mass of each raindrop created from autoconversion. -real(r8), parameter :: droplet_mass_25um = 4._r8/3._r8*pi*rhow*(25.e-6_r8)**3 -real(r8), parameter :: droplet_mass_40um = 4._r8/3._r8*pi*rhow*(40.e-6_r8)**3, & - droplet_mass_40umi = 1._r8/droplet_mass_40um - -!========================================================= -! Constants set in initialization -!========================================================= - -! Set using arguments to micro_mg_init -real(r8) :: rv ! water vapor gas constant -real(r8) :: cpp ! specific heat of dry air -real(r8) :: tmelt ! freezing point of water (K) - -real(r8) :: ra ! dry air gas constant - -! latent heats of: -real(r8) :: xxlv ! vaporization -real(r8) :: xlf ! freezing -real(r8) :: xxls ! sublimation - -! additional constants to help speed up code -real(r8) :: gamma_bs_plus3 -real(r8) :: gamma_half_br_plus5 -real(r8) :: gamma_half_bs_plus5 -!++ag -real(r8) :: gamma_2bs_plus2 -!--ag -! -real(r8), parameter :: zero = 0._r8, one = 1._r8, two = 2._r8, three = 3._r8, & - four = 4._r8, five = 5._r8, six = 6._r8, pio6 = pi/six, & - pio3 = pi/three, half = 0.5_r8, oneo3 = one/three, & - twopi = pi + pi - -!========================================================= -! Utilities that are cheaper if the compiler knows that -! some argument is an integer. -!========================================================= - -!>\ingroup micro_mg_utils_mod -interface rising_factorial - module procedure rising_factorial_r8 - module procedure rising_factorial_integer -end interface rising_factorial - -!>\ingroup micro_mg_utils_mod -interface var_coef - module procedure var_coef_r8 - module procedure var_coef_integer -end interface var_coef - -!========================================================================== -contains -!========================================================================== - -!>\ingroup micro_mg_utils_mod -!! Initialize module variables. -! -! "kind" serves no purpose here except to check for unlikely linking -! issues; always pass in the kind for a double precision real. -! -! -! Check the list at the top of this module for descriptions of all other -! arguments. -subroutine micro_mg_utils_init( kind, rair, rh2o, cpair, tmelt_in, latvap, & - latice, dcs) -! latice, dcs, errstring) - - integer, intent(in) :: kind -!++ag - real(r8), intent(in) :: rair -!--ag - real(r8), intent(in) :: rh2o - real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in - real(r8), intent(in) :: latvap - real(r8), intent(in) :: latice - real(r8), intent(in) :: dcs - - - ! Name this array to workaround an XLF bug (otherwise could just use the - ! expression that sets it). - real(r8) :: ice_lambda_bounds(2) - - !----------------------------------------------------------------------- - - - ! declarations for MG code (transforms variable names) - - rv = rh2o ! water vapor gas constant - cpp = cpair ! specific heat of dry air - tmelt = tmelt_in - !++ag - ra = rair ! dry air gas constant - !--ag - - ! latent heats - - xxlv = latvap ! latent heat vaporization - xlf = latice ! latent heat freezing - xxls = xxlv + xlf ! latent heat of sublimation - - ! Define constants to help speed up code (this limits calls to gamma function) - gamma_bs_plus3 = gamma(three+bs) - gamma_half_br_plus5 = gamma((five+br)*half) - gamma_half_bs_plus5 = gamma((five+bs)*half) -!++ag - gamma_2bs_plus2 = gamma(bs+bs+two) -!--ag - - - ! Don't specify lambda bounds for cloud liquid, as they are determined by - ! pgam dynamically. - mg_liq_props = MGHydrometeorProps(rhow, dsph, min_mean_mass=min_mean_mass_liq) - - ! Mean ice diameter can not grow bigger than twice the autoconversion - ! threshold for snow. - ice_lambda_bounds = one/[two*dcs, 1.e-6_r8] - - mg_ice_props = MGHydrometeorProps(rhoi, dsph, & - ice_lambda_bounds, min_mean_mass_ice) - - mg_rain_props = MGHydrometeorProps(rhow, dsph, lam_bnd_rain) - mg_snow_props = MGHydrometeorProps(rhosn, dsph, lam_bnd_snow) -!++ag - mg_graupel_props = MGHydrometeorProps(rhog, dsph, lam_bnd_snow) -!--ag - -end subroutine micro_mg_utils_init - -!>\ingroup micro_mg_utils_mod -!! Constructor for a constituent property object. -function NewMGHydrometeorProps(rho, eff_dim, lambda_bounds, min_mean_mass) & - result(res) - real(r8), intent(in) :: rho, eff_dim - real(r8), intent(in), optional :: lambda_bounds(2), min_mean_mass - type(MGHydrometeorProps) :: res - - res%rho = rho - res%eff_dim = eff_dim - if (present(lambda_bounds)) then - res%lambda_bounds = lambda_bounds - else - res%lambda_bounds = no_limiter() - end if - if (present(min_mean_mass)) then - res%min_mean_mass = min_mean_mass - else - res%min_mean_mass = no_limiter() - end if - - res%shape_coef = rho * pio6 * gamma(eff_dim+one) - -end function NewMGHydrometeorProps - -!======================================================================== -!FORMULAS -!======================================================================== - -! Use gamma function to implement rising factorial extended to the reals. -pure function rising_factorial_r8(x, n) result(res) - real(r8), intent(in) :: x, n - real(r8) :: res - - res = gamma(x+n) / gamma(x) - -end function rising_factorial_r8 - -! Rising factorial can be performed much cheaper if n is a small integer. -pure function rising_factorial_integer(x, n) result(res) - real(r8), intent(in) :: x - integer, intent(in) :: n - real(r8) :: res - - integer :: i - real(r8) :: factor - - res = one - factor = x - - do i = 1, n - res = res * factor - factor = factor + one - end do - -end function rising_factorial_integer - -! Calculate correction due to latent heat for evaporation/sublimation -elemental function calc_ab(t, qv, xxl) result(ab) - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: qv ! Saturation vapor pressure - real(r8), intent(in) :: xxl ! Latent heat - - real(r8) :: ab - - real(r8) :: dqsdt - - dqsdt = xxl*qv / (rv*t*t) - ab = one + dqsdt*xxl/cpp - -end function calc_ab - -!>\ingroup micro_mg_utils_mod -!! get cloud droplet size distribution parameters -elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc) - type(MGHydrometeorProps), intent(in) :: props - real(r8), intent(in) :: qcic - real(r8), intent(inout) :: ncic - real(r8), intent(in) :: rho - - real(r8), intent(out) :: pgam - real(r8), intent(out) :: lamc - real(r8) :: xs - - type(MGHydrometeorProps) :: props_loc - logical, parameter :: liq_gmao=.true. - - if (qcic > qsmall) then - - ! Local copy of properties that can be modified. - ! (Elemental routines that operate on arrays can't modify scalar - ! arguments.) - props_loc = props - - ! Get pgam from fit to observations of martin et al. 1994 - - if (liq_gmao) then - pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 - ! Anning modified lamc - if ((ncic > 1.0e-3_r8) .and. (qcic > 1.0e-11_r8)) then - xs = 0.07_r8*(1000._r8*qcic/ncic) ** (-0.14_r8) - else - xs = 1.2_r8 - 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) - 4.0_r8)/8.0_r8 - pgam = sqrt(xs) - else - - pgam = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic*rho) -! pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 - endif - pgam = one / (pgam*pgam) - one - pgam = max(pgam, two) - - ! Set coefficient for use in size_dist_param_basic. - ! The 3D case is so common and optimizable that we specialize it: - if (props_loc%eff_dim == three) then - props_loc%shape_coef = pio6 * props_loc%rho * & - rising_factorial(pgam+one, 3) - else - props_loc%shape_coef = pio6 * props_loc%rho * & - rising_factorial(pgam+one, props_loc%eff_dim) - end if - - ! Limit to between 2 and 50 microns mean size. - props_loc%lambda_bounds = (pgam+one) * one/[50.e-6_r8, 2.e-6_r8] - - call size_dist_param_basic(props_loc, qcic, ncic, lamc) - - else - ! pgam not calculated in this case, so set it to a value likely to - ! cause an error if it is accidentally used - ! (gamma function undefined for negative integers) - pgam = -100._r8 - lamc = zero - end if - -end subroutine size_dist_param_liq_line - -!>\ingroup micro_mg_utils_mod -!! This subroutine gets cloud droplet size distribution parameters -subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) - - type(mghydrometeorprops), intent(in) :: props - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: qcic - real(r8), dimension(mgncol), intent(inout) :: ncic - real(r8), dimension(mgncol), intent(in) :: rho - real(r8), dimension(mgncol), intent(out) :: pgam - real(r8), dimension(mgncol), intent(out) :: lamc - real(r8) :: xs - type(mghydrometeorprops) :: props_loc - logical, parameter :: liq_gmao=.true. - integer :: i - - do i=1,mgncol - if (qcic(i) > qsmall) then - ! Local copy of properties that can be modified. - ! (Elemental routines that operate on arrays can't modify scalar - ! arguments.) - props_loc = props - ! Get pgam from fit to observations of martin et al. 1994 - - if (liq_gmao) then - pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 - if ((ncic(i) > 1.0e-3_r8) .and. (qcic(i) > 1.0e-11_r8)) then - xs = 0.07_r8*(1000._r8*qcic(i)/ncic(i)) **(-0.14_r8) - else - xs = 1.2_r8 - 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) - 4.0_r8)/8.0_r8 - pgam(i) = sqrt(xs) - else - pgam(i) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) -! pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 - endif - - pgam(i) = one/(pgam(i)*pgam(i)) - one - pgam(i) = max(pgam(i), two) - endif - enddo - do i=1,mgncol - if (qcic(i) > qsmall) then - ! Set coefficient for use in size_dist_param_basic. - ! The 3D case is so common and optimizable that we specialize - ! it: - if (props_loc%eff_dim == three) then - props_loc%shape_coef = pio6 * props_loc%rho * & - rising_factorial(pgam(i)+one, 3) - else - props_loc%shape_coef = pio6 * props_loc%rho * & - rising_factorial(pgam(i)+one, props_loc%eff_dim) - end if - ! Limit to between 2 and 50 microns mean size. - props_loc%lambda_bounds(1) = (pgam(i)+one) / 50.e-6_r8 - props_loc%lambda_bounds(2) = (pgam(i)+one) / 2.e-6_r8 - call size_dist_param_basic(props_loc, qcic(i), ncic(i), lamc(i)) - endif - enddo - do i=1,mgncol - if (qcic(i) <= qsmall) then - ! pgam not calculated in this case, so set it to a value likely to - ! cause an error if it is accidentally used - ! (gamma function undefined for negative integers) - pgam(i) = -100._r8 - lamc(i) = zero - end if - enddo - -end subroutine size_dist_param_liq_vect - -!>\ingroup micro_mg_utils_mod -!! Basic routine for getting size distribution parameters. -elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) - type(MGHydrometeorProps), intent(in) :: props - real(r8), intent(in) :: qic - real(r8), intent(inout) :: nic - - real(r8), intent(out) :: lam - real(r8), intent(out), optional :: n0 - - if (qic > qsmall) then - - ! add upper limit to in-cloud number concentration to prevent - ! numerical error - if (limiter_is_on(props%min_mean_mass)) then - nic = min(nic, qic / props%min_mean_mass) - end if - - ! lambda = (c n/q)^(1/d) - lam = (props%shape_coef * nic/qic)**(one/props%eff_dim) - - ! check for slope - ! adjust vars - if (lam < props%lambda_bounds(1)) then - lam = props%lambda_bounds(1) - nic = lam**(props%eff_dim) * qic/props%shape_coef - else if (lam > props%lambda_bounds(2)) then - lam = props%lambda_bounds(2) - nic = lam**(props%eff_dim) * qic/props%shape_coef - end if - - else - lam = zero - end if - - if (present(n0)) n0 = nic * lam - -end subroutine size_dist_param_basic_line - -!>\ingroup micro_mg_utils_mod -!! This subroutine calculates -subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) - - type (mghydrometeorprops), intent(in) :: props - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: qic - real(r8), dimension(mgncol), intent(inout) :: nic - real(r8), dimension(mgncol), intent(out) :: lam - real(r8), dimension(mgncol), intent(out), optional :: n0 - integer :: i - do i=1,mgncol - - if (qic(i) > qsmall) then - - ! add upper limit to in-cloud number concentration to prevent - ! numerical error - if (limiter_is_on(props%min_mean_mass)) then - nic(i) = min(nic(i), qic(i) / props%min_mean_mass) - end if - - ! lambda = (c n/q)^(1/d) - lam(i) = (props%shape_coef * nic(i)/qic(i))**(one/props%eff_dim) - - ! check for slope - ! adjust vars - if (lam(i) < props%lambda_bounds(1)) then - lam(i) = props%lambda_bounds(1) - nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef - else if (lam(i) > props%lambda_bounds(2)) then - lam(i) = props%lambda_bounds(2) - nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef - end if - - else - lam(i) = zero - end if - - enddo - - if (present(n0)) n0 = nic * lam - -end subroutine size_dist_param_basic_vect - -!>\ingroup micro_mg_utils_mod -!! ice routine for getting size distribution parameters. -elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) - type(MGHydrometeorProps), intent(in) :: props - real(r8), intent(in) :: qic - real(r8), intent(inout) :: nic - - real(r8), intent(out) :: lam - real(r8):: miu_ice,tx1,tx2, aux - real(r8), intent(out), optional :: n0 - logical, parameter :: ice_sep=.true. - - if (qic > qsmall) then - - ! add upper limit to in-cloud number concentration to prevent - ! numerical error - if (limiter_is_on(props%min_mean_mass)) then - nic = min(nic, qic / props%min_mean_mass) - end if - - ! lambda = (c n/q)^(1/d) - lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) - if (ice_sep) then - miu_ice = max(min(0.008_r8*(lam*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1.0_r8 + miu_ice - tx2 = 1.0_r8 / gamma(tx1) - aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) - lam = lam*aux - else - aux = 1.0_r8 - tx1 = 1.0_r8 - tx2 = 1.0_r8 - end if - if (present(n0)) n0 = nic * lam**tx1*tx2 - - ! check for slope - ! adjust vars - if (lam < props%lambda_bounds(1)*aux) then - lam = props%lambda_bounds(1) - nic = lam**(props%eff_dim) * qic/props%shape_coef - if (present(n0)) n0 = nic * lam - else if (lam > props%lambda_bounds(2)*aux) then - lam = props%lambda_bounds(2) - nic = lam**(props%eff_dim) * qic/props%shape_coef - if (present(n0)) n0 = nic * lam - end if - - else - lam = 0.0_r8 - end if - - -end subroutine size_dist_param_ice_line - -!>\ingroup micro_mg_utils_mod -!! This subroutine -subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) - - type (mghydrometeorprops), intent(in) :: props - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: qic - real(r8), dimension(mgncol), intent(inout) :: nic - real(r8), dimension(mgncol), intent(out) :: lam - real(r8), dimension(mgncol), intent(out), optional :: n0 - real(r8) :: miu_ice,tx1,tx2, aux - integer :: i - logical, parameter :: ice_sep=.true. - do i=1,mgncol - - if (qic(i) > qsmall) then - - ! add upper limit to in-cloud number concentration to prevent - ! numerical error - if (limiter_is_on(props%min_mean_mass)) then - nic(i) = min(nic(i), qic(i) / props%min_mean_mass) - end if - - ! lambda = (c n/q)^(1/d) - lam(i) = (props%shape_coef * nic(i)/qic(i))**(1._r8/props%eff_dim) - if (ice_sep) then - miu_ice = max(min(0.008_r8*(lam(i)*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1.0_r8 + miu_ice - tx2 = 1.0_r8 / gamma(tx1) - aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) - lam(i) = lam(i)*aux - else - aux = 1.0_r8 - tx1 = 1.0_r8 - tx2 = 1.0_r8 - end if - if (present(n0)) n0(i) = nic(i) * lam(i)**tx1*tx2 - - ! check for slope - ! adjust vars - if (lam(i) < props%lambda_bounds(1)*aux) then - lam(i) = props%lambda_bounds(1) - nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef - if (present(n0)) n0(i) = nic(i) * lam(i) - else if (lam(i) > props%lambda_bounds(2)*aux) then - lam(i) = props%lambda_bounds(2) - nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef - if (present(n0)) n0(i) = nic(i) * lam(i) - end if - - else - lam(i) = 0.0_r8 - end if - - enddo - -end subroutine size_dist_param_ice_vect - -!>\ingroup micro_mg_utils_mod -!> Finds the average diameter of particles given their density, and -!! mass/number concentrations in the air. -!! Assumes that diameter follows an exponential distribution. -real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) - real(r8), intent(in) :: q !< mass mixing ratio - real(r8), intent(in) :: n !< number concentration (per volume) - real(r8), intent(in) :: rho_air !< local density of the air - real(r8), intent(in) :: rho_sub !< density of the particle substance - - avg_diameter = (pi * rho_sub * n/(q*rho_air))**(-oneo3) - -end function avg_diameter - -!>\ingroup mg2mg3 -!> Finds a coefficient for process rates based on the relative variance -!! of cloud water. -elemental function var_coef_r8(relvar, a) result(res) - real(r8), intent(in) :: relvar - real(r8), intent(in) :: a - real(r8) :: res - - res = rising_factorial(relvar, a) / relvar**a - -end function var_coef_r8 - -!>\ingroup mg2mg3 -!> Finds a coefficient for process rates based on the relative variance -!! of cloud water. -elemental function var_coef_integer(relvar, a) result(res) - real(r8), intent(in) :: relvar - integer, intent(in) :: a - real(r8) :: res - - res = rising_factorial(relvar, a) / relvar**a - -end function var_coef_integer - -!======================================================================== -!MICROPHYSICAL PROCESS CALCULATIONS -!======================================================================== -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Initial ice deposition and sublimation loop. -!! Run before the main loop -!! This subroutine written by Peter Caldwell -subroutine ice_deposition_sublimation(t, qv, qi, ni, & - icldm, rho, dv,qvl, qvi, & - berg, vap_dep, ice_sublim, mgncol) - - !INPUT VARS: - !=============================================== -! logical, intent(in) :: lprnt - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t - real(r8), dimension(mgncol), intent(in) :: qv - real(r8), dimension(mgncol), intent(in) :: qi - real(r8), dimension(mgncol), intent(in) :: ni - real(r8), dimension(mgncol), intent(in) :: icldm - real(r8), dimension(mgncol), intent(in) :: rho - real(r8), dimension(mgncol), intent(in) :: dv - real(r8), dimension(mgncol), intent(in) :: qvl - real(r8), dimension(mgncol), intent(in) :: qvi - - !OUTPUT VARS: - !=============================================== - real(r8), dimension(mgncol), intent(out) :: vap_dep !ice deposition (cell-ave value) - real(r8), dimension(mgncol), intent(out) :: ice_sublim !ice sublimation (cell-ave value) - real(r8), dimension(mgncol), intent(out) :: berg !bergeron enhancement (cell-ave value) - - !INTERNAL VARS: - !=============================================== - real(r8) :: ab - real(r8) :: epsi - real(r8) :: qiic - real(r8) :: niic - real(r8) :: lami - real(r8) :: n0i - real(r8) :: tx1 - integer :: i - - do i=1,mgncol - if (qi(i)>=qsmall) then - - !GET IN-CLOUD qi, ni - !=============================================== - tx1 = one / icldm(i) - qiic = qi(i) * tx1 - niic = ni(i) * tx1 - - !Compute linearized condensational heating correction - ab = calc_ab(t(i), qvi(i), xxls) - !Get slope and intercept of gamma distn for ice. -! call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) - call size_dist_param_ice(mg_ice_props, qiic, niic, lami, n0i) - !Get depletion timescale=1/eps -! if(lprnt) write(0,*)' twopi=',twopi,' n0i=',n0i,' rho=',rho(1),& -! ' dv=',dv(1),' lami=',lami,' mg_ice_props=',mg_ice_props,& -! ' qiic=',qiic,'niic=',niic - epsi = twopi*n0i*rho(i)*Dv(i)/(lami*lami) - - !Compute deposition/sublimation - vap_dep(i) = epsi/ab*(qv(i) - qvi(i)) - - !Make this a grid-averaged quantity - vap_dep(i) = vap_dep(i)*icldm(i) - - !Split into deposition or sublimation. - if (t(i) < tmelt .and. vap_dep(i) > zero) then - ice_sublim(i) = zero - else - ! make ice_sublim negative for consistency with other evap/sub processes - ice_sublim(i) = min(vap_dep(i), zero) - vap_dep(i) = zero - end if - -! if (lprnt) write(0,*)' t=',t(1),' tmelt=',tmelt,' epsi=',epsi,' ab=',ab,& -! ' ice_sublim=',ice_sublim(1),' vap_dep=',vap_dep(1),' qvl=',qvl(1),qvi(1) - - !sublimation occurs @ any T. Not so for berg. - if (t(i) < tmelt) then - - !Compute bergeron rate assuming cloud for whole step. - berg(i) = max(epsi/ab*(qvl(i) - qvi(i)), zero) - else !T>frz - berg(i) = zero - end if !Tqsmall - enddo -end subroutine ice_deposition_sublimation - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! 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 -subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & - ncic, rho, relvar, prc, nprc, nprc1, mgncol) - - integer, intent(in) :: mgncol - logical, intent(in) :: microp_uniform - - real(r8), dimension(mgncol), intent(in) :: qcic - real(r8), dimension(mgncol), intent(in) :: ncic - real(r8), dimension(mgncol), intent(in) :: rho - - real(r8), dimension(mgncol), intent(in) :: relvar - - real(r8), dimension(mgncol), intent(out) :: prc - real(r8), dimension(mgncol), intent(out) :: nprc - real(r8), dimension(mgncol), intent(out) :: nprc1 - - real(r8), dimension(mgncol) :: prc_coef - integer :: i - - ! Take variance into account, or use uniform value. - if (.not. microp_uniform) then - prc_coef(:) = var_coef(relvar(:), 2.47_r8) - else - prc_coef(:) = one - end if - - do i=1,mgncol - if (qcic(i) >= icsmall) 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 - ! switch for sub-columns, don't include sub-grid qc - - prc(i) = prc_coef(i) * & - 0.01_r8 * 1350._r8 * qcic(i)**2.47_r8 * (ncic(i)*1.e-6_r8*rho(i))**(-1.1_r8) - nprc(i) = prc(i) * (one/droplet_mass_25um) - nprc1(i) = prc(i)*ncic(i)/qcic(i) - - else - prc(i) = zero - nprc(i) = zero - nprc1(i) = zero - end if - enddo -end subroutine kk2000_liq_autoconversion - - !======================================================================== -!>\ingroup micro_mg_utils_mod -!! This subroutine -subroutine sb2001v2_liq_autoconversion(pgam,qc,nc,qr,rho,relvar,au,nprc,nprc1,mgncol) - ! - ! --------------------------------------------------------------------- - ! AUTO_SB: calculates the evolution of mass- and number mxg-ratio for - ! drizzle drops due to autoconversion. The autoconversion rate assumes - ! f(x)=A*x**(nu_c)*exp(-Bx) in drop MASS x. - - ! Code from Hugh Morrison, Sept 2014 - - ! autoconversion - ! use simple lookup table of dnu values to get mass spectral shape parameter - ! equivalent to the size spectral shape parameter pgam - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent (in) :: pgam - real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) - real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) - real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) - real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile - real(r8), dimension(mgncol), intent (in) :: relvar - - real(r8), dimension(mgncol), intent (out) :: au ! = prc autoconversion rate - real(r8), dimension(mgncol), intent (out) :: nprc1 ! = number tendency - real(r8), dimension(mgncol), intent (out) :: nprc ! = number tendency fixed size for rain - - ! parameters for droplet mass spectral shape, - ! used by Seifert and Beheng (2001) - ! warm rain scheme only (iparam = 1) - real(r8), parameter :: dnu(16) = [0._r8,-0.557_r8,-0.430_r8,-0.307_r8, & - -0.186_r8,-0.067_r8,0.050_r8,0.167_r8,0.282_r8,0.397_r8,0.512_r8, & - 0.626_r8,0.739_r8,0.853_r8,0.966_r8,0.966_r8] - - ! parameters for Seifert and Beheng (2001) autoconversion/accretion - real(r8), parameter :: kc = 9.44e9_r8 - real(r8), parameter :: kr = 5.78e3_r8 - real(r8), parameter :: auf = kc / (20._r8*2.6e-7_r8) * 1000._r8, & - con_nprc1 = two/2.6e-7_r8*1000._r8 - real(r8) :: dum, dum1, nu, pra_coef, tx1, tx2, tx3, tx4 - integer :: dumi, i - - do i=1,mgncol - - pra_coef = var_coef(relvar(i), 2.47_r8) - if (qc(i) > qsmall) then - dumi = max(1, min(int(pgam(i)), 15)) - nu = dnu(dumi) + (dnu(dumi+1)-dnu(dumi))* (pgam(i)-dumi) - - !Anning fixed a bug here for FV3GFS 10/13/2017 - dum = max(one-qc(i)/(qc(i)+qr(i)), zero) - tx1 = dum**0.68_r8 - tx2 = one - tx1 - dum1 = 600._r8 * tx1 * tx2 * tx2 * tx2 ! Moorthi -! dum1 = 600._r8*dum**0.68_r8*(one-dum**0.68_r8)**3 - - tx1 = nu + one - tx2 = 0.001_r8 * rho(i) * qc(i) - tx3 = tx2 * tx2 / (rho(i)*nc(i)*1.e-6_r8) - tx2 = tx3 * tx3 - tx3 = one - dum - au(i) = auf * (nu+two) * (nu+four) * tx2 & - * (one+dum1/(tx3*tx3)) / (tx1*tx1*rho(i)) - -! au(i) = kc/(20._r8*2.6e-7_r8)* & -! (nu+2._r8)*(nu+4._r8)/(nu+1._r8)**2._r8* & -! (rho(i)*qc(i)/1000._r8)**4._r8/(rho(i)*nc(i)/1.e6_r8)**2._r8* & -! (1._r8+dum1/(1._r8-dum)**2)*1000._r8 / rho(i) - -! nprc1(i) = au(i) * two / 2.6e-7_r8 * 1000._r8 -! nprc(i) = au(i) / droplet_mass_40um - nprc1(i) = au(i) * con_nprc1 - nprc(i) = au(i) * droplet_mass_40umi - else - au(i) = zero - nprc1(i) = zero - nprc(i) = zero - end if - - enddo - - end subroutine sb2001v2_liq_autoconversion - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Anning Cheng 10/5/2017 add Liu et al. autoconversion - subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & - au,nprc,nprc1,mgncol) - - - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent (in) :: pgam - real(r8), dimension(mgncol), intent (in) :: qc - real(r8), dimension(mgncol), intent (in) :: nc - real(r8), dimension(mgncol), intent (in) :: qr - real(r8), dimension(mgncol), intent (in) :: rho - real(r8), dimension(mgncol), intent (in) :: relvar - - real(r8), dimension(mgncol), intent (out) :: au - real(r8), dimension(mgncol), intent (out) :: nprc1 - real(r8), dimension(mgncol), intent (out) :: nprc - real(r8) :: xs,lw, nw, beta6 -! real(r8), parameter :: dcrit=1.0e-6, miu_disp=1. -! real(r8), parameter :: dcrit=1.0e-3, miu_disp=1. - real(r8), parameter :: dcrit = 2.0e-3, miu_disp = 0.8, & - con_nprc1 = two/2.6e-7_r8*1000._r8 - integer :: i - - do i=1,mgncol - if (qc(i) > qsmall) then - xs = one / (one+pgam(i)) - beta6 = (one+three*xs)*(one+four*xs)*(one+five*xs) & - / ((one+xs)*(one+xs+xs)) - LW = 1.0e-3_r8 * qc(i) * rho(i) - NW = nc(i) * rho(i) * 1.e-6_r8 - - xs = min(20.0_r8, 1.03e16_r8*(LW*LW)/(NW*SQRT(NW))) - au(i) = 1.1e10_r8*beta6*LW*LW*LW & - * (one-exp(-(xs**miu_disp))) / NW - au(i) = au(i)*1.0e3_r8/rho(i) - au(i) = au(i) * gamma(two+relvar(i)) & - / (gamma(relvar(i))*(relvar(i)*relvar(i))) - - au(i) = au(i) * dcrit -! nprc1(i)= au(i) * (two/2.6e-7_r8*1000._r8) -! nprc(i) = au(i) / droplet_mass_40um - nprc1(i)= au(i) * con_nprc1 - nprc(i) = au(i) * droplet_mass_40umi - else - au(i) = zero - nprc1(i) = zero - nprc(i) = zero - end if - enddo - - end subroutine liu_liq_autoconversion - - -!======================================================================== -!SB2001 Accretion V2 -!>\ingroup micro_mg_utils_mod -subroutine sb2001v2_accre_cld_water_rain(qc,nc,qr,rho,relvar,pra,npra,mgncol) - ! - ! --------------------------------------------------------------------- - ! ACCR_SB calculates the evolution of mass mxng-ratio due to accretion - ! and self collection following Seifert & Beheng (2001). - ! - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) - real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) - real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) - real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile - real(r8), dimension(mgncol), intent (in) :: relvar - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: pra ! MMR - real(r8), dimension(mgncol), intent(out) :: npra ! Number - - ! parameters for Seifert and Beheng (2001) autoconversion/accretion - real(r8), parameter :: kc = 9.44e9_r8 - real(r8), parameter :: kr = 5.78e3_r8 - - real(r8) :: dum, dum1, tx1, tx2 - integer :: i - - ! accretion - - do i =1,mgncol - - if (qc(i) > qsmall) then - dum = one - qc(i)/(qc(i)+qr(i)) - tx1 = dum / (dum+5.e-4_r8) - dum1 = tx1 * tx1 - dum1 = dum1 * dum1 - pra(i) = kr*rho(i)*0.001_r8*qc(i)*qr(i)*dum1 - - npra(i) = pra(i) * nc(i) / qc(i) - -! npra(i) = pra(i)*rho(i)*0.001_r8*(nc(i)*rho(i)*1.e-6_r8)/ & -! (qc(i)*rho(i)*0.001_r8)*1.e6_r8 / rho(i) - else - pra(i) = zero - npra(i) = zero - end if - - enddo - - end subroutine sb2001v2_accre_cld_water_rain - -!======================================================================== -! Autoconversion of cloud ice to snow -! similar to Ferrier (1994) -!>\ingroup micro_mg_utils_mod -!! Autoconversion of cloud ice to snow -!! similar to Ferrier (1994) -subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, ac_time, prci, nprci, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t - real(r8), dimension(mgncol), intent(in) :: qiic - real(r8), dimension(mgncol), intent(in) :: lami - real(r8), dimension(mgncol), intent(in) :: n0i - real(r8), intent(in) :: dcs - real(r8), dimension(mgncol), intent(in) :: ac_time - - real(r8), dimension(mgncol), intent(out) :: prci - real(r8), dimension(mgncol), intent(out) :: nprci - - ! Assume autoconversion timescale of 180 seconds. - - ! Average mass of an ice particle. - real(r8) :: m_ip - ! Ratio of autoconversion diameter to average diameter. - real(r8) :: d_rat - integer :: i - - do i=1,mgncol - if (t(i) <= tmelt .and. qiic(i) >= qsmall) then - - d_rat = lami(i)*dcs - - ! Rate of ice particle conversion (number). - nprci(i) = n0i(i)/(lami(i)*ac_time(i))*exp(-d_rat) - - m_ip = rhoi * pio6 / (lami(i)*lami(i)*lami(i)) - -! m_ip = (rhoi*pi/6._r8) / lami(i)**3 - - ! Rate of mass conversion. - ! Note that this is: - ! m n (d^3 + 3 d^2 + 6 d + 6) - prci(i) = m_ip * nprci(i) * (((d_rat + three)*d_rat + six)*d_rat + six) - - else - prci(i) = zero - nprci(i) = zero - end if - enddo -end subroutine ice_autoconversion -!=================================== -! Anning Cheng 10/5/2017 added GMAO ice autoconversion -!>\ingroup micro_mg_utils_mod -!! GMAO ice autoconversion -subroutine gmao_ice_autoconversion(t, qiic, niic, lami, n0i, & - dcs, ac_time, prci, nprci, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t - real(r8), dimension(mgncol), intent(in) :: qiic - real(r8), dimension(mgncol), intent(in) :: niic - real(r8), dimension(mgncol), intent(in) :: lami - real(r8), dimension(mgncol), intent(in) :: n0i - real(r8), dimension(mgncol), intent(in) :: ac_time - real(r8), intent(in) :: dcs - - real(r8), dimension(mgncol), intent(out) :: prci - real(r8), dimension(mgncol), intent(out) :: nprci - - - real(r8) :: m_ip, tx1, tx2 - integer :: i - do i=1,mgncol - if (t(i) <= tmelt .and. qiic(i) >= qsmall) then - m_ip = max(min(0.008_r8*(lami(i)*0.01)**0.87_r8, & - 10.0_r8), 0.1_r8) - tx1 = lami(i)*dcs - tx2 = one / ac_time(i) - nprci(i) = niic(i)*tx2 * (one - gamma_incomp(m_ip, tx1)) - prci(i) = qiic(i)*tx2 * (one - gamma_incomp(m_ip+three, tx1)) - else - prci(i) = zero - nprci(i) = zero - end if - enddo -end subroutine gmao_ice_autoconversion -!=================================== -! immersion freezing (Bigg, 1953) -!=================================== -!>\ingroup micro_mg_utils_mod -!! immersion freezing (Bigg, 1953) -subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & - qcic, ncic, relvar, mnuccc, nnuccc, mgncol) - - integer, intent(in) :: mgncol - logical, intent(in) :: microp_uniform - - ! Temperature - real(r8), dimension(mgncol), intent(in) :: t - - ! Cloud droplet size distribution parameters - real(r8), dimension(mgncol), intent(in) :: pgam - real(r8), dimension(mgncol), intent(in) :: lamc - - ! MMR and number concentration of in-cloud liquid water - real(r8), dimension(mgncol), intent(in) :: qcic - real(r8), dimension(mgncol), intent(in) :: ncic - - ! Relative variance of cloud water - real(r8), dimension(mgncol), intent(in) :: relvar - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: mnuccc ! MMR - real(r8), dimension(mgncol), intent(out) :: nnuccc ! Number - - ! Coefficients that will be omitted for sub-columns - real(r8), dimension(mgncol) :: dum - real(r8) :: tx1 - integer :: i - - if (.not. microp_uniform) then - dum(:) = var_coef(relvar, 2) - else - dum(:) = one - end if - do i=1,mgncol - - if (qcic(i) >= qsmall .and. t(i) < 269.15_r8) then - - tx1 = one / (lamc(i) * lamc(i) * lamc(i)) - nnuccc(i) = pio6*ncic(i)*rising_factorial(pgam(i)+one, 3) * & - bimm*(exp(aimm*(tmelt - t(i)))-one) * tx1 - - mnuccc(i) = dum(i) * nnuccc(i) * pio6 * rhow * & - rising_factorial(pgam(i)+four, 3) * tx1 - - else - mnuccc(i) = zero - nnuccc(i) = zero - end if ! qcic > qsmall and t < 4 deg C - enddo - -end subroutine immersion_freezing - -!>\ingroup micro_mg_utils_mod -!! contact freezing (-40= qsmall .and. t(i) < 269.15_r8) then - - if (.not. microp_uniform) then - dum = var_coef(relvar(i), four/three) - dum1 = var_coef(relvar(i), oneo3) - else - dum = one - dum1 = one - endif - - tcnt=(270.16_r8-t(i))**1.3_r8 - viscosity = 1.8e-5_r8*(t(i)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) - mfp = two*viscosity/ & ! Mean free path (m) - (p(i)*sqrt( 8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i)) )) - - ! Note that these two are vectors. - nslip = one+(mfp/rndst(i,:))*(1.257_r8+(0.4_r8*exp(-(1.1_r8*rndst(i,:)/mfp))))! Slip correction factor - - ndfaer = 1.381e-23_r8*t(i)*nslip/(6._r8*pi*viscosity*rndst(i,:)) ! aerosol diffusivity (m2/s) - - tx1 = one / lamc(i) - contact_factor = dot_product(ndfaer,nacon(i,:)*tcnt) * pi * & - ncic(i) * (pgam(i) + one) * tx1 - - mnucct(i) = dum * contact_factor * & - pio3*rhow*rising_factorial(pgam(i)+two, 3) * tx1 * tx1 *tx1 - - nnucct(i) = (dum1+dum1) * contact_factor - - else - - mnucct(i) = zero - nnucct(i) = zero - - end if ! qcic > qsmall and t < 4 deg C - end do - -end subroutine contact_freezing - -!>\ingroup micro_mg_utils_mod -!! 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 -subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - real(r8), dimension(mgncol), intent(in) :: rho ! Density - real(r8), dimension(mgncol), intent(in) :: asn ! fall speed parameter for snow - real(r8), intent(in) :: rhosn ! density of snow - - ! In-cloud snow - real(r8), dimension(mgncol), intent(in) :: qsic ! MMR - real(r8), dimension(mgncol), intent(in) :: nsic ! Number - - ! Output number tendency - real(r8), dimension(mgncol), intent(out) :: nsagg - - integer :: i - - do i=1,mgncol - if (qsic(i) >= qsmall .and. t(i) <= tmelt) then - nsagg(i) = -1108._r8*eii/(four*720._r8*rhosn)*asn(i)*qsic(i)*nsic(i)*rho(i)*& - ((qsic(i)/nsic(i))*(one/(rhosn*pi)))**((bs-one)*oneo3) - else - nsagg(i) = zero - end if - enddo -end subroutine snow_self_aggregation - -!>\ingroup micro_mg_utils_mod -!! 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 -subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, & - pgam, lamc, lams, n0s, psacws, npsacws, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - real(r8), dimension(mgncol), intent(in) :: rho ! Density - real(r8), dimension(mgncol), intent(in) :: asn ! Fallspeed parameter (snow) - real(r8), dimension(mgncol), intent(in) :: uns ! Current fallspeed (snow) - real(r8), dimension(mgncol), intent(in) :: mu ! Viscosity - - ! In-cloud liquid water - real(r8), dimension(mgncol), intent(in) :: qcic ! MMR - real(r8), dimension(mgncol), intent(in) :: ncic ! Number - - ! In-cloud snow - real(r8), dimension(mgncol), intent(in) :: qsic ! MMR - - ! Cloud droplet size parameters - real(r8), dimension(mgncol), intent(in) :: pgam - real(r8), dimension(mgncol), intent(in) :: lamc - - ! Snow size parameters - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: psacws ! Mass mixing ratio - real(r8), dimension(mgncol), intent(out) :: npsacws ! Number concentration - - real(r8) :: dc0 ! Provisional mean droplet size - real(r8) :: dum - real(r8) :: eci ! collection efficiency for riming of snow by droplets - - ! Fraction of cloud droplets accreted per second - real(r8) :: accrete_rate - integer :: i - - ! ignore collision of snow with droplets above freezing - - do i=1,mgncol - if (qsic(i) >= qsmall .and. t(i) <= tmelt .and. qcic(i) >= 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(i)+one)/lamc(i) - dum = dc0*dc0*uns(i)*rhow*lams(i)/(9._r8*mu(i)) - eci = dum*dum / ((dum+0.4_r8)*(dum+0.4_r8)) - - eci = max(eci,zero) - eci = min(eci,one) - - ! no impact of sub-grid distribution of qc since psacws - ! is linear in qc - accrete_rate = (pi/four)*asn(i)*rho(i)*n0s(i)*eci*gamma_bs_plus3 / lams(i)**(bs+three) - psacws(i) = accrete_rate*qcic(i) - npsacws(i) = accrete_rate*ncic(i) - else - psacws(i) = zero - npsacws(i) = zero - end if - enddo -end subroutine accrete_cloud_water_snow - -!>\ingroup micro_mg_utils_mod -!! add secondary ice production due to accretion of droplets by snow -!=================================================================== -! (Hallet-Mossop process) (from Cotton et al., 1986) -subroutine secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - - ! Accretion of cloud water to snow tendencies - real(r8), dimension(mgncol), intent(inout) :: psacws ! MMR - - ! Output (ice) tendencies - real(r8), dimension(mgncol), intent(out) :: msacwi ! MMR - real(r8), dimension(mgncol), intent(out) :: nsacwi ! Number - integer :: i - - do i=1,mgncol - if((t(i) < 270.16_r8) .and. (t(i) >= 268.16_r8)) then - nsacwi(i) = 3.5e8_r8*(270.16_r8-t(i))/two*psacws(i) - else if((t(i) < 268.16_r8) .and. (t(i) >= 265.16_r8)) then - nsacwi(i) = 3.5e8_r8*(t(i)-265.16_r8)*oneo3*psacws(i) - else - nsacwi(i) = zero - endif - enddo - - do i=1,mgncol - msacwi(i) = min(nsacwi(i)*mi0, psacws(i)) - psacws(i) = psacws(i) - msacwi(i) - enddo -end subroutine secondary_ice_production - -!>\ingroup micro_mg_utils_mod -!! accretion of rain water by snow -!=================================================================== -! formula from ikawa and saito, 1991, used by reisner et al., 1998 -subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & - lamr, n0r, lams, n0s, pracs, npracs, mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - real(r8), dimension(mgncol), intent(in) :: rho ! Density - - ! Fallspeeds - ! mass-weighted - real(r8), dimension(mgncol), intent(in) :: umr ! rain - real(r8), dimension(mgncol), intent(in) :: ums ! snow - ! number-weighted - real(r8), dimension(mgncol), intent(in) :: unr ! rain - real(r8), dimension(mgncol), intent(in) :: uns ! snow - - ! In cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qric ! rain - real(r8), dimension(mgncol), intent(in) :: qsic ! snow - - ! Size distribution parameters - ! rain - real(r8), dimension(mgncol), intent(in) :: lamr - real(r8), dimension(mgncol), intent(in) :: n0r - ! snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: pracs ! MMR - real(r8), dimension(mgncol), intent(out) :: npracs ! Number - - ! Collection efficiency for accretion of rain by snow - real(r8), parameter :: ecr = one - - ! Ratio of average snow diameter to average rain diameter. - real(r8) :: d_rat - ! Common factor between mass and number expressions - real(r8) :: common_factor - real(r8) :: tx1, tx2 - integer :: i - - do i=1,mgncol - if (qric(i) >= icsmall .and. qsic(i) >= icsmall .and. t(i) <= tmelt) then - - tx2 = lamr(i)*lamr(i)*lamr(i) - - common_factor = pi*ecr*rho(i)*n0r(i)*n0s(i) / (tx2 * lams(i)) - - d_rat = lamr(i)/lams(i) - - tx1 = 1.2_r8*umr(i)-0.95_r8*ums(i) - pracs(i) = common_factor*pi*rhow* & - sqrt(tx1*tx1 + 0.08_r8*ums(i)*umr(i)) * & - ((half*d_rat + two)*d_rat + five) / tx2 - - tx1 = unr(i)-uns(i) - npracs(i) = common_factor*half * & - sqrt(1.7_r8*tx1*tx1 + 0.3_r8*unr(i)*uns(i)) * & - ((d_rat + one)*d_rat + one) - - else - pracs(i) = zero - npracs(i) = zero - end if - enddo -end subroutine accrete_rain_snow - -!>\ingroup micro_mg_utils_mod -!! heterogeneous freezing of rain drops -!=================================================================== -! follows from Bigg (1953) -subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - - ! In-cloud rain - real(r8), dimension(mgncol), intent(in) :: qric ! MMR - real(r8), dimension(mgncol), intent(in) :: nric ! Number - real(r8), dimension(mgncol), intent(in) :: lamr ! size parameter - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: mnuccr ! MMR - real(r8), dimension(mgncol), intent(out) :: nnuccr ! Number - real(r8) :: tx1 - integer :: i - - do i=1,mgncol - - if (t(i) < 269.15_r8 .and. qric(i) >= qsmall) then - tx1 = pi / (lamr(i)*lamr(i)*lamr(i)) - nnuccr(i) = nric(i)*bimm* (exp(aimm*(tmelt - t(i)))-one) * tx1 - - mnuccr(i) = nnuccr(i) * 20._r8*rhow * tx1 - - else - mnuccr(i) = zero - nnuccr(i) = zero - end if - enddo -end subroutine heterogeneous_rain_freezing - -!>\ingroup micro_mg_utils_mod -!! accretion of cloud liquid water by rain -!! formula from Khrouditnov and Kogan (2000) -! gravitational collection kernel, droplet fall speed neglected -subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & - ncic, relvar, accre_enhan, pra, npra, mgncol) - - logical, intent(in) :: microp_uniform - integer, intent(in) :: mgncol - ! In-cloud rain - real(r8), dimension(mgncol), intent(in) :: qric ! MMR - - ! Cloud droplets - real(r8), dimension(mgncol), intent(in) :: qcic ! MMR - real(r8), dimension(mgncol), intent(in) :: ncic ! Number - - ! SGS variability - real(r8), dimension(mgncol), intent(in) :: relvar - real(r8), dimension(mgncol), intent(in) :: accre_enhan - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: pra ! MMR - real(r8), dimension(mgncol), intent(out) :: npra ! Number - - ! Coefficient that varies for subcolumns - real(r8), dimension(mgncol) :: pra_coef - - integer :: i - - if (.not. microp_uniform) then - pra_coef(:) = accre_enhan * var_coef(relvar(:), 1.15_r8) - else - pra_coef(:) = one - end if - - do i=1,mgncol - - if (qric(i) >= qsmall .and. qcic(i) >= qsmall) then - - ! include sub-grid distribution of cloud water - pra(i) = pra_coef(i) * 67._r8*(qcic(i)*qric(i))**1.15_r8 - - npra(i) = pra(i)*ncic(i)/qcic(i) - - else - pra(i) = zero - npra(i) = zero - end if - end do -end subroutine accrete_cloud_water_rain - -!>\ingroup micro_mg_utils_mod -!! Self-collection of rain drops -!! from Beheng(1994) -subroutine self_collection_rain(rho, qric, nric, nragg, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: rho ! Air density - - ! Rain - real(r8), dimension(mgncol), intent(in) :: qric ! MMR - real(r8), dimension(mgncol), intent(in) :: nric ! Number - - ! Output number tendency - real(r8), dimension(mgncol), intent(out) :: nragg - - integer :: i - - do i=1,mgncol - if (qric(i) >= qsmall) then - nragg(i) = -8._r8*nric(i)*qric(i)*rho(i) - else - nragg(i) = zero - end if - enddo -end subroutine self_collection_rain - -!>\ingroup micro_mg_utils_mod -!! Accretion of cloud ice by snow -!=================================================================== -! For this calculation, it is assumed that the Vs >> Vi -! and Ds >> Di for continuous collection -subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & - lams, n0s, prai, nprai, mgncol) - - integer, intent(in) :: mgncol - real(r8), dimension(mgncol), intent(in) :: t ! Temperature - real(r8), dimension(mgncol), intent(in) :: rho ! Density - - real(r8), dimension(mgncol), intent(in) :: asn ! Snow fallspeed parameter - - ! Cloud ice - real(r8), dimension(mgncol), intent(in) :: qiic ! MMR - real(r8), dimension(mgncol), intent(in) :: niic ! Number - - real(r8), dimension(mgncol), intent(in) :: qsic ! Snow MMR - - ! Snow size parameters - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: prai ! MMR - real(r8), dimension(mgncol), intent(out) :: nprai ! Number - - ! Fraction of cloud ice particles accreted per second - real(r8) :: accrete_rate - - integer :: i - - do i=1,mgncol - if (qsic(i) >= qsmall .and. qiic(i) >= qsmall .and. t(i) <= tmelt) then - - accrete_rate = (pi/four) * eii * asn(i) * rho(i) * n0s(i) * gamma_bs_plus3 & - / lams(i)**(bs+three) - - prai(i) = accrete_rate * qiic(i) - nprai(i) = accrete_rate * niic(i) - - else - prai(i) = zero - nprai(i) = zero - end if - enddo -end subroutine accrete_cloud_ice_snow - -!>\ingroup micro_mg_utils_mod -!! 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 -subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & - lcldm, precip_frac, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & - pre, prds, am_evp_st, mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t ! temperature - real(r8), dimension(mgncol), intent(in) :: rho ! air density - real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity - real(r8), dimension(mgncol), intent(in) :: mu ! viscosity - real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number - real(r8), dimension(mgncol), intent(in) :: q ! humidity - real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) - real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) - real(r8), dimension(mgncol), intent(in) :: lcldm ! liquid cloud fraction - real(r8), dimension(mgncol), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) - - ! fallspeed parameters - real(r8), dimension(mgncol), intent(in) :: arn ! rain - real(r8), dimension(mgncol), intent(in) :: asn ! snow - - ! In-cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid - real(r8), dimension(mgncol), intent(in) :: qiic ! cloud ice - real(r8), dimension(mgncol), intent(in) :: qric ! rain - real(r8), dimension(mgncol), intent(in) :: qsic ! snow - - ! Size parameters - ! rain - real(r8), dimension(mgncol), intent(in) :: lamr - real(r8), dimension(mgncol), intent(in) :: n0r - ! snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: pre - real(r8), dimension(mgncol), intent(out) :: prds - real(r8), dimension(mgncol), intent(out) :: am_evp_st ! Fractional area where rain evaporates. - - real(r8) :: qclr ! water vapor mixing ratio in clear air - real(r8) :: ab ! correction to account for latent heat - real(r8) :: eps ! 1/ sat relaxation timescale - real(r8) :: tx1, tx2, tx3 - - real(r8), dimension(mgncol) :: dum - - integer :: i - - am_evp_st = zero - ! 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 - do i=1,mgncol - if (qcic(i)+qiic(i) < 1.e-6_r8) then - dum(i) = zero - else - dum(i) = lcldm(i) - end if - enddo - do i=1,mgncol - ! only calculate if there is some precip fraction > cloud fraction - - if (precip_frac(i) > dum(i)) then - - if (qric(i) >= qsmall .or. qsic(i) >= qsmall) then - am_evp_st(i) = precip_frac(i) - dum(i) - - ! calculate q for out-of-cloud region - qclr = (q(i)-dum(i)*qvl(i)) / (one-dum(i)) - end if - - ! evaporation of rain - if (qric(i) >= qsmall) then - - ab = calc_ab(t(i), qvl(i), xxlv) - eps = two*pi*n0r(i)*rho(i)*Dv(i) * & - (f1r/(lamr(i)*lamr(i)) + & - f2r*sqrt(arn(i)*rho(i)/mu(i)) * & - sc(i)**oneo3*gamma_half_br_plus5 & - / (lamr(i)**((five+br)*half))) - - pre(i) = eps*(qclr-qvl(i)) / ab - - ! only evaporate in out-of-cloud region - ! and distribute across precip_frac - pre(i) = min(pre(i)*am_evp_st(i), zero) - pre(i) = pre(i) / precip_frac(i) - else - pre(i) = zero - end if - - ! sublimation of snow - if (qsic(i) >= qsmall) then - ab = calc_ab(t(i), qvi(i), xxls) - eps = two*pi*n0s(i)*rho(i)*Dv(i) * & - ( f1s/(lams(i)*lams(i)) & - + f2s*sqrt(asn(i)*rho(i)/mu(i)) * & - sc(i)**oneo3*gamma_half_bs_plus5 & - / (lams(i)**((five+bs)*half))) - prds(i) = eps*(qclr-qvi(i)) / ab - - ! only sublimate in out-of-cloud region and distribute over precip_frac - prds(i) = min(prds(i)*am_evp_st(i), zero) - prds(i) = prds(i) / precip_frac(i) - else - prds(i) = zero - end if - - else - prds(i) = zero - pre(i) = zero - end if - enddo - -end subroutine evaporate_sublimate_precip - -!>\ingroup micro_mg_utils_mod -!! evaporation/sublimation of rain, snow and graupel -!=================================================================== -! 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 -subroutine evaporate_sublimate_precip_graupel(t, rho, dv, mu, sc, q, qvl, qvi, & - lcldm, precip_frac, arn, asn, agn, bg, qcic, qiic, qric, qsic, qgic, lamr, n0r, lams, n0s, lamg, n0g, & - pre, prds, prdg, am_evp_st, mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t ! temperature - real(r8), dimension(mgncol), intent(in) :: rho ! air density - real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity - real(r8), dimension(mgncol), intent(in) :: mu ! viscosity - real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number - real(r8), dimension(mgncol), intent(in) :: q ! humidity - real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) - real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) - real(r8), dimension(mgncol), intent(in) :: lcldm ! liquid cloud fraction - real(r8), dimension(mgncol), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) - - ! fallspeed parameters - real(r8), dimension(mgncol), intent(in) :: arn ! rain - real(r8), dimension(mgncol), intent(in) :: asn ! snow -!++ag - real(r8), dimension(mgncol), intent(in) :: agn ! graupel - real(r8), intent(in) :: bg -!--ag - - ! In-cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid - real(r8), dimension(mgncol), intent(in) :: qiic ! cloud ice - real(r8), dimension(mgncol), intent(in) :: qric ! rain - real(r8), dimension(mgncol), intent(in) :: qsic ! snow - real(r8), dimension(mgncol), intent(in) :: qgic ! graupel - - ! Size parameters - ! rain - real(r8), dimension(mgncol), intent(in) :: lamr - real(r8), dimension(mgncol), intent(in) :: n0r - ! snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s -!++ag - ! graupel - real(r8), dimension(mgncol), intent(in) :: lamg - real(r8), dimension(mgncol), intent(in) :: n0g -!--ag - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: pre - real(r8), dimension(mgncol), intent(out) :: prds -!++ag - real(r8), dimension(mgncol), intent(out) :: prdg -!--ag - real(r8), dimension(mgncol), intent(out) :: am_evp_st ! Fractional area where rain evaporates. - - real(r8) :: qclr ! water vapor mixing ratio in clear air - real(r8) :: ab ! correction to account for latent heat - real(r8) :: eps ! 1/ sat relaxation timescale - - real(r8), dimension(mgncol) :: dum - - integer :: i - - ! 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 - do i=1,mgncol - if (qcic(i)+qiic(i) < 1.e-6_r8) then - dum(i) = zero - else - dum(i) = lcldm(i) - end if - enddo - do i=1,mgncol - ! only calculate if there is some precip fraction > cloud fraction - - if (precip_frac(i) > dum(i)) then - - if (qric(i) >= qsmall .or. qsic(i) >= qsmall .or. qgic(i) >= qsmall) then - am_evp_st(i) = precip_frac(i) - dum(i) - - ! calculate q for out-of-cloud region - qclr = (q(i)-dum(i)*qvl(i)) / (one-dum(i)) - end if - - ! evaporation of rain - if (qric(i) >= qsmall) then - - ab = calc_ab(t(i), qvl(i), xxlv) - eps = twopi*n0r(i)*rho(i)*Dv(i)* & - ( f1r/(lamr(i)*lamr(i)) & - + f2r*sqrt(arn(i)*rho(i)/mu(i)) & - * sc(i)**oneo3*gamma_half_br_plus5 & - / (lamr(i)**((five+br)*half))) - - pre(i) = eps*(qclr-qvl(i))/ab - - ! only evaporate in out-of-cloud region - ! and distribute across precip_frac - pre(i) = min(pre(i)*am_evp_st(i), zero) - pre(i) = pre(i)/precip_frac(i) - else - pre(i) = zero - end if - - ! sublimation of snow - if (qsic(i) >= qsmall) then - ab = calc_ab(t(i), qvi(i), xxls) - eps = twopi*n0s(i)*rho(i)*Dv(i)* & - ( f1s/(lams(i)*lams(i)) & - + f2s*sqrt(asn(i)*rho(i)/mu(i)) & - * sc(i)**oneo3*gamma_half_bs_plus5 & - / (lams(i)**((five+bs)*half))) - prds(i) = eps*(qclr-qvi(i))/ab - - ! only sublimate in out-of-cloud region and distribute over precip_frac - prds(i) = min(prds(i)*am_evp_st(i), zero) - prds(i) = prds(i)/precip_frac(i) - else - prds(i) = zero - end if - -!++AG ADD GRAUPEL, do Same with prdg. - - if (qgic(i) >= qsmall) then - ab = calc_ab(t(i), qvi(i), xxls) - - eps = twopi*n0g(i)*rho(i)*Dv(i)* & - ( f1s/(lamg(i)*lamg(i)) & - + f2s*sqrt(agn(i)*rho(i)/mu(i)) & - * sc(i)**oneo3*gamma((five+bg)*half) & - / (lamg(i)**((five+bs)*half))) -! / (lamg(i)**((five+bg)*half))) ! changing bs to bg - Moorthi - prdg(i) = eps*(qclr-qvi(i))/ab - - ! only sublimate in out-of-cloud region and distribute over precip_frac - prdg(i) = min(prdg(i)*am_evp_st(i), zero) - prdg(i) = prdg(i)/precip_frac(i) - else - prdg(i) = zero - end if - - else - prds(i) = zero - pre(i) = zero -!++ag - prdg(i) = zero -!--ag - end if - enddo - -end subroutine evaporate_sublimate_precip_graupel - -!>\ingroup micro_mg_utils_mod -!! bergeron process - evaporation of droplets and deposition onto snow -subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & - qcic, qsic, lams, n0s, bergs, mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t ! temperature - real(r8), dimension(mgncol), intent(in) :: rho ! air density - real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity - real(r8), dimension(mgncol), intent(in) :: mu ! viscosity - real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number - real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) - real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) - - ! fallspeed parameter for snow - real(r8), dimension(mgncol), intent(in) :: asn - - ! In-cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid mixing ratio - real(r8), dimension(mgncol), intent(in) :: qsic ! snow mixing ratio - - ! Size parameters for snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: bergs - - real(r8) :: ab ! correction to account for latent heat - real(r8) :: eps ! 1/ sat relaxation timescale - - integer :: i - - do i=1,mgncol - if (qsic(i) >= qsmall.and. qcic(i) >= qsmall .and. t(i) < tmelt) then - ab = calc_ab(t(i), qvi(i), xxls) - eps = two*pi*n0s(i)*rho(i)*Dv(i) * & - (f1s/(lams(i)*lams(i)) + & - f2s*sqrt(asn(i)*rho(i)/mu(i)) * & - sc(i)**oneo3*gamma_half_bs_plus5 / & - (lams(i)**((five+bs)*half))) - bergs(i) = eps*(qvl(i)-qvi(i)) / ab - else - bergs(i) = zero - end if - enddo -end subroutine bergeron_process_snow - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Collection of snow by rain to form graupel -subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & - psacr, mgncol) - - integer, intent(in) :: mgncol - - ! In-cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qsic ! snow - real(r8), dimension(mgncol), intent(in) :: qric ! rain - - ! mass-weighted fall speeds - real(r8), dimension(mgncol), intent(in) :: umr ! rain - real(r8), dimension(mgncol), intent(in) :: ums ! snow - - real(r8), dimension(mgncol), intent(in) :: rho ! air density - - - ! Size parameters for rain - real(r8), dimension(mgncol), intent(in) :: lamr - real(r8), dimension(mgncol), intent(in) :: n0r - - ! Size parameters for snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - real(r8), dimension(mgncol), intent(out) :: psacr ! conversion due to coll of snow by rain - - real(r8) :: cons31, tx1, tx2, tx3, tx4, tx5 - integer :: i - - cons31 = pi*pi*ecr*rhosn - - do i=1,mgncol - - if (qsic(i) >= 0.1e-3_r8 .and. qric(i) >= 0.1e-3_r8) then - tx1 = 1.2_r8*umr(i) - 0.95_r8*ums(i) - tx1 = sqrt(tx1*tx1+0.08_r8*ums(i)*umr(i)) - tx2 = one / lams(i) - tx3 = one / lamr(i) - tx4 = tx2 * tx2 - tx5 = tx4 * tx4 * tx3 - - psacr(i) = cons31 * tx1 * rho(i) * n0r(i) * n0s(i) * tx5 & - * (5.0_r8*tx4+tx3*(tx2+tx2+0.5_r8*tx3)) - -! psacr(i) = cons31*(((1.2_r8*umr(i)-0.95_r8*ums(i))**2+ & -! 0.08_r8*ums(i)*umr(i))**0.5_r8*rho(i)* & -! n0r(i)*n0s(i)/lams(i)**3* & -! (5._r8/(lams(i)**3*lamr(i))+ & -! 2._r8/(lams(i)**2*lamr(i)**2)+ & -! 0.5_r8/(lams(i)*lamr(i)**3))) - else - psacr(i) = zero - end if - - end do - -end subroutine graupel_collecting_snow - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Collection of cloud water by graupel -subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & - psacwg, npsacwg, mgncol) - - integer, intent(in) :: mgncol - - ! In-cloud MMRs - real(r8), dimension(mgncol), intent(in) :: qgic ! graupel - real(r8), dimension(mgncol), intent(in) :: qcic ! cloud water - - real(r8), dimension(mgncol), intent(in) :: ncic ! cloud water number conc - - real(r8), dimension(mgncol), intent(in) :: rho ! air density - - ! Size parameters for graupel - real(r8), dimension(mgncol), intent(in) :: lamg - real(r8), dimension(mgncol), intent(in) :: n0g - - ! fallspeed parameters for graupel - ! Set AGN and BG as input (in micro_mg3_0.F90) (select hail or graupel as appropriate) - real(r8), intent(in) :: bg - real(r8), dimension(mgncol), intent(in) :: agn - - ! Output tendencies - real(r8), dimension(mgncol), intent(out) :: psacwg - real(r8), dimension(mgncol), intent(out) :: npsacwg - - real(r8) :: cons, tx1 - integer :: i - - cons = gamma(bg+three) * pi/four * ecid - - do i=1,mgncol - - if (qgic(i) >= 1.e-8_r8 .and. qcic(i) >= qsmall) then - - tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+three) - - psacwg(i) = tx1 * qcic(i) - npsacwg(i) = tx1 * ncic(i) - else - psacwg(i) = zero - npsacwg(i) = zero - end if - enddo -end subroutine graupel_collecting_cld_water - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Conversion of rimed cloud water onto snow to graupel/hail -subroutine graupel_riming_liquid_snow(psacws,qsic,qcic,nsic,rho,rhosn,rhog,asn,lams,n0s,dtime, & - pgsacw,nscng,mgncol) - - integer, intent(in) :: mgncol - - ! Accretion of cloud water to snow tendency (modified) - real(r8), dimension(mgncol), intent(inout) :: psacws - - real(r8), dimension(mgncol), intent(in) :: qsic ! snow mixing ratio - real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid mixing ratio - real(r8), dimension(mgncol), intent(in) :: nsic ! snow number concentration - - real(r8), dimension(mgncol), intent(in) :: rho ! air density - real(r8), intent(in) :: rhosn ! snow density - real(r8), intent(in) :: rhog ! graupel density - - real(r8), dimension(mgncol), intent(in) :: asn ! fall speed parameter for snow - - ! Size parameters for snow - real(r8), dimension(mgncol), intent(in) :: lams - real(r8), dimension(mgncol), intent(in) :: n0s - - real(r8), intent(in) :: dtime - - !Output process rates - real(r8), dimension(mgncol), intent(out) :: pgsacw ! dQ graupel due to collection droplets by snow - real(r8), dimension(mgncol), intent(out) :: nscng ! dN graupel due to collection droplets by snow - - real(r8) :: cons - real(r8) :: rhosu - real(r8) :: dum - integer :: i - -!........................................................................ -!Input: PSACWS,qs,qc,n0s,rho,lams,rhos,rhog -!Output:PSACWS,PGSACW,NSCNG - - rhosu = 85000._r8/(ra * tmelt) ! typical air density at 850 mb - - do i=1,mgncol - - cons=4._r8 *2._r8 *3._r8 *rhosu*pi*ecid*ecid*gamma_2bs_plus2/(8._r8*(rhog-rhosn)) - - if (psacws(i).gt.0._r8 .and. qsic(i).GE.0.1e-3_r8 .AND. qcic(i).GE.0.5E-3_r8) then -! Only allow conversion if qni > 0.1 and qc > 0.5 g/kg following Rutledge and Hobbs (1984) - !if (qsic(i).GE.0.1e-3_r8 .AND. qcic(i).GE.0.5E-3_r8) then - -! portion of riming converted to graupel (Reisner et al. 1998, originally IS1991) -! dtime here is correct. - pgsacw(i) = min(psacws(i), cons*dtime*n0s(i)*qcic(i)*qcic(i)* & - asn(i)*asn(i)/ (rho(i)*lams(i)**(bs+bs+two))) - -! if (pgsacw(i).lt.0_r8) then -! write(iulog,*) "pgsacw,i,lams,cons",i,pgsacw(i),lams(i),cons -! end if - -! Mix rat converted into graupel as embryo (Reisner et al. 1998, orig M1990) - dum= max(rhosn/(rhog-rhosn)*pgsacw(i), zero) - -! Number concentraiton of embryo graupel from riming of snow - nscng(i) = dum/mg0*rho(i) -! Limit max number converted to snow number (dtime here correct? We think yes) - nscng(i) = min(nscng(i),nsic(i)/dtime) - -! Portion of riming left for snow - psacws(i) = psacws(i) - pgsacw(i) - else - pgsacw(i) = zero - nscng(i) = zero - end if - - enddo - -end subroutine graupel_riming_liquid_snow - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!!CHANGE IN Q,N COLLECTION RAIN BY GRAUPEL -subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,lamg,& - pracg,npracg,mgncol) - - integer, intent(in) :: mgncol - - !MMR - real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio - real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio - - !Mass weighted Fall speeds - real(r8), dimension(mgncol), intent(in) :: umg ! graupel fall speed - real(r8), dimension(mgncol), intent(in) :: umr ! rain fall speed - - !Number weighted fall speeds - real(r8), dimension(mgncol), intent(in) :: ung ! graupel fall speed - real(r8), dimension(mgncol), intent(in) :: unr ! rain fall speed - - real(r8), dimension(mgncol), intent(in) :: rho ! air density - - ! Size parameters for rain - real(r8), dimension(mgncol), intent(in) :: n0r - real(r8), dimension(mgncol), intent(in) :: lamr - - ! Size parameters for graupel - real(r8), dimension(mgncol), intent(in) :: n0g - real(r8), dimension(mgncol), intent(in) :: lamg - - - !Output process rates - real(r8), dimension(mgncol), intent(out) :: pracg ! Q collection rain by graupel - real(r8), dimension(mgncol), intent(out) :: npracg ! N collection rain by graupel - -! Add collection of graupel by rain above freezing -! assume all rain collection by graupel above freezing is shed -! assume shed drops are 1 mm in size - - integer :: i - real(r8) :: cons41 - real(r8) :: cons32 - real(r8) :: dum, tx1, tx2, tx3, tx4, tx5, tx6 - - cons41 = pi*pi*ecr*rhow - cons32 = 0.5*pi*ecr - - do i=1,mgncol - - if (qric(i) >= 1.e-8_r8 .and. qgic(i) >= 1.e-8_r8) then - -! pracg is mixing ratio of rain per sec collected by graupel/hail - tx1 = 1.2_r8*umr(i) - 0.95_r8*umg(i) - tx1 = sqrt(tx1*tx1+0.08_r8*umg(i)*umr(i)) - tx2 = 1.0_r8 / lamr(i) - tx3 = 1.0_r8 / lamg(i) - tx4 = tx2 * tx2 - tx5 = tx4 * tx4 * tx3 - tx6 = rho(i) * n0r(i) * n0g(i) - - - pracg(i) = cons41 * tx1 * tx6 * tx5 * (5.0*tx4+tx3*(tx2+tx2+0.5*tx3)) - - -! pracg(i) = cons41*(((1.2_r8*umr(i)-0.95_r8*umg(i))**2._r8+ & -! 0.08_r8*umg(i)*umr(i))**0.5_r8*rho(i)* & -! n0r(i)*n0g(i)/lamr(i)**3._r8* & -! (5._r8/(lamr(i)**3._r8*lamg(i))+ & -! 2._r8/(lamr(i)**2._r8*lamg(i)**2._r8)+ & -! 0.5_r8/(lamr(i)*lamg(i)**3._r8))) - -! assume 1 mm drops are shed, get number shed per sec - - dum = pracg(i) / 5.2e-7_r8 - - tx1 = unr(i) - ung(i) - tx1 = sqrt(1.7_r8 * tx1 * tx1 + 0.3_r8*unr(i)*ung(i)) - tx4 = tx2 * tx3 - - npracg(i) = cons32 * tx1 * tx6 * tx4 * (tx2*(tx2+tx3)+tx3*tx3) - -! npracg(i) = cons32*rho(i)*(1.7_r8*(unr(i)-ung(i))**2._r8+ & -! 0.3_r8*unr(i)*ung(i))**0.5_r8*n0r(i)*n0g(i)* & -! (1._r8/(lamr(i)**3._r8*lamg(i))+ & -! 1._r8/(lamr(i)**2._r8*lamg(i)**2._r8)+ & -! 1._r8/(lamr(i)*lamg(i)**3._r8)) - -! hm 7/15/13, remove limit so that the number of collected drops can smaller than -! number of shed drops -! NPRACG(K)=MAX(NPRACG(K)-DUM,0.) - npracg(i) = npracg(i) - dum - else - npracg(i) = zero - pracg(i) = zero - end if - - enddo - -end subroutine graupel_collecting_rain - -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Rain riming snow to graupel -!======================================================================== -! Conversion of rimed rainwater onto snow converted to graupel -subroutine graupel_rain_riming_snow(pracs,npracs,psacr,qsic,qric,nric,nsic,n0s, & - lams,n0r,lamr,dtime,pgracs,ngracs,mgncol) - - integer, intent(in) :: mgncol - - ! Accretion of rain by snow - real(r8), dimension(mgncol), intent(inout) :: pracs - real(r8), dimension(mgncol), intent(inout) :: npracs - real(r8), dimension(mgncol), intent(inout) :: psacr ! conversion due to coll of snow by rain - - - real(r8), dimension(mgncol), intent(in) :: qsic !snow mixing ratio - real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio - - real(r8), dimension(mgncol), intent(in) :: nric ! rain number concentration - real(r8), dimension(mgncol), intent(in) :: nsic ! snow number concentration - - ! Size parameters for snow - real(r8), dimension(mgncol), intent(in) :: n0s - real(r8), dimension(mgncol), intent(in) :: lams - - ! Size parameters for rain - real(r8), dimension(mgncol), intent(in) :: n0r - real(r8), dimension(mgncol), intent(in) :: lamr - - real(r8), intent(in) :: dtime - - !Output process rates - real(r8), dimension(mgncol), intent(out) :: pgracs ! Q graupel due to collection rain by snow - real(r8), dimension(mgncol), intent(out) :: ngracs ! N graupel due to collection rain by snow - -!Input: PRACS,NPRACS,PSACR,qni,qr,lams,lamr,nr,ns Note: No PSACR in MG2 -!Output:PGRACS,NGRACS,PRACS,PSACR - - integer :: i - real(r8) :: cons18 - real(r8) :: cons19 - real(r8) :: dum,fmult,tx1,tx2 - - cons18 = rhosn*rhosn - cons19 = rhow*rhow - - do i=1,mgncol - - fmult = zero - - if (pracs(i) > zero .and. qsic(i) >= 0.1e-3_r8 .and. qric(i) >= 0.1e-3_r8) then - ! only allow conversion if qs > 0.1 and qr > 0.1 g/kg following rutledge and hobbs (1984) - !if (qsic(i).ge.0.1e-3_r8.and.qric(i).ge.0.1e-3_r8) then - ! portion of collected rainwater converted to graupel (reisner et al. 1998) - tx1 = four / lams(i) - tx2 = four / lamr(i) - tx1 = tx1 * tx1 * tx1 - tx2 = tx2 * tx2 * tx2 - dum = cons18 * tx1 * tx1 - dum = one - max(zero, min(one, dum / (dum + cons19 * tx2 * tx2))) - -! dum = cons18*(4._r8/lams(i))**3*(4._r8/lams(i))**3 & -! /(cons18*(4._r8/lams(i))**3*(4._r8/lams(i))**3+ & -! cons19*(4._r8/lamr(i))**3*(4._r8/lamr(i))**3) -! dum = min(dum,one) -! dum = max(dum, zero) -! -! pgracs(i) = (one-dum) * pracs(i) -! ngracs(i) = (one-dum) * npracs(i) - - pgracs(i) = dum * pracs(i) - ngracs(i) = dum * npracs(i) - ! limit max number converted to min of either rain or snow number concentration - ngracs(i) = min(ngracs(i),nric(i)/dtime) - ngracs(i) = min(ngracs(i),nsic(i)/dtime) - - ! amount left for snow production - pracs(i) = pracs(i) - pgracs(i) - npracs(i) = npracs(i) - ngracs(i) - - ! conversion to graupel due to collection of snow by rain -! psacr(i) = psacr(i) * (one-dum) - psacr(i) = psacr(i) * dum - else - pgracs(i) = zero - ngracs(i) = zero - end if - enddo - -end subroutine graupel_rain_riming_snow - -!======================================================================== -! Rime Splintering -!======================================================================== -!>\ingroup micro_mg_utils_mod -!! Rime splintering -subroutine graupel_rime_splintering(t,qcic,qric,qgic,psacwg,pracg,& - qmultg,nmultg,qmultrg,nmultrg,mgncol) - - integer, intent(in) :: mgncol - - real(r8), dimension(mgncol), intent(in) :: t !temperature - - !MMR - real(r8), dimension(mgncol), intent(in) :: qcic !liquid mixing ratio - real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio - real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio - - ! Already calculated terms for collection - real(r8), dimension(mgncol), intent(inout) :: psacwg ! collection droplets by graupel - real(r8), dimension(mgncol), intent(inout) :: pracg ! collection rain by graupel - - !Output process rates for splintering - real(r8), dimension(mgncol), intent(out) :: qmultg ! Q ice mult of droplets/graupel - real(r8), dimension(mgncol), intent(out) :: nmultg ! N ice mult of droplets/graupel - real(r8), dimension(mgncol), intent(out) :: qmultrg ! Q ice mult of rain/graupel - real(r8), dimension(mgncol), intent(out) :: nmultrg ! N ice mult of rain/graupel - - -!Input: qg,qc,qr, PSACWG,PRACG,T -!Output: NMULTG,QMULTG,NMULTRG,QMULTRG,PSACWG,PRACG - - integer :: i - real(r8) :: fmult - real(r8) :: tm_3,tm_5,tm_8 - - tm_3 = tmelt - 3._r8 - tm_5 = tmelt - 5._r8 - tm_8 = tmelt - 8._r8 - - -!nmultg,qmultg . -!======================================================================== - do i=1,mgncol - - nmultrg(i) = zero - qmultrg(i) = zero - nmultg(i) = zero - qmultg(i) = zero - - if (qgic(i) >= 0.1e-3_r8) then - if (qcic(i) >= 0.5e-3_r8 .or. qric(i) >= 0.1e-3_r8) then - if (psacwg(i) > zero .or. pracg(i) > zero) then - if (t(i) < tm_3 .and. t(i) > tm_8) then - if (t(i) > tm_3) then - fmult = zero - else if (t(i) <= tm_3 .and. t(i) > tm_5) then - fmult = (tm_3-t(i)) * 0.5 - else if (t(i) >= tm_8 .and. t(i) <= tm_5) then - fmult = (t(i)-tm_8) * (one/three) - else if (t(i) < tm_8) then - fmult = zero - end if - -! 1000 is to convert from kg to g (Check if needed for MG) - -! splintering from droplets accreted onto graupel - - if (psacwg(i) > zero) then - nmultg(i) = 35.e4_r8*psacwg(i)*fmult*1000._r8 - qmultg(i) = nmultg(i)*mmult - -! constrain so that transfer of mass from graupel to ice cannot be more mass -! than was rimed onto graupel - - qmultg(i) = min(qmultg(i),psacwg(i)) - psacwg(i) = psacwg(i) - qmultg(i) - - end if - - -!nmultrg,qmultrg . -!======================================================================== - -! riming and splintering from accreted raindrops - -! Factor of 1000. again (Check) - - if (pracg(i) > zero) then - nmultrg(i) = 35.e4*pracg(i)*fmult*1000._r8 - qmultrg(i) = nmultrg(i)*mmult - -! constrain so that transfer of mass from graupel to ice cannot be more mass -! than was rimed onto graupel - - qmultrg(i) = min(qmultrg(i),pracg(i)) - pracg(i) = pracg(i) - qmultrg(i) - - end if - - end if - end if - end if - end if - enddo - -end subroutine graupel_rime_splintering - -!======================================================================== -! Evaporation and sublimation of graupel -!======================================================================== - -!MERGE WITH RAIN AND SNOW EVAP -! -!subroutine graupel_sublimate_evap(t,q,qgic,rho,n0g,lamg,qvi,dv,mu,sc,bg,agn,& -! prdg,eprdg,mgncol) -! -! integer, intent(in) :: mgncol -! -! real(r8), dimension(mgncol), intent(in) :: t !temperature -! real(r8), dimension(mgncol), intent(in) :: q !specific humidity (mixing ratio) -! -! !MMR -! real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio -! -! real(r8), dimension(mgncol), intent(in) :: rho ! air density -! -! ! Size parameters for graupel -! real(r8), dimension(mgncol), intent(in) :: n0g -! real(r8), dimension(mgncol), intent(in) :: lamg -! -! real(r8), dimension(mgncol), intent(in) :: qvi !saturation humidity (ice) -! -! real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity -! real(r8), dimension(mgncol), intent(in) :: mu ! viscosity -! real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number -! -! ! fallspeed parameters for graupel -! ! Set AGN and BG as input (in micro_mg3_0.F90) (select hail or graupel as appropriate) -! real(r8), intent(in) :: bg -! real(r8), dimension(mgncol), intent(in) :: agn -! -! ! Output tendencies (sublimation or evaporation of graupel) -! real(r8), dimension(mgncol), intent(out) :: prdg -! real(r8), dimension(mgncol), intent(out) :: eprdg -! -! real(r8) :: cons11,cons36 -! real(r8) :: abi -! real(r8) :: epsg -! integer :: i -! -! cons11=gamma(2.5_r8+bg/2._r8) !bg will be different for graupel (bg) or hail (bh) -! cons36=(2.5_r8+bg/2._r8) -! -! -! do i=1,mgncol -! -! abi = calc_ab(t(i), qvi(i), xxls) -! -! if (qgic(i).ge.qsmall) then -! epsg = 2._r8*pi*n0g(i)*rho(i)*dv(i)* & -! (f1s/(lamg(i)*lamg(i))+ & -! f2s*(agn(i)*rho(i)/mu(i))**0.5_r8* & -! sc(i)**(1._r8/3._r8)*cons11/ & -! (lamg(i)**cons36)) -! else -! epsg = 0. -! end if -! -!! vapor dpeosition on graupel -! prdg(i) = epsg*(q(i)-qvi(i))/abi -! -!! make sure not pushed into ice supersat/subsat -!! put this in main mg3 code…..check for it… -!! formula from reisner 2 scheme - -!! -!! dum = (qv3d(k)-qvi(k))/dt -!! -!! fudgef = 0.9999 -!! sum_dep = prd(k)+prds(k)+mnuccd(k)+prdg(k) -!! -!! if( (dum.gt.0. .and. sum_dep.gt.dum*fudgef) .or. & -!! (dum.lt.0. .and. sum_dep.lt.dum*fudgef) ) then -!! prdg(k) = fudgef*prdg(k)*dum/sum_dep -!! endif -! -!! if cloud ice/snow/graupel vap deposition is neg, then assign to sublimation processes -! -! eprdg(i)=0._r8 -! -! if (prdg(i).lt.0._r8) then -! eprdg(i)=prdg(i) -! prdg(i)=0. -! end if -! -! enddo -! -!end subroutine graupel_sublimate_evap - -!======================================================================== -!UTILITIES -!======================================================================== - -!>\ingroup micro_mg_utils_mod -pure function no_limiter() - real(r8) :: no_limiter - - no_limiter = transfer(limiter_off, no_limiter) - -end function no_limiter - -!>\ingroup micro_mg_utils_mod -pure function limiter_is_on(lim) - real(r8), intent(in) :: lim - logical :: limiter_is_on - - limiter_is_on = transfer(lim, limiter_off) /= limiter_off - -end function limiter_is_on - -!>\ingroup micro_mg_utils_mod -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_r8*(alfa**0.5357_r8) - auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) - gamma_incomp = max(one/(one+exp(-auxx)), 1.0e-20) - -END FUNCTION gamma_incomp - - -end module micro_mg_utils diff --git a/gfsphysics/physics/module_bfmicrophysics.f b/gfsphysics/physics/module_bfmicrophysics.f deleted file mode 100644 index 49a20f47e..000000000 --- a/gfsphysics/physics/module_bfmicrophysics.f +++ /dev/null @@ -1,3199 +0,0 @@ - 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/gfsphysics/physics/module_mp_radar.F90 b/gfsphysics/physics/module_mp_radar.F90 deleted file mode 100644 index 8a16c9826..000000000 --- a/gfsphysics/physics/module_mp_radar.F90 +++ /dev/null @@ -1,614 +0,0 @@ -!+---+-----------------------------------------------------------------+ -!..This set of routines facilitates computing radar reflectivity. -!.. This module is more library code whereas the individual microphysics -!.. schemes contains specific details needed for the final computation, -!.. so refer to location within each schemes calling the routine named -!.. rayleigh_soak_wetgraupel. -!.. The bulk of this code originated from Ulrich Blahak (Germany) and -!.. was adapted to WRF by G. Thompson. This version of code is only -!.. intended for use when Rayleigh scattering principles dominate and -!.. is not intended for wavelengths in which Mie scattering is a -!.. significant portion. Therefore, it is well-suited to use with -!.. 5 or 10 cm wavelength like USA NEXRAD radars. -!.. This code makes some rather simple assumptions about water -!.. coating on outside of frozen species (snow/graupel). Fraction of -!.. meltwater is simply the ratio of mixing ratio below melting level -!.. divided by mixing ratio at level just above highest T>0C. Also, -!.. immediately 90% of the melted water exists on the ice's surface -!.. and 10% is embedded within ice. No water is "shed" at all in these -!.. assumptions. The code is quite slow because it does the reflectivity -!.. calculations based on 50 individual size bins of the distributions. -!+---+-----------------------------------------------------------------+ - - MODULE module_mp_radar - - PUBLIC :: rayleigh_soak_wetgraupel - PUBLIC :: radar_init - PRIVATE :: m_complex_water_ray - PRIVATE :: m_complex_ice_maetzler - PRIVATE :: m_complex_maxwellgarnett - PRIVATE :: get_m_mix_nested - PRIVATE :: get_m_mix - PRIVATE :: WGAMMA - PRIVATE :: GAMMLN - - - INTEGER, PARAMETER, PUBLIC:: nrbins = 50 - DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx - DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg - DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters - DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4 - COMPLEX*16, PUBLIC:: m_w_0, m_i_0 - DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson - DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = & - (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) - REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xcrg, xcsg, xcgg - REAL, PUBLIC:: xam_r, xbm_r, xmu_r, xobmr - REAL, PUBLIC:: xam_s, xbm_s, xmu_s, xoams, xobms, xocms - REAL, PUBLIC:: xam_g, xbm_g, xmu_g, xoamg, xobmg, xocmg - REAL, PUBLIC:: xorg2, xosg2, xogg2 - - INTEGER, PARAMETER, PUBLIC:: slen = 20 - CHARACTER(len=slen), PUBLIC:: & - mixingrulestring_s, matrixstring_s, inclusionstring_s, & - hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & - mixingrulestring_g, matrixstring_g, inclusionstring_g, & - hoststring_g, hostmatrixstring_g, hostinclusionstring_g - -!..Single melting snow/graupel particle 90% meltwater on external sfc - DOUBLE PRECISION, PARAMETER:: melt_outside_s = 0.9d0 - DOUBLE PRECISION, PARAMETER:: melt_outside_g = 0.9d0 - - CHARACTER*256:: radar_debug - - CONTAINS - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - - subroutine radar_init - - IMPLICIT NONE - INTEGER:: n - PI5 = 3.14159*3.14159*3.14159*3.14159*3.14159 - lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar - m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) - m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) - K_w = (ABS( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 - - do n = 1, nrbins+1 - simpson(n) = 0.0d0 - enddo - do n = 1, nrbins-1, 2 - simpson(n) = simpson(n) + basis(1) - simpson(n+1) = simpson(n+1) + basis(2) - simpson(n+2) = simpson(n+2) + basis(3) - enddo - - do n = 1, slen - mixingrulestring_s(n:n) = char(0) - matrixstring_s(n:n) = char(0) - inclusionstring_s(n:n) = char(0) - hoststring_s(n:n) = char(0) - hostmatrixstring_s(n:n) = char(0) - hostinclusionstring_s(n:n) = char(0) - mixingrulestring_g(n:n) = char(0) - matrixstring_g(n:n) = char(0) - inclusionstring_g(n:n) = char(0) - hoststring_g(n:n) = char(0) - hostmatrixstring_g(n:n) = char(0) - hostinclusionstring_g(n:n) = char(0) - enddo - - mixingrulestring_s = 'maxwellgarnett' - hoststring_s = 'air' - matrixstring_s = 'water' - inclusionstring_s = 'spheroidal' - hostmatrixstring_s = 'icewater' - hostinclusionstring_s = 'spheroidal' - - mixingrulestring_g = 'maxwellgarnett' - hoststring_g = 'air' - matrixstring_g = 'water' - inclusionstring_g = 'spheroidal' - hostmatrixstring_g = 'icewater' - hostinclusionstring_g = 'spheroidal' - -!..Create bins of snow (from 100 microns up to 2 cm). - xxDx(1) = 100.D-6 - xxDx(nrbins+1) = 0.02d0 - do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & - *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) - enddo - do n = 1, nrbins - xxDs(n) = DSQRT(xxDx(n)*xxDx(n+1)) - xdts(n) = xxDx(n+1) - xxDx(n) - enddo - -!..Create bins of graupel (from 100 microns up to 5 cm). - xxDx(1) = 100.D-6 - xxDx(nrbins+1) = 0.05d0 - do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & - *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) - enddo - do n = 1, nrbins - xxDg(n) = DSQRT(xxDx(n)*xxDx(n+1)) - xdtg(n) = xxDx(n+1) - xxDx(n) - enddo - - -!..The calling program must set the m(D) relations and gamma shape -!.. parameter mu for rain, snow, and graupel. Easily add other types -!.. based on the template here. For majority of schemes with simpler -!.. exponential number distribution, mu=0. - - xcre(1) = 1. + xbm_r - xcre(2) = 1. + xmu_r - xcre(3) = 1. + xbm_r + xmu_r - xcre(4) = 1. + 2.*xbm_r + xmu_r - do n = 1, 4 - xcrg(n) = WGAMMA(xcre(n)) - enddo - xorg2 = 1./xcrg(2) - - xcse(1) = 1. + xbm_s - xcse(2) = 1. + xmu_s - xcse(3) = 1. + xbm_s + xmu_s - xcse(4) = 1. + 2.*xbm_s + xmu_s - do n = 1, 4 - xcsg(n) = WGAMMA(xcse(n)) - enddo - xosg2 = 1./xcsg(2) - - xcge(1) = 1. + xbm_g - xcge(2) = 1. + xmu_g - xcge(3) = 1. + xbm_g + xmu_g - xcge(4) = 1. + 2.*xbm_g + xmu_g - do n = 1, 4 - xcgg(n) = WGAMMA(xcge(n)) - enddo - xogg2 = 1./xcgg(2) - - xobmr = 1./xbm_r - xoams = 1./xam_s - xobms = 1./xbm_s - xocms = xoams**xobms - xoamg = 1./xam_g - xobmg = 1./xbm_g - xocmg = xoamg**xobmg - - - end subroutine radar_init - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) - -! Complex refractive Index of Water as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C -! after Ray (1972) - - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN):: T,lambda - DOUBLE PRECISION:: epsinf,epss,epsr,epsi - DOUBLE PRECISION:: alpha,lambdas,sigma,nenner - COMPLEX*16, PARAMETER:: i = (0d0,1d0) - DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 - - epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T - epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & - + 1.190d-5 * (T - 25.0)*(T - 25.0) & - - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) - alpha = -16.8129d0/(T+273.16) + 0.0609265d0 - lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 - - nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & - + (lambdas/lambda)**(2d0-2d0*alpha) - epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * sin(alpha*PIx*0.5)+1d0)) / nenner - epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * cos(alpha*PIx*0.5)+0d0)) / nenner & - + lambda*1.25664/1.88496 - - m_complex_water_ray = SQRT(CMPLX(epsr,-epsi)) - - END FUNCTION m_complex_water_ray - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T) - -! complex refractive index of ice as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.0001,30] m; T in [-250.0,0.0] C -! Original comment from the Matlab-routine of Prof. Maetzler: -! Function for calculating the relative permittivity of pure ice in -! the microwave region, according to C. Maetzler, "Microwave -! properties of ice and snow", in B. Schmitt et al. (eds.) Solar -! System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer -! Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: -! TK = temperature (K), range 20 to 273.15 -! f = frequency in GHz, range 0.01 to 3000 - - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN):: T,lambda - DOUBLE PRECISION:: f,c,TK,B1,B2,b,deltabeta,betam,beta,theta,alfa - - c = 2.99d8 - TK = T + 273.16 - f = c / lambda * 1d-9 - - B1 = 0.0207 - B2 = 1.16d-11 - b = 335.0d0 - deltabeta = EXP(-10.02 + 0.0364*(TK-273.16)) - betam = (B1/TK) * ( EXP(b/TK) / ((EXP(b/TK)-1)**2) ) + B2*f*f - beta = betam + deltabeta - theta = 300. / TK - 1. - alfa = (0.00504d0 + 0.0062d0*theta) * EXP(-22.1d0*theta) - m_complex_ice_maetzler = 3.1884 + 9.1e-4*(TK-273.16) - m_complex_ice_maetzler = m_complex_ice_maetzler & - + CMPLX(0.0d0, (alfa/f + beta*f)) - m_complex_ice_maetzler = SQRT(CONJG(m_complex_ice_maetzler)) - - END FUNCTION m_complex_ice_maetzler - -!+---+-----------------------------------------------------------------+ - - subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, & - meltratio_outside, m_w, m_i, lambda, C_back, & - mixingrule,matrix,inclusion, & - host,hostmatrix,hostinclusion) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, & - meltratio_outside - DOUBLE PRECISION, INTENT(out):: C_back - COMPLEX*16, INTENT(in):: m_w, m_i - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, & - host, hostmatrix, hostinclusion - - COMPLEX*16:: m_core, m_air - DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, & - volg, vg, volair, volice, volwater, & - meltratio_outside_grenz, mra - INTEGER:: error - DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 - -! refractive index of air: - m_air = (1.0d0,0.0d0) - -! Limiting the degree of melting --- for safety: - fm = DMAX1(DMIN1(fmelt, 1.0d0), 0.0d0) -! Limiting the ratio of (melting on outside)/(melting on inside): - mra = DMAX1(DMIN1(meltratio_outside, 1.0d0), 0.0d0) - -! ! The relative portion of meltwater melting at outside should increase -! ! from the given input value (between 0 and 1) -! ! to 1 as the degree of melting approaches 1, -! ! so that the melting particle "converges" to a water drop. -! ! Simplest assumption is linear: - mra = mra + (1.0d0-mra)*fm - - x_w = x_g * fm - - D_g = a_geo * x_g**b_geo - - if (D_g .ge. 1d-12) then - - vg = PIx/6. * D_g**3 - rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) - vg = x_g / rhog - - meltratio_outside_grenz = 1.0d0 - rhog / 1000. - - if (mra .le. meltratio_outside_grenz) then - !..In this case, it cannot happen that, during melting, all the - !.. air inclusions within the ice particle get filled with - !.. meltwater. This only happens at the end of all melting. - volg = vg * (1.0d0 - mra * fm) - - else - !..In this case, at some melting degree fm, all the air - !.. inclusions get filled with meltwater. - fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) - - if (fm .le. fmgrenz) then - !.. not all air pockets are filled: - volg = (1.0 - mra * fm) * vg - else - !..all air pockets are filled with meltwater, now the - !.. entire ice sceleton melts homogeneously: - volg = (x_g - x_w) / 900.0 + x_w / 1000. - endif - - endif - - D_large = (6.0 / PIx * volg) ** (1./3.) - volice = (x_g - x_w) / (volg * 900.0) - volwater = x_w / (1000. * volg) - volair = 1.0 - volice - volwater - - !..complex index of refraction for the ice-air-water mixture - !.. of the particle: - m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & - volwater, mixingrule, host, matrix, inclusion, & - hostmatrix, hostinclusion, error) - if (error .ne. 0) then - C_back = 0.0d0 - return - endif - - !..Rayleigh-backscattering coefficient of melting particle: - C_back = (ABS((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & - * PI5 * D_large**6 / lamda4 - - else - C_back = 0.0d0 - endif - - end subroutine rayleigh_soak_wetgraupel - -!+---+-----------------------------------------------------------------+ - - complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, & - volice, volwater, mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion, cumulerror) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion - INTEGER, INTENT(out):: cumulerror - - DOUBLE PRECISION:: vol1, vol2 - COMPLEX*16:: mtmp - INTEGER:: error - - !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be - !.. air, ice, or water - - cumulerror = 0 - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - - if (host .eq. 'air') then - - if (matrix .eq. 'air') then - write(*,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volice / MAX(volice+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'air') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'icewater') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'ice') then - - if (matrix .eq. 'ice') then - write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volair+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'ice') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airwater') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - 'air', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'water') then - - if (matrix .eq. 'water') then - write(*,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volice+volair,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'water') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airice') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'none') then - - get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & - volair, volice, volwater, mixingrule, & - matrix, inclusion, error) - cumulerror = cumulerror + error - - else - write(*,*) 'GET_M_MIX_NESTED: unknown matrix: ', host - cumulerror = cumulerror + 1 - endif - - IF (cumulerror .ne. 0) THEN - write(*,*) 'GET_M_MIX_NESTED: error encountered' - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - endif - - end function get_m_mix_nested - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & - volwater, mixingrule, matrix, inclusion, error) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion - INTEGER, INTENT(out):: error - - error = 0 - get_m_mix = CMPLX(1.0d0,0.0d0) - - if (mixingrule .eq. 'maxwellgarnett') then - if (matrix .eq. 'ice') then - get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & - m_i, m_a, m_w, inclusion, error) - elseif (matrix .eq. 'water') then - get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & - m_w, m_a, m_i, inclusion, error) - elseif (matrix .eq. 'air') then - get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & - m_a, m_w, m_i, inclusion, error) - else - write(*,*) 'GET_M_MIX: unknown matrix: ', matrix - error = 1 - endif - - else - write(*,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule - error = 2 - endif - - if (error .ne. 0) then - write(*,*) 'GET_M_MIX: error encountered' - endif - - END FUNCTION get_m_mix - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & - m1, m2, m3, inclusion, error) - - IMPLICIT NONE - - COMPLEX*16 :: m1, m2, m3 - DOUBLE PRECISION :: vol1, vol2, vol3 - CHARACTER(len=*) :: inclusion - - COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t - INTEGER, INTENT(out) :: error - - error = 0 - - if (DABS(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then - write(*,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & - 'partial volume fractions is not 1...ERROR' - m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m1t = m1**2 - m2t = m2**2 - m3t = m3**2 - - if (inclusion .eq. 'spherical') then - beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) - beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) - elseif (inclusion .eq. 'spheroidal') then - beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) - beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) - else - write(*,*) 'M_COMPLEX_MAXWELLGARNETT: ', & - 'unknown inclusion: ', inclusion - m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m_complex_maxwellgarnett = & - SQRT(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & - (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) - - END FUNCTION m_complex_maxwellgarnett - -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) -! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. - IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & - COF = (/76.18009172947146D0, -86.50532032941677D0, & - 24.01409824083091D0, -1.231739572450155D0, & - .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J - - X=XX - Y=X - TMP=X+5.5D0 - TMP=(X+0.5D0)*LOG(TMP)-TMP - SER=1.000000000190015D0 - DO 11 J=1,6 - Y=Y+1.D0 - SER=SER+COF(J)/Y -11 CONTINUE - GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) - - IMPLICIT NONE - REAL, INTENT(IN):: y - - WGAMMA = EXP(GAMMLN(y)) - - END FUNCTION WGAMMA - -!+---+-----------------------------------------------------------------+ - END MODULE module_mp_radar -!+---+-----------------------------------------------------------------+ diff --git a/gfsphysics/physics/module_mp_thompson_gfs.F90 b/gfsphysics/physics/module_mp_thompson_gfs.F90 deleted file mode 100644 index 8c06d8935..000000000 --- a/gfsphysics/physics/module_mp_thompson_gfs.F90 +++ /dev/null @@ -1,4170 +0,0 @@ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Prior to WRFv2.2 this code was based on Reisner et al (1998), but -!.. few of those pieces remain. A complete description is now found in -!.. Thompson, G., P. R. Field, R. M. Rasmussen, and W. D. Hall, 2008: -!.. Explicit Forecasts of winter precipitation using an improved bulk -!.. microphysics scheme. Part II: Implementation of a new snow -!.. parameterization. Mon. Wea. Rev., 136, 5095-5115. -!.. Prior to WRFv3.1, this code was single-moment rain prediction as -!.. described in the reference above, but in v3.1 and higher, the -!.. scheme is two-moment rain (predicted rain number concentration). -!.. -!.. Most importantly, users may wish to modify the prescribed number of -!.. cloud droplets (Nt_c; see guidelines mentioned below). Otherwise, -!.. users may alter the rain and graupel size distribution parameters -!.. to use exponential (Marshal-Palmer) or generalized gamma shape. -!.. The snow field assumes a combination of two gamma functions (from -!.. Field et al. 2005) and would require significant modifications -!.. throughout the entire code to alter its shape as well as accretion -!.. rates. Users may also alter the constants used for density of rain, -!.. graupel, ice, and snow, but the latter is not constant when using -!.. Paul Field's snow distribution and moments methods. Other values -!.. users can modify include the constants for mass and/or velocity -!.. power law relations and assumed capacitances used in deposition/ -!.. sublimation/evaporation/melting. -!.. Remaining values should probably be left alone. -!.. -!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 27 Jul 2012 -!+---+-----------------------------------------------------------------+ -!wrft:model_layer:physics -!+---+-----------------------------------------------------------------+ -! - MODULE module_mp_thompson - - USE physcons, ONLY : g => con_g - USE module_mp_radar - - IMPLICIT NONE - - LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. - INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 - REAL, PARAMETER, PRIVATE:: T_0 = 273.15 - REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 - -!..Densities of rain, snow, graupel, and cloud ice. - REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 - REAL, PARAMETER, PRIVATE:: rho_s = 100.0 - REAL, PARAMETER, PRIVATE:: rho_g = 500.0 - REAL, PARAMETER, PRIVATE:: rho_i = 890.0 - -!..Prescribed number of cloud droplets. Set according to known data or -!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and -!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter, -!.. mu_c, calculated based on Nt_c is important in autoconversion -!.. scheme. -! REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 - REAL, PARAMETER, PRIVATE:: Nt_co = 100.E6 - REAL, PARAMETER, PRIVATE:: Nt_cl = 300.E6 - -!..Generalized gamma distributions for rain, graupel and cloud ice. -!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. - REAL, PARAMETER, PRIVATE:: mu_r = 0.0 - REAL, PARAMETER, PRIVATE:: mu_g = 0.0 - REAL, PARAMETER, PRIVATE:: mu_i = 0.0 -! REAL, PRIVATE:: mu_c - REAL, PRIVATE:: mu_co, mu_cl - -!..Sum of two gamma distrib for snow (Field et al. 2005). -!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) -!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] -!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively -!.. calculated as function of ice water content and temperature. - REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 - REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 - REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 - REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 - REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 - -!..Y-intercept parameter for graupel is not constant and depends on -!.. mixing ratio. Also, when mu_g is non-zero, these become equiv -!.. y-intercept for an exponential distrib and proper values are -!.. computed based on same mixing ratio and total number concentration. - REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4 - REAL, PARAMETER, PRIVATE:: gonv_max = 3.E6 - -!..Mass power law relations: mass = am*D**bm -!.. Snow from Field et al. (2005), others assume spherical form. - REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 - REAL, PARAMETER, PRIVATE:: bm_r = 3.0 - REAL, PARAMETER, PRIVATE:: am_s = 0.069 - REAL, PARAMETER, PRIVATE:: bm_s = 2.0 - REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0 - REAL, PARAMETER, PRIVATE:: bm_g = 3.0 - REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0 - REAL, PARAMETER, PRIVATE:: bm_i = 3.0 - -!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) -!.. Rain from Ferrier (1994), ice, snow, and graupel from -!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. - REAL, PARAMETER, PRIVATE:: av_r = 4854.0 - REAL, PARAMETER, PRIVATE:: bv_r = 1.0 - REAL, PARAMETER, PRIVATE:: fv_r = 195.0 - REAL, PARAMETER, PRIVATE:: av_s = 40.0 - REAL, PARAMETER, PRIVATE:: bv_s = 0.55 - REAL, PARAMETER, PRIVATE:: fv_s = 100.0 - REAL, PARAMETER, PRIVATE:: av_g = 442.0 - REAL, PARAMETER, PRIVATE:: bv_g = 0.89 - REAL, PARAMETER, PRIVATE:: av_i = 1847.5 - REAL, PARAMETER, PRIVATE:: bv_i = 1.0 - -!..Capacitance of sphere and plates/aggregates: D**3, D**2 - REAL, PARAMETER, PRIVATE:: C_cube = 0.5 - REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3 - -!..Collection efficiencies. Rain/snow/graupel collection of cloud -!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and -!.. get computed elsewhere because they are dependent on stokes -!.. number. - REAL, PARAMETER, PRIVATE:: Ef_si = 0.05 - REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75 - REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 - -!..Minimum microphys values -!.. R1 value, 1.E-12, cannot be set lower because of numerical -!.. problems with Paul Field's moments and should not be set larger -!.. because of truncation problems in snow/ice growth. - REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 - REAL, PARAMETER, PRIVATE:: R2 = 1.E-6 - REAL, PARAMETER, PRIVATE:: eps = 1.E-15 - -!..Constants in Cooper curve relation for cloud ice number. - REAL, PARAMETER, PRIVATE:: TNO = 5.0 - REAL, PARAMETER, PRIVATE:: ATO = 0.304 - -!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) - -!..Schmidt number - REAL, PARAMETER, PRIVATE:: Sc = 0.632 - REAL, PRIVATE:: Sc3 - -!..Homogeneous freezing temperature - REAL, PARAMETER, PRIVATE:: HGFR = 235.16 - -!..Water vapor and air gas constants at constant pressure - REAL, PARAMETER, PRIVATE:: Rv = 461.5 - REAL, PARAMETER, PRIVATE:: oRv = 1./Rv - REAL, PARAMETER, PRIVATE:: R = 287.04 - REAL, PARAMETER, PRIVATE:: Cp = 1004.0 - -!..Enthalpy of sublimation, vaporization, and fusion at 0C. - REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 - REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 - REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 - REAL, PARAMETER, PRIVATE:: olfus = 1./lfus - -!..Ice initiates with this mass (kg), corresponding diameter calc. -!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 - REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 - REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 200.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 250.E-6 - REAL, PRIVATE:: D0i, xm0s, xm0g - -!..Lookup table dimensions - INTEGER, PARAMETER, PRIVATE:: nbins = 100 - INTEGER, PARAMETER, PRIVATE:: nbc = nbins - INTEGER, PARAMETER, PRIVATE:: nbi = nbins - INTEGER, PARAMETER, PRIVATE:: nbr = nbins - INTEGER, PARAMETER, PRIVATE:: nbs = nbins - INTEGER, PARAMETER, PRIVATE:: nbg = nbins - INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 - INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 - INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 - INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 - - DOUBLE PRECISION, DIMENSION(nbins+1):: xDx - DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc - DOUBLE PRECISION, DIMENSION(nbi):: Di, dti - DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr - DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts - DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg - -!..Lookup tables for cloud water content (kg/m**3). - REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & - r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for cloud ice content (kg/m**3). - REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & - r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & - 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & - 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & - 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & - 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & - 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3/) - -!..Lookup tables for rain content (kg/m**3). - REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & - r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for graupel content (kg/m**3). - REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & - r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for snow content (kg/m**3). - REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & - r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for rain y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & - N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & - 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & - 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & - 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & - 1.e10/) - -!..Lookup tables for graupel y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: & - N0g_exp = (/1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & - 1.e7/) - -!..Lookup tables for ice number concentration (/m**3). - REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & - Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & - 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & - 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & - 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & - 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6/) - -!..For snow moments conversions (from Field et al. 2005) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) - -!..Temperatures (5 C interval 0 to -40) used in lookup tables. - REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & - Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) - -!..Lookup tables for various accretion/collection terms. -!.. ntb_x refers to the number of elements for rain, snow, graupel, -!.. and temperature array indices. Variables beginning with t-p/c/m/n -!.. represent lookup tables. Save compile-time memory by making -!.. allocatable (2009Jun12, J. Michalakes). - INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & - tnr_racg, tnr_gacr - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & - tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & - tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 -! REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: & - tpi_qcfz, tni_qcfz - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: & - tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & - tps_iaus, tni_iaus, tpi_ide - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev - -!..Variables holding a bunch of exponents and gamma values (cloud water, -!.. cloud ice, rain, snow, then graupel). -! REAL, DIMENSION(3), PRIVATE:: cce, ccg -! REAL, PRIVATE:: ocg1, ocg2 - REAL, DIMENSION(3,2), PRIVATE:: cce, ccg - REAL, DIMENSION(2), PRIVATE:: ocg1, ocg2 - REAL, DIMENSION(7), PRIVATE:: cie, cig - REAL, PRIVATE:: oig1, oig2, obmi - REAL, DIMENSION(13), PRIVATE:: cre, crg - REAL, PRIVATE:: ore1, org1, org2, org3, obmr - REAL, DIMENSION(18), PRIVATE:: cse, csg - REAL, PRIVATE:: oams, obms, ocms - REAL, DIMENSION(12), PRIVATE:: cge, cgg - REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg - -!..Declaration of precomputed constants in various rate eqns. - REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi - REAL:: t1_qr_ev, t2_qr_ev - REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd - REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me - -! CHARACTER*256:: mp_debug - -!+---+ -!+---+-----------------------------------------------------------------+ -!..END DECLARATIONS -!+---+-----------------------------------------------------------------+ -!+---+ -!ctrlL - - CONTAINS - - SUBROUTINE thompson_init - - IMPLICIT NONE - - INTEGER:: i, j, k, m, n - LOGICAL:: micro_init - -!..Allocate space for lookup tables (J. Michalakes 2009Jun08). - micro_init = .FALSE. - - if (.NOT. ALLOCATED(tcg_racg) ) then - ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - micro_init = .TRUE. - endif - - if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - - if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - -! if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45)) -! if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45)) - if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45,2)) - if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45,2)) - - if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45)) - if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45)) - if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45)) - if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45)) - - if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) - if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) - if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1)) - - if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc)) - if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc)) - - if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r)) - - if (micro_init) then - -!..From Martin et al. (1994), assign gamma shape parameter mu for cloud -!.. drops according to general dispersion characteristics (disp=~0.25 -!.. for Maritime and 0.45 for Continental). -!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime -!.. to 2 for really dirty air. -! mu_c = MIN(15., (1000.E6/Nt_c + 2.)) - mu_co = MIN(15., (1000.E6/Nt_co + 2.)) - mu_cl = MIN(15., (1000.E6/Nt_cl + 2.)) - -!..Schmidt number to one-third used numerous times. - Sc3 = Sc**(1./3.) - -!..Compute min ice diam from mass, min snow/graupel mass from diam. - D0i = (xm0i/am_i)**(1./bm_i) - xm0s = am_s * D0s**bm_s - xm0g = am_g * D0g**bm_g - -!..These constants various exponents and gamma() assoc with cloud, -!.. rain, snow, and graupel. -! cce(1) = mu_c + 1. -! cce(2) = bm_r + mu_c + 1. -! cce(3) = bm_r + mu_c + 4. -! ccg(1) = WGAMMA(cce(1)) -! ccg(2) = WGAMMA(cce(2)) -! ccg(3) = WGAMMA(cce(3)) -! ocg1 = 1./ccg(1) -! ocg2 = 1./ccg(2) - cce(1,1) = mu_cl + 1. - cce(1,2) = mu_co + 1. - cce(2,1) = bm_r + mu_cl + 1. - cce(2,2) = bm_r + mu_co + 1. - cce(3,1) = bm_r + mu_cl + 4. - cce(3,2) = bm_r + mu_co + 4. - ccg(1,1) = WGAMMA(cce(1,1)) - ccg(1,2) = WGAMMA(cce(1,2)) - ccg(2,1) = WGAMMA(cce(2,1)) - ccg(2,2) = WGAMMA(cce(2,2)) - ccg(3,1) = WGAMMA(cce(3,1)) - ccg(3,2) = WGAMMA(cce(3,2)) - ocg1(1) = 1./ccg(1,1) - ocg1(2) = 1./ccg(1,2) - ocg2(1) = 1./ccg(2,1) - ocg2(2) = 1./ccg(2,2) - - cie(1) = mu_i + 1. - cie(2) = bm_i + mu_i + 1. - cie(3) = bm_i + mu_i + bv_i + 1. - cie(4) = mu_i + bv_i + 1. - cie(5) = mu_i + 2. - cie(6) = bm_i*0.5 + mu_i + bv_i + 1. - cie(7) = bm_i*0.5 + mu_i + 1. - cig(1) = WGAMMA(cie(1)) - cig(2) = WGAMMA(cie(2)) - cig(3) = WGAMMA(cie(3)) - cig(4) = WGAMMA(cie(4)) - cig(5) = WGAMMA(cie(5)) - cig(6) = WGAMMA(cie(6)) - cig(7) = WGAMMA(cie(7)) - oig1 = 1./cig(1) - oig2 = 1./cig(2) - obmi = 1./bm_i - - cre(1) = bm_r + 1. - cre(2) = mu_r + 1. - cre(3) = bm_r + mu_r + 1. - cre(4) = bm_r*2. + mu_r + 1. - cre(5) = mu_r + bv_r + 1. - cre(6) = bm_r + mu_r + bv_r + 1. - cre(7) = bm_r*0.5 + mu_r + bv_r + 1. - cre(8) = bm_r + mu_r + bv_r + 3. - cre(9) = mu_r + bv_r + 3. - cre(10) = mu_r + 2. - cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) - cre(12) = bm_r*0.5 + mu_r + 1. - cre(13) = bm_r*2. + mu_r + bv_r + 1. - do n = 1, 13 - crg(n) = WGAMMA(cre(n)) - enddo - obmr = 1./bm_r - ore1 = 1./cre(1) - org1 = 1./crg(1) - org2 = 1./crg(2) - org3 = 1./crg(3) - - cse(1) = bm_s + 1. - cse(2) = bm_s + 2. - cse(3) = bm_s*2. - cse(4) = bm_s + bv_s + 1. - cse(5) = bm_s*2. + bv_s + 1. - cse(6) = bm_s*2. + 1. - cse(7) = bm_s + mu_s + 1. - cse(8) = bm_s + mu_s + 2. - cse(9) = bm_s + mu_s + 3. - cse(10) = bm_s + mu_s + bv_s + 1. - cse(11) = bm_s*2. + mu_s + bv_s + 1. - cse(12) = bm_s*2. + mu_s + 1. - cse(13) = bv_s + 2. - cse(14) = bm_s + bv_s - cse(15) = mu_s + 1. - cse(16) = 1.0 + (1.0 + bv_s)/2. - cse(17) = cse(16) + mu_s + 1. - cse(18) = bv_s + mu_s + 3. - do n = 1, 18 - csg(n) = WGAMMA(cse(n)) - enddo - oams = 1./am_s - obms = 1./bm_s - ocms = oams**obms - - cge(1) = bm_g + 1. - cge(2) = mu_g + 1. - cge(3) = bm_g + mu_g + 1. - cge(4) = bm_g*2. + mu_g + 1. - cge(5) = bm_g*2. + mu_g + bv_g + 1. - cge(6) = bm_g + mu_g + bv_g + 1. - cge(7) = bm_g + mu_g + bv_g + 2. - cge(8) = bm_g + mu_g + bv_g + 3. - cge(9) = mu_g + bv_g + 3. - cge(10) = mu_g + 2. - cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) - cge(12) = 0.5*(bv_g + 5.) + mu_g - do n = 1, 12 - cgg(n) = WGAMMA(cge(n)) - enddo - oamg = 1./am_g - obmg = 1./bm_g - ocmg = oamg**obmg - oge1 = 1./cge(1) - ogg1 = 1./cgg(1) - ogg2 = 1./cgg(2) - ogg3 = 1./cgg(3) - -!+---+-----------------------------------------------------------------+ -!..Simplify various rate eqns the best we can now. -!+---+-----------------------------------------------------------------+ - -!..Rain collecting cloud water and cloud ice - t1_qr_qc = PI*.25*av_r * crg(9) - t1_qr_qi = PI*.25*av_r * crg(9) - t2_qr_qi = PI*.25*am_r*av_r * crg(8) - -!..Graupel collecting cloud water - t1_qg_qc = PI*.25*av_g * cgg(9) - -!..Snow collecting cloud water - t1_qs_qc = PI*.25*av_s - -!..Snow collecting cloud ice - t1_qs_qi = PI*.25*av_s - -!..Evaporation of rain; ignore depositional growth of rain. - t1_qr_ev = 0.78 * crg(10) - t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) - -!..Sublimation/depositional growth of snow - t1_qs_sd = 0.86 - t2_qs_sd = 0.28*Sc3*SQRT(av_s) - -!..Melting of snow - t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 - t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) - -!..Sublimation/depositional growth of graupel - t1_qg_sd = 0.86 * cgg(10) - t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Melting of graupel - t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) - t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Constants for helping find lookup table indexes. - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) - nig3 = NINT(ALOG10(N0g_exp(1))) - -!..Create bins of cloud water (from min diameter up to 100 microns). - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 - do n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 - dtc(n) = (Dc(n) - Dc(n-1)) - enddo - -!..Create bins of cloud ice (from min diameter up to 5x min snow size). - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 5.0d0*D0s - do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) - dti(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of rain (from min diameter up to 5 mm). - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 - do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) - dtr(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of snow (from min diameter up to 2 cm). - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 - do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) - dts(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of graupel (from min diameter up to 5 cm). - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 - do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) - dtg(n) = xDx(n+1) - xDx(n) - enddo - -!+---+-----------------------------------------------------------------+ -!..Create lookup tables for most costly calculations. -!+---+-----------------------------------------------------------------+ - - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_g - do i = 1, ntb_g1 - tcg_racg(i,j,k,m) = 0.0d0 - tmr_racg(i,j,k,m) = 0.0d0 - tcr_gacr(i,j,k,m) = 0.0d0 - tmg_gacr(i,j,k,m) = 0.0d0 - tnr_racg(i,j,k,m) = 0.0d0 - tnr_gacr(i,j,k,m) = 0.0d0 - enddo - enddo - enddo - enddo - - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_t - do i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - tnr_racs1(i,j,k,m) = 0.0d0 - tnr_racs2(i,j,k,m) = 0.0d0 - tnr_sacr1(i,j,k,m) = 0.0d0 - tnr_sacr2(i,j,k,m) = 0.0d0 - enddo - enddo - enddo - enddo - - do k = 1, 45 - do j = 1, ntb_r1 - do i = 1, ntb_r - tpi_qrfz(i,j,k) = 0.0d0 - tni_qrfz(i,j,k) = 0.0d0 - tpg_qrfz(i,j,k) = 0.0d0 - tnr_qrfz(i,j,k) = 0.0d0 - enddo - enddo -! do i = 1, ntb_c -! tpi_qcfz(i,k) = 0.0d0 -! tni_qcfz(i,k) = 0.0d0 -! enddo - do j = 1, 2 - do i = 1, ntb_c - tpi_qcfz(i,k,j) = 0.0d0 - tni_qcfz(i,k,j) = 0.0d0 - enddo - enddo - enddo - - do j = 1, ntb_i1 - do i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 - enddo - enddo - - do j = 1, nbc - do i = 1, nbr - t_Efrw(i,j) = 0.0 - enddo - do i = 1, nbs - t_Efsw(i,j) = 0.0 - enddo - enddo - - do k = 1, ntb_r - do j = 1, ntb_r1 - do i = 1, nbr - tnr_rev(i,j,k) = 0.0d0 - enddo - enddo - enddo - -!..Collision efficiency between rain/snow and cloud water. - call table_Efrw - call table_Efsw - -!..Drop evaporation. -! CALL wrf_debug(200, ' creating rain evap table') -! call table_dropEvap - -!..Initialize various constants for computing radar reflectivity. - xam_r = am_r - xbm_r = bm_r - xmu_r = mu_r - xam_s = am_s - xbm_s = bm_s - xmu_s = mu_s - xam_g = am_g - xbm_g = bm_g - xmu_g = mu_g - call radar_init - - if (.not. iiwarm) then - -!..Rain collecting graupel & graupel collecting rain. -! CALL wrf_debug(200, ' creating rain collecting graupel table') -! print*, ' creating rain collecting graupel table' - call qr_acr_qg - -!..Rain collecting snow & snow collecting rain. -! CALL wrf_debug(200, ' creating rain collecting snow table') -! print*,' creating rain collecting snow table' - call qr_acr_qs - -!..Cloud water and rain freezing (Bigg, 1953). -! CALL wrf_debug(200, ' creating freezing of water drops table') -! print*,' creating freezing of water drops table' - call freezeH2O - -!..Conversion of some ice mass into snow category. -! CALL wrf_debug(200, ' creating ice converting to snow table') -! print*,' creating ice converting to snow table' - call qi_aut_qs - - endif - -! CALL wrf_debug(150, ' ... DONE microphysical lookup tables') -! print*,' ... DONE microphysical lookup tables' - - endif - - END SUBROUTINE thompson_init -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a wrapper routine designed to transfer values from 3D to 1D. -!+---+-----------------------------------------------------------------+ - SUBROUTINE mp_gt_driver(ims,ime,kms,kme,its,ite,kts,kte, & - qv, qc, qr, qi, qs, qg, ni, nr, & - tt, p, dz, dt_in,itimestep, & - RAINNCV, & - SR,islmsk, & - refl_10cm,lradar, & - re_cloud, re_ice, re_snow,me,phii) - - implicit none - -!..Subroutine arguments -! INTEGER, INTENT(IN):: ids,ide, kds,kde - INTEGER, INTENT(IN):: ims,ime, kms,kme, & - its,ite, kts,kte - REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, nr, tt - REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT):: & - re_cloud, re_ice, re_snow - REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN):: & - p, dz - REAL, DIMENSION(ims:ime, kms:kme+1), INTENT(IN):: phii - INTEGER, DIMENSION(ims:ime), INTENT(IN):: islmsk ! land and ocean - REAL, DIMENSION(its:ite), INTENT(INOUT):: & - RAINNCV, SR - REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT):: & - refl_10cm - REAL, INTENT(IN):: dt_in - INTEGER, INTENT(IN):: itimestep,me - -!..Local variables - REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dz1d, dBZ, nc1d - REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d - REAL, DIMENSION(its:ite):: pcp_ra, pcp_sn, pcp_gr, pcp_ic - REAL:: dt, pptrain, pptsnow, pptgraul, pptice - REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - INTEGER:: i, j, k - INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr - INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr - INTEGER:: i_start, i_end - LOGICAL, INTENT(IN) :: lradar - real :: Nt_c - -!+---+ - - i_start = its - i_end = MIN(ite, ime) - -!..For idealized testing by developer. -! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. & -! ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then -! i_start = its + 2 -! i_end = ite -! endif - - dt = dt_in - - qc_max = 0. - qr_max = 0. - qs_max = 0. - qi_max = 0. - qg_max = 0 - ni_max = 0. - nr_max = 0. - imax_qc = 0 - imax_qr = 0 - imax_qi = 0 - imax_qs = 0 - imax_qg = 0 - imax_ni = 0 - imax_nr = 0 - kmax_qc = 0 - kmax_qr = 0 - kmax_qi = 0 - kmax_qs = 0 - kmax_qg = 0 - kmax_ni = 0 - kmax_nr = 0 -! do i = 1, 256 -! mp_debug(i:i) = char(0) -! enddo - - i_loop: do i = i_start, i_end - - pptrain = 0. - pptsnow = 0. - pptgraul = 0. - pptice = 0. - RAINNCV(i) = 0. -! IF ( PRESENT (snowncv) ) THEN -! SNOWNCV(i) = 0. -! ENDIF -! IF ( PRESENT (graupelncv) ) THEN -! GRAUPELNCV(i) = 0. -! ENDIF - SR(i) = 0. - - if(islmsk(i) == 1) then - Nt_c = Nt_cl - else - Nt_c = Nt_co - endif - -! if(me==0) then -! print*,'islmsk,Nt_c:',i,islmsk(i),Nt_c,Nt_cl,Nt_co -! endif - - do k = kts, kte - t1d(k) = tt(i,k) - p1d(k) = p(i,k) - dz1d (k) = (phii(i,k+1)-phii(i,k)) / g -! qv1d(k) = qv(i,k) - qv1d(k) = qv(i,k)/(1.-qv(i,k)) - qc1d(k) = qc(i,k) - qi1d(k) = qi(i,k) - qr1d(k) = qr(i,k) - qs1d(k) = qs(i,k) - qg1d(k) = qg(i,k) - ni1d(k) = ni(i,k) - nr1d(k) = nr(i,k) - nc1d(k) = Nt_c - enddo - - call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dz1d, & - pptrain, pptsnow, pptgraul, pptice, & - islmsk(i), & - kts, kte, dt, i) - - pcp_ra(i) = pptrain - pcp_sn(i) = pptsnow - pcp_gr(i) = pptgraul - pcp_ic(i) = pptice - RAINNCV(i) = (pptrain + pptsnow + pptgraul + pptice)/1000. -! RAINNC(i) = RAINNC(i) + pptrain + pptsnow + pptgraul + pptice -! IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN -! SNOWNCV(i) = pptsnow + pptice -! SNOWNC(i) = SNOWNC(i) + pptsnow + pptice -! ENDIF -! IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN -! GRAUPELNCV(i) = pptgraul -! GRAUPELNC(i) = GRAUPELNC(i) + pptgraul -! ENDIF - SR(i) = (pptsnow + pptgraul + pptice)/(RAINNCV(i)*1000.+1.e-12) - - do k = kts, kte -! qv(i,k) = qv1d(k) - qv(i,k) = qv1d(k)/(1.+qv1d(k)) - qc(i,k) = qc1d(k) - qi(i,k) = qi1d(k) - qr(i,k) = qr1d(k) - qs(i,k) = qs1d(k) - qg(i,k) = qg1d(k) - ni(i,k) = ni1d(k) - nr(i,k) = nr1d(k) -!#ifdef WRF_CHEM -! rainprod(i,k,j) = rainprod1d(k) -! evapprod(i,k,j) = evapprod1d(k) -!#endif -! th(i,k) = t1d(k)/pii(i,k) - tt(i,k) = t1d(k) - if (qc1d(k) .gt. qc_max) then - imax_qc = i - kmax_qc = k - qc_max = qc1d(k) - elseif (qc1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative qc ', qc1d(k), & -! ' at i,k=', i,k - endif - if (qr1d(k) .gt. qr_max) then - imax_qr = i - kmax_qr = k - qr_max = qr1d(k) - elseif (qr1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative qr ', qr1d(k), & -! ' at i,k=', i,k - endif - if (nr1d(k) .gt. nr_max) then - imax_nr = i - kmax_nr = k - nr_max = nr1d(k) - elseif (nr1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative nr ', nr1d(k), & -! ' at i,k=', i,k - endif - if (qs1d(k) .gt. qs_max) then - imax_qs = i - kmax_qs = k - qs_max = qs1d(k) - elseif (qs1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative qs ', qs1d(k), & -! ' at i,k=', i,k - endif - if (qi1d(k) .gt. qi_max) then - imax_qi = i - kmax_qi = k - qi_max = qi1d(k) - elseif (qi1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative qi ', qi1d(k), & -! ' at i,k=', i,k - endif - if (qg1d(k) .gt. qg_max) then - imax_qg = i - kmax_qg = k - qg_max = qg1d(k) - elseif (qg1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative qg ', qg1d(k), & -! ' at i,k=', i,k - endif - if (ni1d(k) .gt. ni_max) then - imax_ni = i - kmax_ni = k - ni_max = ni1d(k) - elseif (ni1d(k) .lt. 0.0) then -! write(*,*) 'WARNING, negative ni ', ni1d(k), & -! ' at i,k=', i,k - endif - if (qv1d(k) .lt. 0.0) then - if (k.lt.kte-2 .and. k.gt.kts+1) then - qv(i,k) = 0.5*(qv(i,k-1) + qv(i,k+1)) - else - qv(i,k) = 1.E-7 - endif -! write(*,*) 'WARNING, negative qv ', qv1d(k), & -! ' at i,k=', i,k - endif - enddo - - if (lradar) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, i) - do k = kts, kte - refl_10cm(i,k) = MAX(-35., dBZ(k)) - enddo - endif - - do k = kts, kte - re_qc1d(k) = 2.51E-6 - re_qi1d(k) = 10.01E-6 - re_qs1d(k) = 10.01E-6 - enddo - call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & - islmsk(i), re_qc1d, re_qi1d, re_qs1d, kts, kte) - do k = kts, kte - re_cloud(i,k)=MAX( 2.51E-6, MIN(re_qc1d(k), 50.E-6))*1.e6 - re_ice(i,k) =MAX(10.01E-6, MIN(re_qi1d(k), 125.E-6))*1.e6 - re_snow(i,k) =MAX(10.01E-6, MIN(re_qs1d(k), 999.E-6))*1.e6 - enddo - enddo i_loop - -! DEBUG - GT -! write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,1x))') 'MP-GT:', & -! 'qc: ', qc_max, '(', imax_qc, ',', kmax_qc, ')', & -! 'qr: ', qr_max, '(', imax_qr, ',', kmax_qr, ')', & -! 'qi: ', qi_max, '(', imax_qi, ',', kmax_qi, ')', & -! 'qs: ', qs_max, '(', imax_qs, ',', kmax_qs, ')', & -! 'qg: ', qg_max, '(', imax_qg, ',', kmax_qg, ')', & -! 'ni: ', ni_max, '(', imax_ni, ',', kmax_ni, ')', & -! 'nr: ', nr_max, '(', imax_nr, ',', kmax_nr, ')' -! CALL wrf_debug(150, mp_debug) -! write(*,'(a,7(a,e13.6,1x,a,i3,a,i3,a,1x))') 'MP-GT:', & -! 'qc: ', qc_max, '(', imax_qc, ',', kmax_qc, ')', & -! 'qr: ', qr_max, '(', imax_qr, ',', kmax_qr, ')', & -! 'qi: ', qi_max, '(', imax_qi, ',', kmax_qi, ')', & -! 'qs: ', qs_max, '(', imax_qs, ',', kmax_qs, ')', & -! 'qg: ', qg_max, '(', imax_qg, ',', kmax_qg, ')', & -! 'ni: ', ni_max, '(', imax_ni, ',', kmax_ni, ')', & -! 'nr: ', nr_max, '(', imax_nr, ',', kmax_nr, ')' -! END DEBUG - GT - -! do i = 1, 256 -! mp_debug(i:i) = char(0) -! enddo - - END SUBROUTINE mp_gt_driver - -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Previously this code was based on Reisner et al (1998), but few of -!.. those pieces remain. A complete description is now found in -!.. Thompson et al. (2004, 2008). -!+---+-----------------------------------------------------------------+ -! - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & - islmski, & - kts, kte, dt, ii) - - implicit none - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii - INTEGER, INTENT(IN):: islmski - REAL, DIMENSION(kts:kte), INTENT(INOUT):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d -!#ifdef WRF_CHEM -! REAL, DIMENSION(kts:kte), INTENT(INOUT):: & -! rainprod, evapprod -!#endif - REAL, DIMENSION(kts:kte), INTENT(IN):: dzq - REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice - REAL, INTENT(IN):: dt - -!..Local variables - REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & - qrten, qsten, qgten, niten, nrten - - DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd - - DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, & - prr_rcg, prr_sml, prr_gml, & - prr_rci, prv_rev, & - pnr_wau, pnr_rcs, pnr_rcg, & - pnr_rci, pnr_sml, pnr_gml, & - pnr_rev, pnr_rcr, pnr_rfz - - DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & - pni_ihm, pri_wfz, pni_wfz, & - pri_rfz, pni_rfz, pri_ide, & - pni_ide, pri_rci, pni_rci, & - pni_sci, pni_iau - - DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & - prs_scw, prs_sde, prs_ihm, & - prs_ide - - DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & - prg_gcw, prg_rci, prg_rcs, & - prg_rcg, prg_ihm - - DOUBLE PRECISION, PARAMETER:: zeroD0 = 0.0d0 - - REAL, DIMENSION(kts:kte):: temp, pres, qv - REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr - REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 - REAL, DIMENSION(kts:kte):: qvs, qvsi, delQvs - REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati - REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & - tcond, lvap, ocp, lvt2 - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r, mvd_c - REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, & - smoc, smod, smoe, smof - - REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n - - REAL:: rgvm, delta_tp, orho, lfus2 - REAL, DIMENSION(4):: onstep - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg - DOUBLE PRECISION:: lami, ilami - REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m - DOUBLE PRECISION:: Dr_star - REAL:: zeta1, zeta, taud, tau - REAL:: stoke_r, stoke_s, stoke_g, stoke_i - REAL:: vti, vtr, vts, vtg - REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk - REAL, DIMENSION(kts:kte):: vts_boost - REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow - REAL:: a_, b_, loga_, A1, A2, tf - REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat - REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr - REAL:: xsat, rate_max, sump, ratio - REAL:: clap, fcd, dfcd - REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl - REAL:: r_frac, g_frac - REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr - REAL:: dtsave, odts, odt, odzq - REAL:: xslw1, ygra1, zans1 - INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq - INTEGER, DIMENSION(4):: ksed1 - INTEGER:: nir, nis, nig, nii, nic - INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & - idx_i1, idx_i, idx_c, idx, idx_d - LOGICAL:: melti, no_micro - LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg - LOGICAL:: debug_flag - INTEGER:: idx_lo ! land and ocean - -!+---+ - - debug_flag = .false. -! if (ii.eq.315 ) debug_flag = .true. - - no_micro = .true. - dtsave = dt - odt = 1./dt - odts = 1./dtsave - iexfrq = 1 - - if(islmski == 1) then - idx_lo = 1 - else - idx_lo = 2 - endif - -!+---+-----------------------------------------------------------------+ -!.. Source/sink terms. First 2 chars: "pr" represents source/sink of -!.. mass while "pn" represents source/sink of number. Next char is one -!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for -!.. cloud water, "s" for snow, and "g" for graupel. Next chars -!.. represent processes: "de" for sublimation/deposition, "ev" for -!.. evaporation, "fz" for freezing, "ml" for melting, "au" for -!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop -!.. secondary ice production, and "c" for collection followed by the -!.. character for the species being collected. ALL of these terms are -!.. positive (except for deposition/sublimation terms which can switch -!.. signs based on super/subsaturation) and are treated as negatives -!.. where necessary in the tendency equations. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - tten(k) = 0. - qvten(k) = 0. - qcten(k) = 0. - qiten(k) = 0. - qrten(k) = 0. - qsten(k) = 0. - qgten(k) = 0. - niten(k) = 0. - nrten(k) = 0. - - prw_vcd(k) = 0. - - prv_rev(k) = 0. - prr_wau(k) = 0. - prr_rcw(k) = 0. - prr_rcs(k) = 0. - prr_rcg(k) = 0. - prr_sml(k) = 0. - prr_gml(k) = 0. - prr_rci(k) = 0. - pnr_wau(k) = 0. - pnr_rcs(k) = 0. - pnr_rcg(k) = 0. - pnr_rci(k) = 0. - pnr_sml(k) = 0. - pnr_gml(k) = 0. - pnr_rev(k) = 0. - pnr_rcr(k) = 0. - pnr_rfz(k) = 0. - - pri_inu(k) = 0. - pni_inu(k) = 0. - pri_ihm(k) = 0. - pni_ihm(k) = 0. - pri_wfz(k) = 0. - pni_wfz(k) = 0. - pri_rfz(k) = 0. - pni_rfz(k) = 0. - pri_ide(k) = 0. - pni_ide(k) = 0. - pri_rci(k) = 0. - pni_rci(k) = 0. - pni_sci(k) = 0. - pni_iau(k) = 0. - - prs_iau(k) = 0. - prs_sci(k) = 0. - prs_rcs(k) = 0. - prs_scw(k) = 0. - prs_sde(k) = 0. - prs_ihm(k) = 0. - prs_ide(k) = 0. - - prg_scw(k) = 0. - prg_rfz(k) = 0. - prg_gde(k) = 0. - prg_gcw(k) = 0. - prg_rci(k) = 0. - prg_rcs(k) = 0. - prg_rcg(k) = 0. - prg_ihm(k) = 0. - enddo -!#ifdef WRF_CHEM -! do k = kts, kte -! rainprod(k) = 0. -! evapprod(k) = 0. -! enddo -!#endif - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - if (qc1d(k) .gt. R1) then - no_micro = .false. - rc(k) = qc1d(k)*rho(k) - L_qc(k) = .true. - else - qc1d(k) = 0.0 - rc(k) = R1 - L_qc(k) = .false. - endif - if (qi1d(k) .gt. R1) then - no_micro = .false. - ri(k) = qi1d(k)*rho(k) - ni(k) = MAX(R2, ni1d(k)*rho(k)) - L_qi(k) = .true. - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 20.E-6) then - lami = cie(2)/20.E-6 - ni(k) = MIN(250.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i - endif - else - qi1d(k) = 0.0 - ni1d(k) = 0.0 - ri(k) = R1 - ni(k) = R2 - L_qi(k) = .false. - endif - - if (qr1d(k) .gt. R1) then - no_micro = .false. - rr(k) = qr1d(k)*rho(k) - nr(k) = MAX(R2, nr1d(k)*rho(k)) - L_qr(k) = .true. - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r - endif - else - qr1d(k) = 0.0 - nr1d(k) = 0.0 - rr(k) = R1 - nr(k) = R2 - L_qr(k) = .false. - endif - if (qs1d(k) .gt. R1) then - no_micro = .false. - rs(k) = qs1d(k)*rho(k) - L_qs(k) = .true. - else - qs1d(k) = 0.0 - rs(k) = R1 - L_qs(k) = .false. - endif - if (qg1d(k) .gt. R1) then - no_micro = .false. - rg(k) = qg1d(k)*rho(k) - L_qg(k) = .true. - else - qg1d(k) = 0.0 - rg(k) = R1 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Derive various thermodynamic variables frequently used. -!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from -!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from -!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - tempc = temp(k) - 273.15 - rhof(k) = SQRT(RHO_NOT/rho(k)) - rhof2(k) = SQRT(rhof(k)) - qvs(k) = rslf(pres(k), temp(k)) - delQvs(k) = MAX(0.0, rslf(pres(k), 273.15)-qv(k)) - if (tempc .le. 0.0) then - qvsi(k) = rsif(pres(k), temp(k)) - else - qvsi(k) = qvs(k) - endif - satw(k) = qv(k)/qvs(k) - sati(k) = qv(k)/qvsi(k) - ssatw(k) = satw(k) - 1. - ssati(k) = sati(k) - 1. - if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0 - if (abs(ssati(k)).lt. eps) ssati(k) = 0.0 - if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false. - diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) - if (tempc .ge. 0.0) then - visco(k) = (1.718+0.0049*tempc)*1.0E-5 - else - visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 - endif - ocp(k) = 1./(Cp*(1.+0.887*qv(k))) - vsc2(k) = SQRT(rho(k)/visco(k)) - lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc - tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 - enddo - -!+---+-----------------------------------------------------------------+ -!..If no existing hydrometeor species and no chance to initiate ice or -!.. condense cloud water, just exit quickly! -!+---+-----------------------------------------------------------------+ - - if (no_micro) return - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope, and useful moments for snow. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams - -!..All other moments based on reference, 2nd moment. If bm_s.ne.2, -!.. then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif - -!..Calculate 0th moment. Represents snow number concentration. - loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0 - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0 - smo0(k) = a_ * smo2(k)**b_ - -!..Calculate 1st moment. Useful for depositional growth and melting. - loga_ = sa(1) + sa(2)*tc0 + sa(3) & - + sa(4)*tc0 + sa(5)*tc0*tc0 & - + sa(6) + sa(7)*tc0*tc0 & - + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & - + sa(10) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & - + sb(5)*tc0*tc0 + sb(6) & - + sb(7)*tc0*tc0 + sb(8)*tc0 & - + sb(9)*tc0*tc0*tc0 + sb(10) - smo1(k) = a_ * smo2(k)**b_ - -!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ - -!..Calculate bv_s+2 (th) moment. Useful for riming. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & - + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & - + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & - + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(13)*cse(13)*cse(13) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & - + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & - + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) - smoe(k) = a_ * smo2(k)**b_ - -!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & - + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & - + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & - + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(16)*cse(16)*cse(16) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & - + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & - + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) - smof(k) = a_ * smo2(k)**b_ - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for graupel. -!+---+-----------------------------------------------------------------+ - N0_min = gonv_max - do k = kte, kts, -1 - if (temp(k).lt.270.65 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then - xslw1 = 4.01 + alog10(mvd_r(k)) - else - xslw1 = 0.01 - endif - ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) - zans1 = 3.1 + (100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1)) - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) -!+---+-----------------------------------------------------------------+ -! if( debug_flag .and. k.lt.42) then -! if (k.eq.41) write(mp_debug,*) 'DEBUG-GT: K, zans1, rc, rr, rg, N0_g' -! if (k.eq.41) CALL wrf_debug(0, mp_debug) -! write(mp_debug, 'a, i2, 1x, f6.3, 1x, 4(1x,e13.6,1x)') & -! ' GT ', k, zans1, rc(k), rr(k), rg(k), N0_g(k) -! CALL wrf_debug(0, mp_debug) -! endif -!+---+-----------------------------------------------------------------+ - enddo - - endif - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for rain. -!+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - ilamr(k) = 1./lamr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - N0_r(k) = nr(k)*org2*lamr**cre(2) - enddo - -!+---+-----------------------------------------------------------------+ -!..Compute warm-rain process terms (except evap done later). -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - -!..Rain self-collection follows Seifert, 1994 and drop break-up -!.. follows Verlinde and Cotton, 1993. RAIN2M - if (L_qr(k) .and. mvd_r(k).gt. D0r) then -!-GT Ef_rr = 1.0 -!-GT if (mvd_r(k) .gt. 1500.0E-6) then - Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1600.0E-6)) -!-GT endif - pnr_rcr(k) = Ef_rr * 4.*nr(k)*rr(k) - endif - - mvd_c(k) = D0c - if (.not. L_qc(k)) CYCLE -! xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6) -! lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr - if(islmski == 1) then - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_cl))**obmr) * 1.E6) - lamc = (Nt_cl*am_r* ccg(2,1) * ocg1(1) / rc(k))**obmr ! land - else - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_co))**obmr) * 1.E6) - lamc = (Nt_co*am_r* ccg(2,2) * ocg1(2) / rc(k))**obmr ! ocean - endif -! mvd_c(k) = (3.0+mu_c+0.672) / lamc - if(islmski == 1) then - mvd_c(k) = (3.0+mu_cl+0.672) / lamc - else - mvd_c(k) = (3.0+mu_co+0.672) / lamc - endif - -! print*,'mvd_c:',mvd_c(k),islmski,mu_co,mu_cl,lamc - -!..Autoconversion follows Berry & Reinhardt (1974) with characteristic -!.. diameters correctly computed from gamma distrib of cloud droplets. - if (rc(k).gt. 0.01e-3) then -! Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6 - if(islmski == 1) then - Dc_g = ((ccg(3,1)*ocg2(1))**obmr / lamc) * 1.E6 - else - Dc_g = ((ccg(3,2)*ocg2(2))**obmr / lamc) * 1.E6 - endif - - Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) & - **(1./6.) - zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) & - + abs(6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4)) - zeta = 0.027*rc(k)*zeta1 - taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 - tau = 3.72/(rc(k)*taud) - prr_wau(k) = zeta/tau - prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) -! pnr_wau(k) = prr_wau(k) / (am_r*mu_c*D0r*D0r*D0r) ! RAIN2M - if(islmski == 1) then - pnr_wau(k) = prr_wau(k) / (am_r*mu_cl*D0r*D0r*D0r) ! RAIN2M - else - pnr_wau(k) = prr_wau(k) / (am_r*mu_co*D0r*D0r*D0r) ! RAIN2M - endif - endif - -!..Rain collecting cloud water. In CE, assume Dc<1). Either way, only bother to do sedimentation below -!.. 1st level that contains any sedimenting particles (k=ksed1 on down). -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!+---+-----------------------------------------------------------------+ - nstep = 0 - onstep(:) = 1.0 - ksed1(:) = 1 - do k = kte+1, kts, -1 - vtrk(k) = 0. - vtnrk(k) = 0. - vtik(k) = 0. - vtnik(k) = 0. - vtsk(k) = 0. - vtgk(k) = 0. - enddo - do k = kte, kts, -1 - vtr = 0. - rhof(k) = SQRT(RHO_NOT/rho(k)) - - if (rr(k).gt. R1) then - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & - *((lamr+fv_r)**(-cre(6))) - vtrk(k) = vtr -! First below is technically correct: -! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & -! *((lamr+fv_r)**(-cre(5))) -! Test: make number fall faster (but still slower than mass) -! Goal: less prominent size sorting - vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & - *((lamr+fv_r)**(-cre(7))) - vtnrk(k) = vtr - else - vtrk(k) = vtrk(k+1) - vtnrk(k) = vtnrk(k+1) - endif - - if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then - ksed1(1) = MAX(ksed1(1), k) - delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(1) .eq. kte) ksed1(1) = kte-1 - if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - if (.not. iiwarm) then - - nstep = 0 - do k = kte, kts, -1 - vti = 0. - - if (ri(k).gt. R1) then - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i - vtik(k) = vti -! First below is technically correct: -! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i -! Goal: less prominent size sorting - vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i - vtnik(k) = vti - else - vtik(k) = vtik(k+1) - vtnik(k) = vtnik(k+1) - endif - - if (vtik(k) .gt. 1.E-3) then - ksed1(2) = MAX(ksed1(2), k) - delta_tp = dzq(k)/vtik(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(2) .eq. kte) ksed1(2) = kte-1 - if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - nstep = 0 - do k = kte, kts, -1 - vts = 0. - - if (rs(k).gt. R1) then - xDs = smoc(k) / smob(k) - Mrat = 1./xDs - ils1 = 1./(Mrat*Lam0 + fv_s) - ils2 = 1./(Mrat*Lam1 + fv_s) - t1_vts = Kap0*csg(4)*ils1**cse(4) - t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) - ils1 = 1./(Mrat*Lam0) - ils2 = 1./(Mrat*Lam1) - t3_vts = Kap0*csg(1)*ils1**cse(1) - t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) - vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. T_0) then - vtsk(k) = MAX(vts*vts_boost(k), vtrk(k)) - else - vtsk(k) = vts*vts_boost(k) - endif - else - vtsk(k) = vtsk(k+1) - endif - - if (vtsk(k) .gt. 1.E-3) then - ksed1(3) = MAX(ksed1(3), k) - delta_tp = dzq(k)/vtsk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(3) .eq. kte) ksed1(3) = kte-1 - if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - nstep = 0 - do k = kte, kts, -1 - vtg = 0. - - if (rg(k).gt. R1) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g - if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) - else - vtgk(k) = vtg - endif - else - vtgk(k) = vtgk(k+1) - endif - - if (vtgk(k) .gt. 1.E-3) then - ksed1(4) = MAX(ksed1(4), k) - delta_tp = dzq(k)/vtgk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(4) .eq. kte) ksed1(4) = kte-1 - if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) - endif - -!+---+-----------------------------------------------------------------+ -!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, -!.. whereas neglect m(D) term for number concentration. Therefore, -!.. cloud ice has proper differential sedimentation. -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(1)) - do n = 1, nstep - do k = kte, kts, -1 - sed_r(k) = vtrk(k)*rr(k) - sed_n(k) = vtnrk(k)*nr(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho - nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) - do k = ksed1(1), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*onstep(1)*orho - nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(1)) - enddo - - if (rr(kts).gt.R1*10.) & - pptrain = pptrain + sed_r(kts)*DT*onstep(1) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(2)) - do n = 1, nstep - do k = kte, kts, -1 - sed_i(k) = vtik(k)*ri(k) - sed_n(k) = vtnik(k)*ni(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho - niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) - do k = ksed1(2), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*onstep(2)*orho - niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(2)) - enddo - - if (ri(kts).gt.R1*10.) & - pptice = pptice + sed_i(kts)*DT*onstep(2) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(3)) - do n = 1, nstep - do k = kte, kts, -1 - sed_s(k) = vtsk(k)*rs(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) - do k = ksed1(3), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*DT*onstep(3)) - enddo - - if (rs(kts).gt.R1*10.) & - pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(4)) - do n = 1, nstep - do k = kte, kts, -1 - sed_g(k) = vtgk(k)*rg(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) - do k = ksed1(4), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*DT*onstep(4)) - enddo - - if (rg(kts).gt.R1*10.) & - pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) - enddo - -!+---+-----------------------------------------------------------------+ -!.. Instantly melt any cloud ice into cloud water if above 0C and -!.. instantly freeze any cloud water found below HGFR. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - xri = MAX(0.0, qi1d(k) + qiten(k)*DT) - if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then - qcten(k) = qcten(k) + xri*odt - qiten(k) = qiten(k) - xri*odt - niten(k) = -ni1d(k)*odt - tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) - endif - - xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) - if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then - lfus2 = lsub - lvap(k) - qiten(k) = qiten(k) + xrc*odt - niten(k) = niten(k) + xrc/xm0i * odt - qcten(k) = qcten(k) - xrc*odt - tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) - endif - enddo - endif - -!+---+-----------------------------------------------------------------+ -!.. All tendencies computed, apply and pass back final values to parent. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - t1d(k) = t1d(k) + tten(k)*DT - qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) - qc1d(k) = qc1d(k) + qcten(k)*DT - if (qc1d(k) .le. R1) qc1d(k) = 0.0 - qi1d(k) = qi1d(k) + qiten(k)*DT - ni1d(k) = MAX(R2/rho(k), ni1d(k) + niten(k)*DT) - if (qi1d(k) .le. R1) then - qi1d(k) = 0.0 - ni1d(k) = 0.0 - else - lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 20.E-6) then - lami = cie(2)/20.E-6 - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - endif - ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 250.D3/rho(k)) - endif - qr1d(k) = qr1d(k) + qrten(k)*DT - nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) - if (qr1d(k) .le. R1) then - qr1d(k) = 0.0 - nr1d(k) = 0.0 - else - lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - endif - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r - endif - qs1d(k) = qs1d(k) + qsten(k)*DT - if (qs1d(k) .le. R1) qs1d(k) = 0.0 - qg1d(k) = qg1d(k) + qgten(k)*DT - if (qg1d(k) .le. R1) qg1d(k) = 0.0 - enddo - - end subroutine mp_thompson -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Creation of the lookup tables and support functions found below here. -!+---+-----------------------------------------------------------------+ -!..Rain collecting graupel (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qg - - implicit none - -!..Local variables - INTEGER:: i, j, k, m, n, n2 - INTEGER:: km, km_s, km_e - DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g - DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r - DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr - DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 - -!+---+ - - do n2 = 1, nbr -! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & - + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) - enddo - do n = 1, nbg - vg(n) = av_g*Dg(n)**bv_g - enddo - -!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for -!.. fortran indices. J. Michalakes, 2009Oct30. - -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) -#else - km_s = 0 - km_e = ntb_r*ntb_r1 - 1 -#endif - - do km = km_s, km_e - m = km / ntb_r1 + 1 - k = mod( km , ntb_r1 ) + 1 - - lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do j = 1, ntb_g - do i = 1, ntb_g1 - lam_exp = (N0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - N0_g = N0g_exp(i)/(cgg(2)*lam_exp) * lamg**cge(2) - do n = 1, nbg - N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbg - massg = am_g * Dg(n)**bm_g - - dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) - dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) - - t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massg * N_g(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massr * N_g(n)* N_r(n2) - y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg * N_g(n)* N_r(n2) - - t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massr * N_g(n)* N_r(n2) - y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr * N_g(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massg * N_g(n)* N_r(n2) - enddo - 97 continue - enddo - tcg_racg(i,j,k,m) = t1 - tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) - tcr_gacr(i,j,k,m) = t2 - tmg_gacr(i,j,k,m) = z2 - tnr_racg(i,j,k,m) = y1 - tnr_gacr(i,j,k,m) = y2 - enddo - enddo - enddo - -!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). - -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) -#endif - - end subroutine qr_acr_qg -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Rain collecting snow (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qs - - implicit none - -!..Local variables - INTEGER:: i, j, k, m, n, n2 - INTEGER:: km, km_s, km_e - DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r - DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s - DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 - DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2 - DOUBLE PRECISION:: dvs, dvr, masss, massr - DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 - DOUBLE PRECISION:: y1, y2, y3, y4 - -!+---+ - - do n2 = 1, nbr -! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & - + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) - D1(n2) = (vr(n2)/av_s)**(1./bv_s) - enddo - do n = 1, nbs - vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) - enddo - -!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for -!.. fortran indices. J. Michalakes, 2009Oct30. - -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) -#else - km_s = 0 - km_e = ntb_r*ntb_r1 - 1 -#endif - - do km = km_s, km_e - m = km / ntb_r1 + 1 - k = mod( km , ntb_r1 ) + 1 - - lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do j = 1, ntb_t - do i = 1, ntb_s - -!..From the bm_s moment, compute plus one moment. If we are not -!.. using bm_s=2, then we must transform to the pure 2nd moment -!.. (variable called "second") and then to the bm_s+1 moment. - - M2 = r_s(i)*oams *1.0d0 - if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s & - + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) & - + sa(6)*bm_s*bm_s + sa(7)*Tc(j)*Tc(j)*bm_s & - + sa(8)*Tc(j)*bm_s*bm_s + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*Tc(j) + sb(3)*bm_s & - + sb(4)*Tc(j)*bm_s + sb(5)*Tc(j)*Tc(j) & - + sb(6)*bm_s*bm_s + sb(7)*Tc(j)*Tc(j)*bm_s & - + sb(8)*Tc(j)*bm_s*bm_s + sb(9)*Tc(j)*Tc(j)*Tc(j) & - + sb(10)*bm_s*bm_s*bm_s - second = (M2/a_)**(1./b_) - else - second = M2 - endif - - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*cse(1) & - + sa(4)*Tc(j)*cse(1) + sa(5)*Tc(j)*Tc(j) & - + sa(6)*cse(1)*cse(1) + sa(7)*Tc(j)*Tc(j)*cse(1) & - + sa(8)*Tc(j)*cse(1)*cse(1) + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+sb(2)*Tc(j)+sb(3)*cse(1) + sb(4)*Tc(j)*cse(1) & - + sb(5)*Tc(j)*Tc(j) + sb(6)*cse(1)*cse(1) & - + sb(7)*Tc(j)*Tc(j)*cse(1) + sb(8)*Tc(j)*cse(1)*cse(1) & - + sb(9)*Tc(j)*Tc(j)*Tc(j)+sb(10)*cse(1)*cse(1)*cse(1) - M3 = a_ * second**b_ - - oM3 = 1./M3 - Mrat = M2*(M2*oM3)*(M2*oM3)*(M2*oM3) - M0 = (M2*oM3)**mu_s - slam1 = M2 * oM3 * Lam0 - slam2 = M2 * oM3 * Lam1 - - do n = 1, nbs - N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) & - + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - t3 = 0.0d0 - t4 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - z3 = 0.0d0 - z4 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - y3 = 0.0d0 - y4 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbs - masss = am_s * Ds(n)**bm_s - - dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n))) - dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2))) - - if (massr .gt. 1.5*masss) then - t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - y1 = y1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs * N_s(n)* N_r(n2) - else - t3 = t3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z3 = z3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - y3 = y3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs * N_s(n)* N_r(n2) - endif - - if (massr .gt. 1.5*masss) then - t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - y2 = y2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr * N_s(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - else - t4 = t4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - y4 = y4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr * N_s(n)* N_r(n2) - z4 = z4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - endif - - enddo - enddo - tcs_racs1(i,j,k,m) = t1 - tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) - tcs_racs2(i,j,k,m) = t3 - tmr_racs2(i,j,k,m) = z3 - tcr_sacr1(i,j,k,m) = t2 - tms_sacr1(i,j,k,m) = z2 - tcr_sacr2(i,j,k,m) = t4 - tms_sacr2(i,j,k,m) = z4 - tnr_racs1(i,j,k,m) = y1 - tnr_racs2(i,j,k,m) = y3 - tnr_sacr1(i,j,k,m) = y2 - tnr_sacr2(i,j,k,m) = y4 - enddo - enddo - enddo - -!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). - -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) -#endif - - - end subroutine qr_acr_qs -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a literal adaptation of Bigg (1954) probability of drops of -!..a particular volume freezing. Given this probability, simply freeze -!..the proportion of drops summing their masses. -!+---+-----------------------------------------------------------------+ - - subroutine freezeH2O - - implicit none - -!..Local variables - INTEGER:: i, j, k, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc - DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & - prob, vol, Texp, orho_w, & - lam_exp, lamr, N0_r, lamc, N0_c, y - -!+---+ - - orho_w = 1./rho_w - - do n2 = 1, nbr - massr(n2) = am_r*Dr(n2)**bm_r - enddo - do n = 1, nbc - massc(n) = am_r*Dc(n)**bm_r - enddo - -!..Freeze water (smallest drops become cloud ice, otherwise graupel). - do k = 1, 45 -! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) ) - 1.0D0 - do j = 1, ntb_r1 - do i = 1, ntb_r - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - sum1 = 0.0d0 - sum2 = 0.0d0 - sumn1 = 0.0d0 - sumn2 = 0.0d0 - do n2 = nbr, 1, -1 - N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) - vol = massr(n2)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - if (massr(n2) .lt. xm0g) then - sumn1 = sumn1 + prob*N_r(n2) - sum1 = sum1 + prob*N_r(n2)*massr(n2) - else - sumn2 = sumn2 + prob*N_r(n2) - sum2 = sum2 + prob*N_r(n2)*massr(n2) - endif - if ((sum1+sum2) .ge. r_r(i)) EXIT - enddo - tpi_qrfz(i,j,k) = sum1 - tni_qrfz(i,j,k) = sumn1 - tpg_qrfz(i,j,k) = sum2 - tnr_qrfz(i,j,k) = sumn2 - enddo - enddo - do j = 1, 2 !land and ocean - do i = 1, ntb_c -! lamc = 1.0D-6 * (Nt_c*am_r* ccg(2) * ocg1 / r_c(i))**obmr -! N0_c = 1.0D-18 * Nt_c*ocg1 * lamc**cce(1) - if(j==1) then - lamc = 1.0D-6 * (Nt_cl*am_r* ccg(2,1) * ocg1(1) / r_c(i))**obmr - N0_c = 1.0D-18 * Nt_cl*ocg1(1) * lamc**cce(1,1) - else - lamc = 1.0D-6 * (Nt_co*am_r* ccg(2,2) * ocg1(2) / r_c(i))**obmr - N0_c = 1.0D-18 * Nt_co*ocg1(2) * lamc**cce(1,2) - endif - sum1 = 0.0d0 - sumn2 = 0.0d0 - do n = nbc, 1, -1 - y = Dc(n)*1.0D6 - vol = massc(n)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) -! N_c(n) = N0_c* y**mu_c * EXP(-lamc*y)*dtc(n) - if(j==1) then - N_c(n) = N0_c* y**mu_cl * EXP(-lamc*y)*dtc(n) - else - N_c(n) = N0_c* y**mu_co * EXP(-lamc*y)*dtc(n) - endif - N_c(n) = 1.0D24 * N_c(n) - sumn2 = sumn2 + prob*N_c(n) - sum1 = sum1 + prob*N_c(n)*massc(n) - if (sum1 .ge. r_c(i)) EXIT - enddo -! tpi_qcfz(i,k) = sum1 -! tni_qcfz(i,k) = sumn2 - tpi_qcfz(i,k,j) = sum1 - tni_qcfz(i,k,j) = sumn2 - enddo - enddo - enddo - - end subroutine freezeH2O -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Cloud ice converting to snow since portion greater than min snow -!.. size. Given cloud ice content (kg/m**3), number concentration -!.. (#/m**3) and gamma shape parameter, mu_i, break the distrib into -!.. bins and figure out the mass/number of ice with sizes larger than -!.. D0s. Also, compute incomplete gamma function for the integration -!.. of ice depositional growth from diameter=0 to D0s. Amount of -!.. ice depositional growth is this portion of distrib while larger -!.. diameters contribute to snow growth (as in Harrington et al. 1995). -!+---+-----------------------------------------------------------------+ - - subroutine qi_aut_qs - - implicit none - -!..Local variables - INTEGER:: i, j, n2 - DOUBLE PRECISION, DIMENSION(nbi):: N_i - DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2 - REAL:: xlimit_intg - -!+---+ - - do j = 1, ntb_i1 - do i = 1, ntb_i - lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi - Di_mean = (bm_i + mu_i + 1.) / lami - N0_i = Nt_i(j)*oig1 * lami**cie(1) - t1 = 0.0d0 - t2 = 0.0d0 - if (SNGL(Di_mean) .gt. 5.*D0s) then - t1 = r_i(i) - t2 = Nt_i(j) - tpi_ide(i,j) = 0.0D0 - elseif (SNGL(Di_mean) .lt. D0i) then - t1 = 0.0D0 - t2 = 0.0D0 - tpi_ide(i,j) = 1.0D0 - else - xlimit_intg = lami*D0s - tpi_ide(i,j) = GAMMP(mu_i+2.0, xlimit_intg) * 1.0D0 - do n2 = 1, nbi - N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) - if (Di(n2).ge.D0s) then - t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i - t2 = t2 + N_i(n2) - endif - enddo - endif - tps_iaus(i,j) = t1 - tni_iaus(i,j) = t2 - enddo - enddo - - end subroutine qi_aut_qs -! -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for rain collecting cloud water using -!.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise -!.. uses polynomials to get close match of Pruppacher & Klett Fig 14-9. -!+---+-----------------------------------------------------------------+ - - subroutine table_Efrw - - implicit none - -!..Local variables - DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X - INTEGER:: i, j - - do j = 1, nbc - do i = 1, nbr - Ef_rw = 0.0 - p = Dc(j)/Dr(i) - if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then - t_Efrw(i,j) = 0.0 - elseif (p.gt.0.25) then - X = Dc(j)*1.D6 - if (Dr(i) .lt. 75.e-6) then - Ef_rw = 0.026794*X - 0.20604 - elseif (Dr(i) .lt. 125.e-6) then - Ef_rw = -0.00066842*X*X + 0.061542*X - 0.37089 - elseif (Dr(i) .lt. 175.e-6) then - Ef_rw = 4.091e-06*X*X*X*X - 0.00030908*X*X*X & - + 0.0066237*X*X - 0.0013687*X - 0.073022 - elseif (Dr(i) .lt. 250.e-6) then - Ef_rw = 9.6719e-5*X*X*X - 0.0068901*X*X + 0.17305*X & - - 0.65988 - elseif (Dr(i) .lt. 350.e-6) then - Ef_rw = 9.0488e-5*X*X*X - 0.006585*X*X + 0.16606*X & - - 0.56125 - else - Ef_rw = 0.00010721*X*X*X - 0.0072962*X*X + 0.1704*X & - - 0.46929 - endif - else - vtr = -0.1021 + 4.932E3*Dr(i) - 0.9551E6*Dr(i)*Dr(i) & - + 0.07934E9*Dr(i)*Dr(i)*Dr(i) & - - 0.002362E12*Dr(i)*Dr(i)*Dr(i)*Dr(i) - stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i)) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - endif - - t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95)) - - enddo - enddo - - end subroutine table_Efrw -! -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for snow collecting cloud water using -!.. method of Wang and Ji, 2000 except equate melted snow diameter to -!.. their "effective collision cross-section." -!+---+-----------------------------------------------------------------+ - - subroutine table_Efsw - - implicit none - -!..Local variables - DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0 - INTEGER:: i, j - - do j = 1, nbc - vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0) - do i = 1, nbs - vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc - Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr - p = Dc(j)/Ds_m - if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 & - .or. vts.lt.1.E-3) then - t_Efsw(i,j) = 0.0 - else - stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95)) - endif - - enddo - enddo - - end subroutine table_Efsw -! -!+---+-----------------------------------------------------------------+ -!..Integrate rain size distribution from zero to D-star to compute the -!.. number of drops smaller than D-star that evaporate in a single -!.. timestep. Drops larger than D-star dont evaporate entirely so do -!.. not affect number concentration. -!+---+-----------------------------------------------------------------+ - - subroutine table_dropEvap - - implicit none - -!..Local variables - DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam - REAL:: xlimit_intg - INTEGER:: i, j, k - - do k = 1, ntb_r - do j = 1, ntb_r1 - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 - lam = lam_exp * (crg(3)*org2*org1)**obmr - N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2) - Nt_r = N0 * crg(2) / lam**cre(2) - - do i = 1, nbr - xlimit_intg = lam*Dr(i) - tnr_rev(i,j,k) = GAMMP(mu_r+1.0, xlimit_intg) * Nt_r - enddo - - enddo - enddo - - end subroutine table_dropEvap - -! TO APPLY TABLE ABOVE -!..Rain lookup table indexes. -! Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & -! * 0.78*4.*diffu(k)*xsat*rvs/rho_w) -! idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r) & -! / DLOG(Dr(nbr)/D0r)) -! idx_d = MAX(1, MIN(idx_d, nbr)) -! -! nir = NINT(ALOG10(rr(k))) -! do nn = nir-1, nir+1 -! n = nn -! if ( (rr(k)/10.**nn).ge.1.0 .and. & -! (rr(k)/10.**nn).lt.10.0) goto 154 -! enddo -!154 continue -! idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) -! idx_r = MAX(1, MIN(idx_r, ntb_r)) -! -! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr -! lam_exp = lamr * (crg(3)*org2*org1)**bm_r -! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) -! nir = NINT(DLOG10(N0_exp)) -! do nn = nir-1, nir+1 -! n = nn -! if ( (N0_exp/10.**nn).ge.1.0 .and. & -! (N0_exp/10.**nn).lt.10.0) goto 155 -! enddo -!155 continue -! idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) -! idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) -! -! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M -! * odts)) -! -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - SUBROUTINE GCF(GAMMCF,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS -! --- CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS -! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY -! --- A MODIFIED LENTZ METHOD. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, PARAMETER:: FPMIN=1.E-30 - REAL, INTENT(IN):: A, X - REAL:: GAMMCF,GLN - INTEGER:: I - REAL:: AN,B,C,D,DEL,H - GLN=GAMMLN(A) - B=X+1.-A - C=1./FPMIN - D=1./B - H=D - DO 11 I=1,ITMAX - AN=-I*(I-A) - B=B+2. - D=AN*D+B - IF(ABS(D).LT.FPMIN)D=FPMIN - C=B+AN/C - IF(ABS(C).LT.FPMIN)C=FPMIN - D=1./D - DEL=D*C - H=H*DEL - IF(ABS(DEL-1.).LT.gEPS)GOTO 1 - 11 CONTINUE - PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF' - 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H - END SUBROUTINE GCF -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - SUBROUTINE GSER(GAMSER,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS -! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) -! --- AS GLN. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, INTENT(IN):: A, X - REAL:: GAMSER,GLN - INTEGER:: N - REAL:: AP,DEL,SUM - GLN=GAMMLN(A) - IF(X.LE.0.)THEN - IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' - 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)*gEPS)GOTO 1 - 11 CONTINUE - PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER' - 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) - END SUBROUTINE GSER -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) -! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. - IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & - COF = (/76.18009172947146D0, -86.50532032941677D0, & - 24.01409824083091D0, -1.231739572450155D0, & - .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J - - X=XX - Y=X - TMP=X+5.5D0 - TMP=(X+0.5D0)*LOG(TMP)-TMP - SER=1.000000000190015D0 - DO 11 J=1,6 - Y=Y+1.D0 - SER=SER+COF(J)/Y -11 CONTINUE - GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMP(A,X) -! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) -! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 -! --- USES GCF,GSER - IMPLICIT NONE - REAL, INTENT(IN):: A,X - REAL:: GAMMCF,GAMSER,GLN - GAMMP = 0. - IF((X.LT.0.) .OR. (A.LE.0.)) THEN - PRINT *, 'BAD ARGUMENTS IN GAMMP' - RETURN - ELSEIF(X.LT.A+1.)THEN - CALL GSER(GAMSER,A,X,GLN) - GAMMP=GAMSER - ELSE - CALL GCF(GAMMCF,A,X,GLN) - GAMMP=1.-GAMMCF - ENDIF - END FUNCTION GAMMP -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) - - IMPLICIT NONE - REAL, INTENT(IN):: y - - WGAMMA = EXP(GAMMLN(y)) - - END FUNCTION WGAMMA -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS -! A FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSLF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 - - X=MAX(-80.,T-273.16) - -! ESL=612.2*EXP(17.67*X/(T-29.65)) - ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSLF=.622*ESL/(P-ESL) - -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T -! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 -! / T - 9.44523 * ALOG(T) + 0.014025 * T)) - - END FUNCTION RSLF -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A -! FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSIF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 - - X=MAX(-80.,T-273.16) - ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSIF=.622*ESI/(P-ESI) - -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T) - - END FUNCTION RSIF -!+---+-----------------------------------------------------------------+ - -!+---+-----------------------------------------------------------------+ -!..Compute radar reflectivity assuming 10 cm wavelength radar and using -!.. Rayleigh approximation. Only complication is melted snow/graupel -!.. which we treat as water-coated ice spheres and use Uli Blahak's -!.. library of routines. The meltwater fraction is simply the amount -!.. of frozen species remaining from what initially existed at the -!.. melting level interface. -!+---+-----------------------------------------------------------------+ - - subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ -! REAL, DIMENSION(kts:kte), INTENT(INOUT):: vt_dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof - REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r - REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz - REAL:: oM3, M0, Mrat, slam1, slam2, xDs - REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts - REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg - REAL:: a_, b_, loga_, tc0 - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - DOUBLE PRECISION:: cback, x, eta, f_d - REAL:: xslw1, ygra1, zans1 - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - rhof(k) = SQRT(RHO_NOT/rho(k)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) - if (qr1d(k) .gt. R1) then - rr(k) = qr1d(k)*rho(k) - nr(k) = MAX(R2, nr1d(k)*rho(k)) - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - ilamr(k) = 1./lamr - N0_r(k) = nr(k)*org2*lamr**cre(2) - mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k) - L_qr(k) = .true. - else - rr(k) = R1 - nr(k) = R1 - mvd_r(k) = 50.E-6 - L_qr(k) = .false. - endif - if (qs1d(k) .gt. R2) then - rs(k) = qs1d(k)*rho(k) - L_qs(k) = .true. - else - rs(k) = R1 - L_qs(k) = .false. - endif - if (qg1d(k) .gt. R2) then - rg(k) = qg1d(k)*rho(k) - L_qg(k) = .true. - else - rg(k) = R1 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope, and useful moments for snow. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams - -!..All other moments based on reference, 2nd moment. If bm_s.ne.2, -!.. then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif - -!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ - -!..Calculate bm_s*2 (th) moment. Useful for reflectivity. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & - + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & - + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & - + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(3)*cse(3)*cse(3) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & - + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & - + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) - smoz(k) = a_ * smo2(k)**b_ - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for graupel. -!+---+-----------------------------------------------------------------+ - - N0_min = gonv_max - do k = kte, kts, -1 - if (temp(k).lt.270.65 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then - xslw1 = 4.01 + alog10(mvd_r(k)) - else - xslw1 = 0.01 - endif - ygra1 = 4.31 + alog10(max(5.E-5, rg(k))) - zans1 = 3.1 + (100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1)) - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*crg(4)*ilamr(k)**cre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (am_s/900.0)*(am_s/900.0)*smoz(k) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (am_g/900.0)*(am_g/900.0) & - * N0_g(k)*cgg(4)*ilamg(k)**cge(4) - enddo - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (.not. iiwarm .and. melti .and. k_0.ge.2) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.05d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - oM3 = 1./smoc(k) - M0 = (smob(k)*oM3) - Mrat = smob(k)*M0*M0*M0 - slam1 = M0 * Lam0 - slam2 = M0 * Lam1 - do n = 1, nrbins - x = am_s * xxDs(n)**bm_s - call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = Mrat*(Kap0*DEXP(-slam1*xxDs(n)) & - + Kap1*(M0*xxDs(n))**mu_s * DEXP(-slam2*xxDs(n))) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.05d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = am_g * xxDg(n)**bm_g - call rayleigh_soak_wetgraupel (x, DBLE(ocmg), DBLE(obmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**mu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - -!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). -! do k = kte, kts, -1 -! vt_dBZ(k) = 1.E-3 -! if (rs(k).gt.R2) then -! Mrat = smob(k) / smoc(k) -! ils1 = 1./(Mrat*Lam0 + fv_s) -! ils2 = 1./(Mrat*Lam1 + fv_s) -! t1_vts = Kap0*csg(5)*ils1**cse(5) -! t2_vts = Kap1*Mrat**mu_s*csg(11)*ils2**cse(11) -! ils1 = 1./(Mrat*Lam0) -! ils2 = 1./(Mrat*Lam1) -! t3_vts = Kap0*csg(6)*ils1**cse(6) -! t4_vts = Kap1*Mrat**mu_s*csg(12)*ils2**cse(12) -! vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) -! if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then -! vts_dbz_wt = vts_dbz_wt*1.5 -! elseif (temp(k).ge.275.15) then -! vts_dbz_wt = vts_dbz_wt*2.0 -! endif -! else -! vts_dbz_wt = 1.E-3 -! endif - -! if (rr(k).gt.R1) then -! lamr = 1./ilamr(k) -! vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) & -! / (crg(4)*lamr**(-cre(4))) -! else -! vtr_dbz_wt = 1.E-3 -! endif - -! if (rg(k).gt.R2) then -! lamg = 1./ilamg(k) -! vtg_dbz_wt = rhof(k)*av_g*cgg(5)*lamg**(-cge(5)) & -! / (cgg(4)*lamg**(-cge(4))) -! else -! vtg_dbz_wt = 1.E-3 -! endif - -! vt_dBZ(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) & -! + vtg_dbz_wt*ze_graupel(k)) & -! / (ze_rain(k)+ze_snow(k)+ze_graupel(k)) -! enddo - - end subroutine calc_refl10cm - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!ctrlL - -!+---+-----------------------------------------------------------------+ -!..Compute _radiation_ effective radii of cloud water, ice, and snow. -!.. These are entirely consistent with microphysics assumptions, not -!.. constant or otherwise ad hoc as is internal to most radiation -!.. schemes. Since only the smallest snowflakes should impact -!.. radiation, compute from first portion of complicated Field number -!.. distribution, not the second part, which is the larger sizes. -!+---+-----------------------------------------------------------------+ - - subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & - & islmski,re_qc1d, re_qi1d, re_qs1d, kts, kte) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte - INTEGER, INTENT(IN):: islmski - REAL, DIMENSION(kts:kte), INTENT(IN):: & - & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: re_qc1d, re_qi1d, re_qs1d -!..Local variables - INTEGER:: k - REAL, DIMENSION(kts:kte):: rho, rc, nc, ri, ni, rs - REAL:: smo2, smob, smoc - REAL:: tc0, loga_, a_, b_ - DOUBLE PRECISION:: lamc, lami - LOGICAL:: has_qc, has_qi, has_qs - INTEGER:: inu_c - real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & - & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) - - has_qc = .false. - has_qi = .false. - has_qs = .false. - -! print*,'cal_eff:',islmski,Nt_c, Nt_cl,Nt_co - - do k = kts, kte - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) - if(islmski == 1) then - nc(k) = Nt_cl - else - nc(k) = Nt_co - endif - if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. - ri(k) = MAX(R1, qi1d(k)*rho(k)) - ni(k) = MAX(R2, ni1d(k)*rho(k)) - if (ri(k).gt.R1 .and. ni(k).gt.R2) has_qi = .true. - rs(k) = MAX(R1, qs1d(k)*rho(k)) - if (rs(k).gt.R1) has_qs = .true. - enddo - - if (has_qc) then - do k = kts, kte - if (rc(k).le.R1 .or. nc(k).le.R2) CYCLE - if (nc(k).lt.100) then - inu_c = 15 - elseif (nc(k).gt.1.E10) then - inu_c = 2 - else - inu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) - endif - lamc = (nc(k)*am_r*g_ratio(inu_c)/rc(k))**obmr - re_qc1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+inu_c)/lamc), 50.E-6)) - enddo - endif - - if (has_qi) then - do k = kts, kte - if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - re_qi1d(k) = MAX(10.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) - enddo - endif - - if (has_qs) then - do k = kts, kte - if (rs(k).le.R1) CYCLE - tc0 = MIN(-0.1, t1d(k)-273.15) - smob = rs(k)*oams - -!..All other moments based on reference, 2nd moment. If bm_s.ne.2, -!.. then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2 = smob - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - & + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - & + sb(10)*bm_s*bm_s*bm_s - smo2 = (smob/a_)**(1./b_) - endif -!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - & + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc = a_ * smo2**b_ - re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) - enddo - endif - - end subroutine calc_effectRad - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -END MODULE module_mp_thompson -!+---+-----------------------------------------------------------------+ diff --git a/gfsphysics/physics/module_mp_wsm6_fv3.F90 b/gfsphysics/physics/module_mp_wsm6_fv3.F90 deleted file mode 100644 index ff3594699..000000000 --- a/gfsphysics/physics/module_mp_wsm6_fv3.F90 +++ /dev/null @@ -1,2632 +0,0 @@ -!#if ( RWORDSIZE == 4 ) -!# define VREC vsrec -!# define VSQRT vssqrt -!#else -!# define VREC vrec -!# define VSQRT vsqrt -!#endif - -MODULE module_mp_wsm6 - - USE module_mp_radar - use physcons, only : cpd => con_cp, g => con_g, rd => con_rd, & - rv => con_rv, xlv0 => con_hvap, & - xlf0 => con_hfus, & - t0c => con_t0c, & - psat => con_psat,cliq => con_cliq, & - cice => con_csol, ep1 => con_fvirt, & - ep2 => con_eps, cpv => con_cvap, & - qmin => con_epsq, & - den0 => rhoair, & - denr => rhowater, eps1 => con_fvirt -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain -! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency -!rsun REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xncrl = 3.e8 ! land cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xncro = 1.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow -! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow -! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur - REAL, SAVE :: & -!rsun qc0, qck1, pidnc, & ! rsun - qc0o, qc0l,qck1o,qck1l, pidnc, & ! rsun - bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc,pi, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wsm6(t, phii,qq, qc, qr, qi, qs, qg & - ,p, del & - ,delt & - ,rainncv & - ,sr & - ,islmsk & - ,re_cloud, re_ice, re_snow & ! for radiation - ,ims,ime,kms,kme & - ,its,ite,kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ims,ime, kms,kme , & - its,ite, kts,kte - REAL, DIMENSION( ims:ime , kms:kme+1), INTENT(IN ) :: phii - INTEGER, DIMENSION( ims:ime), INTENT(IN ) :: islmsk !rsun - REAL, DIMENSION( ims:ime , kms:kme), & - INTENT(INOUT) :: & - t, & - qq, & - qc, & - qi, & - qr, & - qs, & - qg - REAL, DIMENSION( ims:ime , kms:kme) :: den - REAL, DIMENSION( ims:ime , kms:kme), & - INTENT(IN ) :: & - p, & - del - REAL, INTENT(IN ) :: delt - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: & - rainncv, & - sr -! for radiation connecting - INTEGER :: & - has_reqc, & - has_reqi, & - has_reqs - REAL, DIMENSION(ims:ime, kms:kme), & - INTENT(INOUT):: & - re_cloud, & - re_ice, & - re_snow -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(ims:ime, kms:kme) :: & ! GT - refl_10cm -!+---+-----------------------------------------------------------------+ - - REAL, DIMENSION( ims:ime ):: snow, & - snowncv - REAL, DIMENSION( ims:ime ) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs - REAL, DIMENSION( ims:ime , kms:kme) :: q - INTEGER :: i,j,k - -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(kts:kte):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ -!+---+-----------------------------------------------------------------+ -! to calculate effective radius for radiation - REAL, DIMENSION( kts:kte ) :: den1d - REAL, DIMENSION( kts:kte ) :: qc1d - REAL, DIMENSION( kts:kte ) :: qi1d - REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs - real :: tmp - integer :: islmski - - DO k=kts,kte - DO i=its,ite - qci(i,k,1) = qc(i,k) - qci(i,k,2) = qi(i,k) - qrs(i,k,1) = qr(i,k) - qrs(i,k,2) = qs(i,k) - qrs(i,k,3) = qg(i,k) - q(i,k) = qq(i,k) / (1.-qq(i,k)) - tmp = MAX(1.E-10, q(i,k)) - den(i,k) = p(i,k)/(Rd*t(i,k)*(1. + eps1*tmp)) - ENDDO - ENDDO - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - CALL wsm62D(t, q, qci, qrs & - ,den & - ,p, del, phii & - ,delt & - ,rainncv & - ,sr & - ,islmsk & - ,ims,ime, kms,kme & - ,its,ite, kts,kte & - ,snow=snow,snowncv=snowncv & - ,graupel=graupel,graupelncv=graupelncv & - ) - DO K=kts,kte - DO I=its,ite - qc(i,k) = qci(i,k,1) - qi(i,k) = qci(i,k,2) - qr(i,k) = qrs(i,k,1) - qs(i,k) = qrs(i,k,2) - qg(i,k) = qrs(i,k,3) - qq(i,k) = q(i,k) / (1.+q(i,k)) - ENDDO - ENDDO - -!+---+-----------------------------------------------------------------+ - has_reqc = 1 - has_reqi = 1 - has_reqs = 1 - - if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then - do i=its,ite - do k=kts,kte - re_qc(k) = 2.51E-6 - re_qi(k) = 10.01E-6 - re_qs(k) = 25.E-6 - - t1d(k) = t(i,k) - den1d(k)= den(i,k) - qc1d(k) = qc(i,k) - qi1d(k) = qi(i,k) - qs1d(k) = qs(i,k) - enddo - islmski = islmsk(i) - call effectRad_wsm6(t1d, qc1d, qi1d, qs1d, den1d, & - qmin, t0c, re_qc, re_qi, re_qs, & - islmski, & !rsun - kts, kte, i) - do k=kts,kte - re_cloud(i,k) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) - re_ice(i,k) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) - re_snow(i,k) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) - enddo - enddo - endif ! has_reqc, etc... -!+---+-----------------------------------------------------------------+ - END SUBROUTINE wsm6 -!=================================================================== -! - SUBROUTINE wsm62D(t, q & - ,qci, qrs, den, p, del,phii & - ,delt & - ,rainncv & - ,sr & - ,islmsk & !rsun - ,ims,ime, kms,kme & - ,its,ite, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! further modifications : -! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 -! ==> higher accuracy and efficient at lower resolutions -! reflectivity computation from greg thompson, lim, jun 2011 -! ==> only diagnostic, but with removal of too large drops -! add hail option from afwa, aug 2014 -! ==> switch graupel or hail by changing no, den, fall vel. -! effective radius of hydrometeors, bae from kiaps, jan 2015 -! ==> consistency in solar insolation of rrtmg radiation -! bug fix in melting terms, bae from kiaps, nov 2015 -! ==> density of air is divided, which has not been -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! Juang and Hong (JH, 2010) Mon. Wea. Rev. -! - INTEGER, INTENT(IN ) :: ims,ime, kms,kme , & - its,ite, kts,kte - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - del - - INTEGER, DIMENSION( ims:ime), & - INTENT(IN ) :: islmsk - - REAL, DIMENSION( ims:ime , kms:kme+1 ), & - INTENT(IN ) :: & - phii - - REAL, DIMENSION( ims:ime , kms:kme ) :: delz - REAL, INTENT(IN ) :: delt -! REAL, INTENT(IN ) :: delt, & -! g, & -! cpd, & -! cpv, & -! t0c, & -! den0, & -! rd, & -! rv, & -! ep1, & -! ep2, & -! qmin, & -! XLS, & -! XLV0, & -! XLF0, & -! cliq, & -! cice, & -! psat, & -! denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: & - rainncv, & - sr - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - qrs_tmp, & - falk, & - fall, & - work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - fallc, & - falkc, & - work1c, & - work2c, & - workr, & - worka - REAL, DIMENSION( its:ite , kts:kte ) :: & - den_tmp, & - delz_tmp - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - REAL, DIMENSION( its:ite , kts:kte ) :: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - denqrs1, & - denqrs2, & - denqrs3, & - denqci, & - n0sfac - REAL, DIMENSION( its:ite ) :: delqrs1, & - delqrs2, & - delqrs3, & - delqi - REAL, DIMENSION( its:ite ) :: tstepsnow, & - tstepgraup - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: & - cpmcal, xlcal, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n, idim, kdim -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp - REAL :: xls - REAL :: xncr,qck1,qc0 ! rsun -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! Optimizatin : A**B => exp(log(A)*(B)) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - idim = ite-its+1 - kdim = kte-kts+1 -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo - do k = kts, kte - do i = its, ite - delz(i,k) = (phii(i,k+1) - phii(i,k)) / g - delz_tmp(i,k) = delz(i,k) - den_tmp(i,k) = den(i,k) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the surface rain, snow, graupel -! - do i = its, ite - rainncv(i) = 0. - if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i) = 0. - if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i) = 0. - sr(i) = 0. -! new local array to catch step snow and graupel - tstepsnow(i) = 0. - tstepgraup(i) = 0. - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo -! do k = kts, kte -! CALL VREC( tvec1(its), den(its,k), ite-its+1) -! do i = its, ite -! tvec1(i) = tvec1(i)*den0 -! enddo -! CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) -! enddo - do k = kts, kte - do i = its, ite - tvec1(i) = den0 / den(i,k) - denfac(i,k) = sqrt(tvec1(i)) - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - xls = xlv0 + xlf0 - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - do k = kts, kte - do i = its, ite - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!---------------------------------------------------------------- - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - workr(i,k) = work1(i,k,1) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - ELSE - worka(i,k) = 0. - ENDIF - denqrs1(i,k) = den(i,k)*qrs(i,k,1) - denqrs2(i,k) = den(i,k)*qrs(i,k,2) - denqrs3(i,k) = den(i,k)*qrs(i,k,3) - if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & - delqrs1,dtcld,1,1) - call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & - denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) - do k = kts, kte - do i = its, ite - qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) - qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) - qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) - fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) - fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) - fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) - enddo - enddo - do i = its, ite - fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld - fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld - fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld - enddo - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/den(i,k) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/den(i,k) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work1c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - endif - enddo - enddo -! -! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) -! - do k = kte, kts, -1 - do i = its, ite - denqci(i,k) = den(i,k)*qci(i,k,2) - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & - delqi,dtcld,1,0) - do k = kts, kte - do i = its, ite - qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) - enddo - enddo - do i = its, ite - fallc(i,1) = delqi(i)/delz(i,1)/dtcld - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld + rainncv(i) - endif - if(fallsum_qsi.gt.0.) then - tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld & - +tstepsnow(i) - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld & - +snowncv(i) - snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) - ENDIF - endif - if(fallsum_qg.gt.0.) then - tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - +tstepgraup(i) - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - - graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + graupelncv(i) - graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) - ENDIF - endif - IF ( PRESENT (snowncv)) THEN - if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(rainncv(i)+1.e-12) - ELSE - if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) - ENDIF - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then - if(islmsk(i) == 1) then - xncr = xncrl - else - xncr = xncro - endif -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! *rslope(i,k,1)*dtcld,qrs(i,k,1)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! update the slope parameters for microphysics computation -! - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -!------------------------------------------------------------------ -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(islmsk(i) == 1 ) then - qc0 = qc0l - qck1 = qck1l - else - qc0 = qc0o - qck1 = qck1o - endif - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*qci(i,k,1)**(7./3.) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - +diameter**2*rslope(i,k,1) - praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - *rslopeb(i,k,1)/24./den(i,k) - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - +diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qsum(i,k) .gt. 1.e-15) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - /xlf,-qrs(i,k,3)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - *rslope2(i,k,2)+precs2*work2(i,k) & - *coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - +pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - *delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - +psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - - END SUBROUTINE wsm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm6init() -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL :: cl - INTEGER :: hail_opt ! RAS - -! RAS13.1 define graupel parameters as graupel-like or hail-like, -! depending on namelist option - - hail_opt = 0 - IF (hail_opt .eq. 1) THEN !Hail! - n0g = 4.e4 - deng = 700. - avtg = 285.0 - bvtg = 0.8 - lamdagmax = 2.e4 - ELSE !Graupel! - n0g = 4.e6 - deng = 500 - avtg = 330.0 - bvtg = 0.8 - lamdagmax = 6.e4 - ENDIF -! - cl = cliq - pi = 4.*atan(1.) - xlv1 = cl-cpv - -! -!rsun qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qc0o = 4./3.*pi*denr*r0**3*xncro/den0 ! 0.419e-3 -- .61e-3 - qc0l = 4./3.*pi*denr*r0**3*xncrl/den0 ! 0.419e-3 -- .61e-3 -!rsun qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - qck1o = .104*9.8*peaut/(xncro*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - qck1l = .104*9.8*peaut/(xncrl*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. ! syb -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g - -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax - -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - xam_r = PI*denr/6. - xbm_r = 3. - xmu_r = 0. - xam_s = PI*dens/6. - xbm_s = 3. - xmu_s = 0. - xam_g = PI*deng/6. - xbm_g = 3. - xmu_g = 0. - -!+---+-----------------------------------------------------------------+ - -! - END SUBROUTINE wsm6init -!------------------------------------------------------------------------------ - subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte,3) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt - REAL, DIMENSION( its:ite , kts:kte) :: & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, lamdas, lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) - vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) - vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) - if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 - if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 - if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 - enddo - enddo - END subroutine slope_wsm6 -!----------------------------------------------------------------------------- - subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtr - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_rain -!------------------------------------------------------------------------------ - subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdas, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = rslope(i,k)**bvts - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_snow -!---------------------------------------------------------------------------------- - subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopegmax - rslopeb(i,k) = rslopegbmax - rslope2(i,k) = rslopeg2max - rslope3(i,k) = rslopeg3max - else - rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtg - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_graup -!--------------------------------------------------------------------------------- -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),precip(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - enddo - qa(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - rql(i,:) = qn(:) -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter,ist - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 - precip1(:) = 0.0 - precip2(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - qq2(:) = rql2(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) + qq2(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qa2(k) = qq2(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - qr2(k) = qa2(k)/den(k) - enddo - qa(km+1) = 0.0 - qa2(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) - do k = 1, km - tmp(k) = max((qr(k)+qr2(k)), 1.E-15) - IF ( tmp(k) .gt. 1.e-15 ) THEN - wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) - ELSE - wa(k) = 0. - ENDIF - enddo - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & -! ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif - ist_loop : do ist = 1, 2 - if (ist.eq.2) then - qa(:) = qa2(:) - endif -! - precip(i) = 0. -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - if(ist.eq.1) then - rql(i,:) = qn(:) - precip1(i) = precip(i) - else - rql2(i,:) = qn(:) - precip2(i) = precip(i) - endif - enddo ist_loop -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm6 - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii, jj) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg - REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti - - DOUBLE PRECISION:: cback, x, eta, f_d - REAL, PARAMETER:: R=287. - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = min(n0smax, n0s*exp(-alpha*temp_C)) - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo - - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_wsm6 -!+---+-----------------------------------------------------------------+ - -!----------------------------------------------------------------------- - subroutine effectRad_wsm6 (t, qc, qi, qs, rho, qmin, t0c, & - re_qc, re_qi, re_qs, islmski, kts, kte, ii) - -!----------------------------------------------------------------------- -! Compute radiation effective radii of cloud water, ice, and snow for -! single-moment microphysics. -! These are entirely consistent with microphysics assumptions, not -! constant or otherwise ad hoc as is internal to most radiation -! schemes. -! Coded and implemented by Soo ya Bae, KIAPS, January 2015. -!----------------------------------------------------------------------- - - implicit none - -!..Sub arguments - integer, intent(in) :: kts, kte, ii - real, intent(in) :: qmin - real, intent(in) :: t0c - integer, intent(in) :: islmski - real, dimension( kts:kte ), intent(in):: t - real, dimension( kts:kte ), intent(in):: qc - real, dimension( kts:kte ), intent(in):: qi - real, dimension( kts:kte ), intent(in):: qs - real, dimension( kts:kte ), intent(in):: rho - real, dimension( kts:kte ), intent(inout):: re_qc - real, dimension( kts:kte ), intent(inout):: re_qi - real, dimension( kts:kte ), intent(inout):: re_qs -!..Local variables - integer:: i,k - integer :: inu_c - real, dimension( kts:kte ):: ni - real, dimension( kts:kte ):: rqc - real, dimension( kts:kte ):: rqi - real, dimension( kts:kte ):: rni - real, dimension( kts:kte ):: rqs - real :: temp - real :: lamdac - real :: supcol, n0sfac, lamdas - real :: diai ! diameter of ice in m - logical :: has_qc, has_qi, has_qs -!..Minimum microphys values - real, parameter :: R1 = 1.E-12 - real, parameter :: R2 = 1.E-6 -!..Mass power law relations: mass = am*D**bm - real, parameter :: bm_r = 3.0 - real, parameter :: obmr = 1.0/bm_r -! real, parameter :: nc0 = 3.E8 - real :: nc0 - real, parameter :: nc0l = 3.E8 - real, parameter :: nc0o = 1.E8 -!----------------------------------------------------------------------- - has_qc = .false. - has_qi = .false. - has_qs = .false. - - do k = kts, kte - ! for cloud - rqc(k) = max(R1, qc(k)*rho(k)) - if (rqc(k).gt.R1) has_qc = .true. - ! for ice - rqi(k) = max(R1, qi(k)*rho(k)) - temp = (rho(k)*max(qi(k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - ni(k) = min(max(5.38e7*temp,1.e3),1.e6) - rni(k)= max(R2, ni(k)*rho(k)) - if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. - ! for snow - rqs(k) = max(R1, qs(k)*rho(k)) - if (rqs(k).gt.R1) has_qs = .true. - enddo - - if(islmski == 1) then - nc0 = nc0l - else - nc0 = nc0o - endif - - if (has_qc) then - do k=kts,kte - if (rqc(k).le.R1) CYCLE - lamdac = (pidnc*nc0/rqc(k))**obmr - re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) - enddo - endif - - if (has_qi) then - do k=kts,kte - if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE - diai = 11.9*sqrt(rqi(k)/ni(k)) - re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) - enddo - endif - - if (has_qs) then - do k=kts,kte - if (rqs(k).le.R1) CYCLE - supcol = t0c-t(k) - n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) - lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) - re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) - enddo - endif - - end subroutine effectRad_wsm6 -!----------------------------------------------------------------------- - -END MODULE module_mp_wsm6 diff --git a/gfsphysics/physics/module_nst_model.f90 b/gfsphysics/physics/module_nst_model.f90 deleted file mode 100644 index 7154489f6..000000000 --- a/gfsphysics/physics/module_nst_model.f90 +++ /dev/null @@ -1,924 +0,0 @@ -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 .and. zcsq > 0.0 .and. alpha > 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/gfsphysics/physics/module_nst_parameters.f90 b/gfsphysics/physics/module_nst_parameters.f90 deleted file mode 100644 index 1186177e4..000000000 --- a/gfsphysics/physics/module_nst_parameters.f90 +++ /dev/null @@ -1,143 +0,0 @@ -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/gfsphysics/physics/module_nst_water_prop.f90 b/gfsphysics/physics/module_nst_water_prop.f90 deleted file mode 100644 index ffc7f4896..000000000 --- a/gfsphysics/physics/module_nst_water_prop.f90 +++ /dev/null @@ -1,700 +0,0 @@ -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,wet,z1,z2,nx,ny,dtm) -!subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,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 ! -! wet - logical, flag for wet point (ocean or lake) 1 ! -! icy - logical, flag for ice point (ocean or lake) 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 - logical, dimension(nx,ny), intent(in) :: wet -! logical, dimension(nx,ny), intent(in) :: wet,icy - 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) :: dt_warm, dtw, dtc, xzi - real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 - - -!$omp parallel do private(j,i,dtw,dtc,xzi) - do j = 1, ny - do i= 1, nx - - dtm(i,j) = zero ! initialize dtm - - if ( wet(i,j) ) then -! -! get the mean warming in the range of z=z1 to z=z2 -! - dtw = zero - if ( xt(i,j) > zero ) then - xzi = one / xz(i,j) - dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) - if (z1 < z2) then - if ( z2 < xz(i,j) ) then - dtw = dt_warm * (one-half*(z1+z2)*xzi) - elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then - dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) - endif - elseif (z1 == z2 ) then - if (z1 < xz(i,j) ) then - dtw = dt_warm * (one-z1*xzi) - endif - endif - endif -! -! get the mean cooling in the range of z=0 to z=zsea -! - dtc = zero - if ( zc(i,j) > zero ) then - if ( z1 < z2) then - if ( z2 < zc(i,j) ) then - dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) - elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then - dtc = half*(one-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 = dt_cool(i,j) * (one-z1/zc(i,j)) - endif - endif - endif -! get the mean T departure from Tf in the range of z=z1 to z=z2 - dtm(i,j) = dtw - dtc - endif ! if ( wet(i,j)) then - enddo - enddo - - end subroutine get_dtzm_2d - -end module module_nst_water_prop diff --git a/gfsphysics/physics/module_sf_noahmp_glacier.f90 b/gfsphysics/physics/module_sf_noahmp_glacier.f90 deleted file mode 100644 index a26e108e4..000000000 --- a/gfsphysics/physics/module_sf_noahmp_glacier.f90 +++ /dev/null @@ -1,2988 +0,0 @@ -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 - 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/gfsphysics/physics/module_sf_noahmplsm.f90 b/gfsphysics/physics/module_sf_noahmplsm.f90 deleted file mode 100644 index 83724aa5f..000000000 --- a/gfsphysics/physics/module_sf_noahmplsm.f90 +++ /dev/null @@ -1,8200 +0,0 @@ -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 / smc -! 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/gfsphysics/physics/module_wrf_utl.f90 b/gfsphysics/physics/module_wrf_utl.f90 deleted file mode 100644 index 29f8bb9e1..000000000 --- a/gfsphysics/physics/module_wrf_utl.f90 +++ /dev/null @@ -1,50 +0,0 @@ -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/gfsphysics/physics/moninedmf.f b/gfsphysics/physics/moninedmf.f deleted file mode 100644 index f264a873e..000000000 --- a/gfsphysics/physics/moninedmf.f +++ /dev/null @@ -1,1306 +0,0 @@ -!> \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 HEDMF 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) - 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 - thermal(i) = thvx(i,1) - crb(i) = crbcon - 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 -!> 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/gfsphysics/physics/moninedmf_hafs.f b/gfsphysics/physics/moninedmf_hafs.f deleted file mode 100644 index a035ad3d6..000000000 --- a/gfsphysics/physics/moninedmf_hafs.f +++ /dev/null @@ -1,1571 +0,0 @@ -!> \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 HEDMF 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 . -!! -!! WeiGuo Wang updated the scheme for HAFS in July, 2019. -!! -!! \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_hafs(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,islimsk) -! - 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) - integer islimsk(1: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 - -!! for aplha - real(kind=kind_phys) WSPM(IM,KM-1) - integer kLOC ! RGF - real :: xDKU, ALPHA ! RGF - - integer :: useshape - real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax - - -!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) - -! HAFS PBL: height-dependent ALPHA - useshape=2 !0-- no change, origincal ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) - alpha=moninq_fac - - ! write(0,*)'in PBL,alpha=',alpha - - ! write(0,*)'islimsk=',(islimsk(i),i=1,im) - -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) - 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 ( ALPHA .GT. 0.0) THEN ! ALPHA - - 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 = 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 - - ELSE -! use variable Ri for all conditions - if(pblflg(i)) then - thermal(i) = thvx(i,1) - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - endif - 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) = crbcon - IF(islimsk(i).ne.0) crb(I) = 0.16*(tem1)**(-0.18) - IF(islimsk(i).eq.0) crb(I) = 0.25*(tem1)**(-0.18) - crb(i) = max(min(crb(i), crbmax), crbmin) - ENDIF ! ALPHA - - 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 - -!!! HAFS PBL, Bgin adjustment -! RGF determine wspd at roughly 500 m above surface, or as close as possible, -! reuse SPDK2 -! zi(i,k) is AGL, right? May not matter if applied only to water grid points - if(moninq_fac.lt.0)then - - DO I=1,IM - SPDK2 = 0. - WSPM(i,1) = 0. - DO K = 1, KMPBL ! kmpbl is like a max possible pbl height - if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m - SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m - WSPM(i,1) = SPDK2/0.6 ! now the Km limit for 500 m. just store in K=1 - WSPM(i,2) = float(k) ! height of level at gridpoint i. store in K=2 -! if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 ',wspm(i,1),' -! KMPBL ',kmpbl,' KPBL ',kpbl(i) - endif - ENDDO - ENDDO ! i - - endif ! moninq_fac < 0 - - -! -! 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. - - IF (ALPHA > 0) THEN ! AAAAAAAAAAAAAAAAAAAAAAAAAAA - - 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 - - ELSE ! ALPHA <0 AAAAAAAAAAAAA - - do i=1,im - do k = 1, kmpbl - 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 - tem = zi(i,k+1) * (zfac**pfac) * abs( moninq_fac) - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac -! smax=0.148 !! max value of this shape function - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape - endif - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif - endif - endif ! endif useshape>1 -!!!! END OF CHAGES , WANG W - - - 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 !K loop - -! possible modification of first guess DKU, under certain conditions -! (1) this applies only to columns over water - - IF(islimsk(i).eq.0)then ! sea only - -! (2) alpha test -! if alpha < 0, find alpha for each column and do the loop again -! if alpha > 0, we are finished - - - if(alpha.lt.0)then ! variable alpha test - -! k-level of layer around 500 m - kLOC = INT(WSPM(i,2)) -! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) - -! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as -! if alpha = +1 - - if(KPBL(I).gt.kLOC)then - - xDKU = DKU(i,kLOC) ! Km at k-level -! (4) DKU check. -! WSPM(i,1) is the KM cap for the 500-m level. -! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = -! abs(alpha). No need to recalc. -! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire -! column - if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done - - WSPM(i,3) = WSPM(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) - !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed - WSPM(i,4) = min(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed - !! recalculate K capped by WSPM(i,1) - do k = 1, kmpbl - 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) - tem = zi(i,k+1) * (zfac**pfac) * WSPM(i,4) - - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(WSPM(i,4),0.2) !! adjustment coef should not smaller than 0.2 - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape -! if(k ==5) write(0,*)'min alf, height-depend alf',WSPM(i,4),ashape - endif ! endif useshape=1 - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment -! if(k ==5) write(0,*)'before, dku,ashape,ashpe1', -! & tem*wscaleu(i)*vk,ashape,ashape1 - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif -! if(k ==5)write(0,*) -! & 'after,dku,k_sfc,skmax,sksfc,zi(2),hpbl' -! & ,tem*wscaleu(i)*vk,WSCALEU(I)*VK*HPBL(i)*sksfc, skmax, -! & sksfc,ZI(I,2),HPBL(I) - - endif ! endif useshape=2 - endif ! endif useshape>1 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - 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 !K loop - endif ! xDKU.ge.WSPM(i,1) - endif ! KPBL(I).ge.kLOC - endif ! alpha < 0 - endif ! islimsk=0 - - enddo !I loop - ENDIF !AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA - -! -! 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) - !! if K needs to be adjusted by alpha, then no need to add this term - if(alpha .ge. 0.0) dkt(i,k) = dkt(i,k)+ckt(i,k) - if(alpha .ge. 0.0) 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 tridin99(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 - if (alpha .gt. 0.0) then - tau(i,1) = tau(i,1)+0.5*ttend - else - tau(i,1) = tau(i,1)+0.7*ttend ! in HWRF/HMON, use 0.7 - endif - 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 - if (alpha .gt. 0.0) then - tau(i,k) = tau(i,k) + 0.5*ttend - else - tau(i,k) = tau(i,k) + 0.7*ttend ! in HWRF/HMON, use 0.7 - endif - 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 tridi299(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 tridi299(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 tridin99(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/gfsphysics/physics/moninp.f b/gfsphysics/physics/moninp.f deleted file mode 100644 index 550d75c47..000000000 --- a/gfsphysics/physics/moninp.f +++ /dev/null @@ -1,547 +0,0 @@ -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/gfsphysics/physics/moninp1.f b/gfsphysics/physics/moninp1.f deleted file mode 100644 index f03f87d22..000000000 --- a/gfsphysics/physics/moninp1.f +++ /dev/null @@ -1,556 +0,0 @@ -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/gfsphysics/physics/moninq.f b/gfsphysics/physics/moninq.f deleted file mode 100644 index a3c73257d..000000000 --- a/gfsphysics/physics/moninq.f +++ /dev/null @@ -1,942 +0,0 @@ -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 -!GFDL spdk2 = max(((u1(i,k)-u1(i,1))**2 -!GFDL & +(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/gfsphysics/physics/moninq1.f b/gfsphysics/physics/moninq1.f deleted file mode 100644 index 0389f13b8..000000000 --- a/gfsphysics/physics/moninq1.f +++ /dev/null @@ -1,940 +0,0 @@ -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/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f deleted file mode 100644 index c0926631a..000000000 --- a/gfsphysics/physics/moninshoc.f +++ /dev/null @@ -1,557 +0,0 @@ -!!!!! ========================================================== !!!!! -! subroutine 'moninshoc' computes pbl height and applies vertical diffusion -! using the coefficient provided by the SHOC scheme (from previous step) -! 2015-05-04 - Shrinivas Moorthi - original version based on monin -! 2018-03-21 - Shrinivas Moorthi - fixed a bug related to tke vertical diffusion -! and gneralized the tke location in tracer array -! 2018-03-23 - Shrinivas Moorthi - used twice the momentum diffusion coefficient -! for tke as in Deardorff (1980) - added tridi1 -! - subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,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,xkzminv, - & 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, ncnd, ntke - integer, dimension(im) :: kinver, kpbl -! - real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s, xkzminv - 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,is,k,kk,km1,kmpbl,kp1, ntloc -! - 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 -! - real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad - &, dt2odel - real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au - &, dku, dkt, rdzt -! - 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 - &, ttend, utend, vtend, qtend - &, spdk2, rbint, ri, zol1, robn, bvf2 -! - real(kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 - &, gravi=one/grav, zolcr=0.2d0 - &, zolcru=-0.5d0, rimin=-100.0d0, sfcfrac=0.1d0 - &, crbcon=0.25d0, crbmin=0.15d0, crbmax=0.35d0 - &, qmin=1.0d-8, zfmin=1.0d-8, qlmin=1.0d-12 - &, aphi5=5.0d0, aphi16=16.0d0, f0=1.0d-4 - &, cont=cp/grav, conq=hvap/grav, conw=one/grav - &, dkmin=zero, dkmax=1000.0d0 -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, gocp=grav/cp, prmin=0.25d0, prmax=4.0d0 - &, vk=0.4d0, cfac=6.5d0 -! -!----------------------------------------------------------------------- -! -! compute preliminary variables -! - if (ix < im) stop -! -! if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) -! &, ' grav=',grav, rd, cp, hvap, fv,' ipr=',ipr -! &,' ntke=',ntke,' ntcw=',ntcw -! if (lprnt) write(0,*)' in moninshoc tin=',t1(ipr,:) -! if (lprnt) write(0,*)' in moninshoc qin=',q1(ipr,:,1) -! if (lprnt) write(0,*)' in moninshoc qwin=',q1(ipr,:,2) -! if (lprnt) write(0,*)' in moninshoc qiin=',q1(ipr,:,3) - - 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 - dt2odel(i,k) = dt2 / del(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) = one / (zl(i,k+1) - zl(i,k)) - prnum(i,k) = one - enddo - enddo -! Setup backgrond diffision - do i=1,im - prnum(i,km) = one - tx1(i) = one / prsi(i,1) - enddo - do k = 1,km1 - do i=1,im - xkzo(i,k) = zero - xkzmo(i,k) = zero -! if (k < kinver(i)) then - if (k <= kinver(i)) then -! vertical background diffusivity for heat and momentum - tem1 = one - prsi(i,k+1) * tx1(i) - tem1 = min(one, exp(-tem1 * tem1 * 10.0d0)) - xkzo(i,k) = xkzm_h * tem1 - xkzmo(i,k) = xkzm_m * tem1 - endif - enddo - enddo -! if (lprnt) then -! write(0,*)' tx1=',tx1(ipr),' kinver=',kinver(ipr) -! write(0,*)' xkzo=',xkzo(ipr,:) -! write(0,*)' xkzmo=',xkzmo(ipr,:) -! 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.0d0) then - tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.0d-5) then - xkzo(i,k) = min(xkzo(i,k),xkzminv) - endif - endif - enddo - enddo -! -! - do i = 1,im - z0(i) = 0.01d0 * zorl(i) - kpbl(i) = 1 - hpbl(i) = zi(i,1) - pblflg(i) = .true. - sfcflg(i) = .true. - if(rbsoil(i) > zero) sfcflg(i) = .false. - dusfc(i) = zero - dvsfc(i) = zero - dtsfc(i) = zero - dqsfc(i) = zero - enddo -! - do k = 1,km - do i=1,im - tx1(i) = zero - enddo - do kk=1,ncnd - do i=1,im - tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin) - enddo - enddo - do i = 1,im - 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)-tx1(i)) - enddo - enddo -! -! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) - do i = 1,im - sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= zero) 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)*(one+fv*max(q1(i,1,1),qmin)) - tem = max(one, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) - robn = tem / (f0 * z0(i)) - tem1 = 1.0d-7 * robn - crb(i) = max(min(0.16d0 * (tem1**(-0.18d0)), 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 = zero - elseif(rbup(i) <= crb(i)) then - rbint = one - 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)**(-one/4.0d0) -! phih(i) = (1.-aphi16*zol1)**(-one/2.0d0) - tem = one / max(one - aphi16*zol1, 1.0d-8) - phih(i) = sqrt(tem) - phim(i) = sqrt(phih(i)) - else - phim(i) = one + 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)), one) - 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 = zero - elseif(rbup(i) <= crb(i)) then - rbint = one - 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 - kp1 = k + 1 - do i=1,im - if(k >= kpbl(i)) then - rdz = rdzt(i,k) - tem = u1(i,k) - u1(i,kp1) - tem1 = v1(i,k) - v1(i,kp1) - tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5d0*grav)*(thvx(i,kp1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,kp1)) - ri = max(bvf2/tem,rimin) - if(ri < zero) then ! unstable regime - prnum(i,kp1) = one - else - prnum(i,kp1) = min(one + 2.1d0*ri, prmax) - endif - elseif (k > 1) then - prnum(i,kp1) = prnum(i,1) - endif -! -! prnum(i,kp1) = 1.0 - prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) - tem = tkh(i,kp1) * prnum(i,kp1) - dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) - dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k)) - enddo - enddo -! if (lprnt) write(0,*)' tkh=',tkh(ipr,:) -! if (lprnt) write(0,*)' dkt=',dkt(ipr,:) -! -! compute tridiagonal matrix elements for heat and moisture -! - do i=1,im - ad(i,1) = one - a1(i,1) = t1(i,1) + beta(i) * heat(i) - a2(i,1) = q1(i,1,1) + beta(i) * evap(i) - enddo -! if (lprnt) write(0,*)' a1=',a1(ipr,1),' beta=',beta(ipr) -! &,' heat=',heat(ipr), ' t1=',t1(ipr,1) - - ntloc = 1 - if(ntrac > 1) then - is = 0 - do k = 2, ntrac - if (k /= ntke) then - ntloc = ntloc + 1 - is = is + km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - endif - enddo - endif -! - do k = 1,km1 - kp1 = k + 1 - do i = 1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - 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,kp1) = one - al(i,k) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k) + dtodsd*dsdzt - a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt - a2(i,kp1) = q1(i,kp1,1) - enddo - enddo -! - if(ntrac > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + km - do k = 1, km1 - kp1 = k + 1 - do i = 1, im - a2(i,kp1+is) = q1(i,kp1,kk) - enddo - enddo - endif - enddo - endif -! -! solve tridiagonal problem for heat and moisture -! - call tridin(im,km,ntloc,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 > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + 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 - endif - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i=1,im - ad(i,1) = one + beta(i) * stress(i) / spd1(i) - a1(i,1) = u1(i,1) - a2(i,1) = v1(i,1) - enddo -! - do k = 1,km1 - kp1 = k + 1 - do i=1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - 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,kp1) = one - al(i,k) - a1(i,kp1) = u1(i,kp1) - a2(i,kp1) = v1(i,kp1) -! - enddo - enddo - - 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 -! - if (ntke > 0) then ! solve tridiagonal problem for momentum and tke -! -! compute tridiagonal matrix elements for tke -! - do i=1,im - ad(i,1) = one - a1(i,1) = q1(i,1,ntke) - enddo -! - do k = 1,km1 - kp1 = k + 1 - do i=1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - rdz = rdzt(i,k) - tem1 = 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,kp1) = one - al(i,k) - a1(i,kp1) = q1(i,kp1,ntke) - enddo - enddo - - call tridi1(im,km,al,ad,au,a1,au,a1) -! - do k = 1, km ! recover tendencies of tke - do i = 1, im - qtend = (a1(i,k)-q1(i,k,ntke))*rdt - rtg(i,k,ntke) = rtg(i,k,ntke) + qtend - enddo - enddo - endif -! -! if (lprnt) write(0,*)' in moninshoc tau=',tau(ipr,:)*86400 - - return - end - subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) -! - use machine , only : kind_phys - implicit none - real(kind=kind_phys), parameter :: one=1.0d0 -! - real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n), & - & au(l,n-1),a1(l,n) -! - real(kind=kind_phys) fk - integer k,n,l,i -! - do i=1,l - fk = one / cm(i,1) - au(i,1) = fk*cu(i,1) - a1(i,1) = fk*r1(i,1) - enddo - do k=2,n-1 - do i=1,l - fk = one / (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)) - enddo - enddo - do i=1,l - fk = one / (cm(i,n)-cl(i,n)*au(i,n-1)) - a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(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) - enddo - enddo -! - return - end diff --git a/gfsphysics/physics/moninshoc.f_1Km b/gfsphysics/physics/moninshoc.f_1Km deleted file mode 100644 index 2dc515e82..000000000 --- a/gfsphysics/physics/moninshoc.f_1Km +++ /dev/null @@ -1,492 +0,0 @@ -!!!!! ========================================================== !!!!! -! subroutine 'moninshoc' computes pbl height and applies vertical diffusion -! using the coefficient provided by the SHOC scheme (from previous step) -! 2015-05-04 - Shrinivas Moorthi - original version based on monin -! 2018-03-21 - Shrinivas Moorthi - fixed a bug related to tke vertical diffusion -! and gneralized the tke location in tracer array -! - subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,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, ncnd, 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,is,k,kk,km1,kmpbl,kp1, ntloc -! - 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 -! - real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad - &, dt2odel - real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au - &, dku, dkt, rdzt -! - 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 - &, 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. -! &, 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 - dt2odel(i,k) = dt2 / del(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)) - prnum(i,k) = 1.0 - enddo - enddo -! Setup backgrond diffision - do i=1,im - prnum(i,km) = 1.0 - tx1(i) = 1.0 / prsi(i,1) - 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 for heat and momentum - tem1 = 1.0 - prsi(i,k+1) * tx1(i) - tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) - xkzo(i,k) = xkzm_h * tem1 - xkzmo(i,k) = xkzm_m * tem1 - 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 - tx1(i) = 0.0 - enddo - do kk=1,ncnd - do i=1,im - tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin) - enddo - enddo - do i = 1,im - 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)-tx1(i)) - enddo - enddo -! -! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) - 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) = max(min(0.16 * (tem1 ** (-0.18)), 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 / max(1. - aphi16*zol1, 1.0e-8) - 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 - kp1 = k + 1 - do i=1,im - if(k >= kpbl(i)) then - rdz = rdzt(i,k) - tem = u1(i,k) - u1(i,kp1) - tem1 = v1(i,k) - v1(i,kp1) - tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,kp1)) - ri = max(bvf2/tem,rimin) - if(ri < 0.) then ! unstable regime - prnum(i,kp1) = 1.0 - else - prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) - endif - elseif (k > 1) then - prnum(i,kp1) = prnum(i,1) - endif -! -! prnum(i,kp1) = 1.0 - prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) - tem = tkh(i,kp1) * prnum(i,kp1) - dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) - dkt(i,k) = max(min(tkh(i,kp1)+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 (lprnt) write(0,*)' a1=',a1(ipr,1),' beta=',beta(ipr) -! &,' heat=',heat(ipr), ' t1=',t1(ipr,1) - - ntloc = 1 - if(ntrac > 1) then - is = 0 - do k = 2, ntrac - if (k /= ntke) then - ntloc = ntloc + 1 - is = is + km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - endif - enddo - endif -! - do k = 1,km1 - kp1 = k + 1 - do i = 1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - 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,kp1) = 1.-al(i,k) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k) + dtodsd*dsdzt - a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt - a2(i,kp1) = q1(i,kp1,1) -! - enddo - enddo -! - if(ntrac > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + km - do k = 1, km1 - kp1 = k + 1 - do i = 1, im - a2(i,kp1+is) = q1(i,kp1,kk) - enddo - enddo - endif - enddo - endif -! -! solve tridiagonal problem for heat and moisture -! - call tridin(im,km,ntloc,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 -! if(lprnt .and. i==ipr .and. k<11) write(0,*)' tau=',tau(ipr,k) -! &,' ttend=',ttend,' a1=',a1(ipr,k),' t1=',t1(ipr,k) - 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 > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + 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 - endif - 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 - kp1 = k + 1 - do i=1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - 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,kp1) = 1.0 - al(i,k) - a1(i,kp1) = u1(i,kp1) - a2(i,kp1) = v1(i,kp1) -! - enddo - enddo - if (ntke > 0) then ! solve tridiagonal problem for momentum and tke - do k = 1, km1 - kp1 = k + 1 - do i = 1, im - a2(i,kp1+km) = q1(i,kp1,ntke) - enddo - enddo - call tridin(im,km,2,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/gfsphysics/physics/mstadb.f b/gfsphysics/physics/mstadb.f deleted file mode 100644 index a3de3ea71..000000000 --- a/gfsphysics/physics/mstadb.f +++ /dev/null @@ -1,80 +0,0 @@ -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/gfsphysics/physics/mstadbtn.f b/gfsphysics/physics/mstadbtn.f deleted file mode 100644 index 4bf650e07..000000000 --- a/gfsphysics/physics/mstadbtn.f +++ /dev/null @@ -1,91 +0,0 @@ -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/gfsphysics/physics/mstadbtn2.f b/gfsphysics/physics/mstadbtn2.f deleted file mode 100644 index 4bf650e07..000000000 --- a/gfsphysics/physics/mstadbtn2.f +++ /dev/null @@ -1,91 +0,0 @@ -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/gfsphysics/physics/mstcnv.f b/gfsphysics/physics/mstcnv.f deleted file mode 100644 index c8469951d..000000000 --- a/gfsphysics/physics/mstcnv.f +++ /dev/null @@ -1,316 +0,0 @@ - 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/gfsphysics/physics/namelist_soilveg.f b/gfsphysics/physics/namelist_soilveg.f deleted file mode 100644 index cd4618af0..000000000 --- a/gfsphysics/physics/namelist_soilveg.f +++ /dev/null @@ -1,49 +0,0 @@ - module namelist_soilveg - implicit none - save - - INTEGER MAX_SLOPETYP - INTEGER MAX_SOILTYP - INTEGER MAX_VEGTYP - - PARAMETER(MAX_SLOPETYP = 30) - PARAMETER(MAX_SOILTYP = 30) - PARAMETER(MAX_VEGTYP = 30) - - REAL SLOPE_DATA(MAX_SLOPETYP) - REAL RSMTBL(MAX_VEGTYP) - REAL RGLTBL(MAX_VEGTYP) - REAL HSTBL(MAX_VEGTYP) - REAL SNUPX(MAX_VEGTYP) - REAL BB(MAX_SOILTYP) - REAL DRYSMC(MAX_SOILTYP) - REAL F11(MAX_SOILTYP) - REAL MAXSMC(MAX_SOILTYP) - REAL REFSMC(MAX_SOILTYP) - REAL SATPSI(MAX_SOILTYP) - REAL SATDK(MAX_SOILTYP) - REAL SATDW(MAX_SOILTYP) - REAL WLTSMC(MAX_SOILTYP) - REAL QTZ(MAX_SOILTYP) - LOGICAL LPARAM - REAL ZBOT_DATA - REAL SALP_DATA - REAL CFACTR_DATA - REAL CMCMAX_DATA - REAL SBETA_DATA - REAL RSMAX_DATA - REAL TOPT_DATA - REAL REFDK_DATA - REAL FRZK_DATA - INTEGER BARE - INTEGER DEFINED_VEG - INTEGER DEFINED_SOIL - INTEGER DEFINED_SLOPE - REAL FXEXP_DATA - INTEGER NROOT_DATA(MAX_VEGTYP) - REAL REFKDT_DATA - REAL Z0_DATA(MAX_VEGTYP) - REAL CZIL_DATA - REAL LAI_DATA(MAX_VEGTYP) - REAL CSOIL_DATA - end module namelist_soilveg diff --git a/gfsphysics/physics/num_parthds.F b/gfsphysics/physics/num_parthds.F deleted file mode 100644 index 922ae4a4f..000000000 --- a/gfsphysics/physics/num_parthds.F +++ /dev/null @@ -1,23 +0,0 @@ - function num_parthds() -#ifdef _OPENMP -#include -!$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/gfsphysics/physics/ozinterp.f90 b/gfsphysics/physics/ozinterp.f90 deleted file mode 100644 index f3e2d1c60..000000000 --- a/gfsphysics/physics/ozinterp.f90 +++ /dev/null @@ -1,193 +0,0 @@ - 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='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), 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 < oz_time(1)) RJDAY = RJDAY + 365. -! - n2 = timeoz + 1 - do j=2,timeoz - if (rjday < oz_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 -! -! if (me == 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/gfsphysics/physics/ozne_def.f b/gfsphysics/physics/ozne_def.f deleted file mode 100644 index c33ef0b62..000000000 --- a/gfsphysics/physics/ozne_def.f +++ /dev/null @@ -1,14 +0,0 @@ - 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/gfsphysics/physics/ozphys.f b/gfsphysics/physics/ozphys.f deleted file mode 100644 index ce7623960..000000000 --- a/gfsphysics/physics/ozphys.f +++ /dev/null @@ -1,159 +0,0 @@ -!> \file ozphys.f -!! This file is ozone sources and sinks. - -!> \defgroup GFS_ozn GFS 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 Communication -!! - Routine OZPHYS is called from GBPHYS after call to RAYLEIGH_DAMP -!! @{ - -!> -!! \section arg_table_ozphys_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 | -!! -!! \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/gfsphysics/physics/ozphys_2015.f b/gfsphysics/physics/ozphys_2015.f deleted file mode 100644 index 1d7cad57c..000000000 --- a/gfsphysics/physics/ozphys_2015.f +++ /dev/null @@ -1,108 +0,0 @@ - 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/gfsphysics/physics/physcons.F90 b/gfsphysics/physics/physcons.F90 deleted file mode 100644 index 67be2c336..000000000 --- a/gfsphysics/physics/physcons.F90 +++ /dev/null @@ -1,193 +0,0 @@ -!> \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 - real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) -!> square root of 2 - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys -!> square root of 3 - real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0_kind_phys - -!> \name Geophysics/Astronomy constants - -!> radius of earth (m) - real(kind=kind_phys),parameter:: con_rerth =6.3712e+6_kind_phys -!> gravity (\f$m/s^{2}\f$) - real(kind=kind_phys),parameter:: con_g =9.80665e+0_kind_phys -!> ang vel of earth (\f$s^{-1}\f$) - real(kind=kind_phys),parameter:: con_omega =7.2921e-5_kind_phys -!> std atms pressure (pa) - real(kind=kind_phys),parameter:: con_p0 =1.01325e5_kind_phys -! real(kind=kind_phys),parameter:: con_solr =1.36822e+3_kind_phys ! 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_kind_phys -!> solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) - real(kind=kind_phys),parameter:: con_solr =1.3608e+3_kind_phys -! real(kind=kind_phys),parameter:: con_solr =1.36742732e+3_kind_phys ! 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_kind_phys -!> gas constant air (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_rd =2.8705e+2_kind_phys -!> gas constant H2O (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_rv =4.6150e+2_kind_phys -!> spec heat air at p (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cp =1.0046e+3_kind_phys -!> spec heat air at v (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cv =7.1760e+2_kind_phys -!> spec heat H2O gas (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cvap =1.8460e+3_kind_phys -!> spec heat H2O liq (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3_kind_phys -!> spec heat H2O ice (\f$J/kg/K\f$) - real(kind=kind_phys),parameter:: con_csol =2.1060e+3_kind_phys -!> lat heat H2O cond (\f$J/kg\f$) - real(kind=kind_phys),parameter:: con_hvap =2.5000e+6_kind_phys -! real(kind=kind_phys),parameter:: con_hvap =2.5010e+6_kind_phys ! from AMS -!> lat heat H2O fusion (\f$J/kg\f$) - real(kind=kind_phys),parameter:: con_hfus =3.3358e+5_kind_phys -! real(kind=kind_phys),parameter:: con_hfus =3.3370e+5_kind_phys ! from AMS -!> pres at H2O 3pt (Pa) - real(kind=kind_phys),parameter:: con_psat =6.1078e+2_kind_phys -!> temp at 0C (K) - real(kind=kind_phys),parameter:: con_t0c =2.7315e+2_kind_phys -!> temp at H2O 3pt (K) - real(kind=kind_phys),parameter:: con_ttp =2.7316e+2_kind_phys -!> temp freezing sea (K) - real(kind=kind_phys),parameter:: con_tice =2.7120e+2_kind_phys -!> joules per calorie - real(kind=kind_phys),parameter:: con_jcal =4.1855E+0_kind_phys -!> sea water reference density (\f$kg/m^{3}\f$) - real(kind=kind_phys),parameter:: con_rhw0 =1022.0_kind_phys -!> min q for computing precip type - real(kind=kind_phys),parameter:: con_epsq =1.0E-12_kind_phys - -!> \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_kind_phys -!> planck constant (\f$J/s\f$) - real(kind=kind_phys),parameter:: con_plnk =6.6260693e-34_kind_phys -!> boltzmann constant (\f$J/K\f$) - real(kind=kind_phys),parameter:: con_boltz =1.3806505e-23_kind_phys -!> stefan-boltzmann (\f$W/m^{2}/K^{4}\f$) - real(kind=kind_phys),parameter:: con_sbc =5.670400e-8_kind_phys -!> avogadro constant (\f$mol^{-1}\f$) - real(kind=kind_phys),parameter:: con_avgd =6.0221415e23_kind_phys -!> vol of ideal gas at 273.15K, 101.325kPa (\f$m^{3}/mol\f$) - real(kind=kind_phys),parameter:: con_gasv =22413.996e-6_kind_phys -! real(kind=kind_phys),parameter:: con_amd =28.970_kind_phys ! 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_kind_phys -!> molecular wght of water vapor (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amw =18.0154_kind_phys -!> molecular wght of o3 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amo3 =47.9982_kind_phys -! real(kind=kind_phys),parameter:: con_amo3 =48.0_kind_phys ! molecular wght of o3 (g/mol) -!> molecular wght of co2 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amco2 =44.011_kind_phys -!> molecular wght of o2 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amo2 =31.9999_kind_phys -!> molecular wght of ch4 (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amch4 =16.043_kind_phys -!> molecular wght of n2o (\f$g/mol\f$) - real(kind=kind_phys),parameter:: con_amn2o =44.013_kind_phys -!> temperature the H.G.Nuc. ice starts - real(kind=kind_phys), parameter:: con_thgni =-38.15_kind_phys - -#ifdef CCPP -!> minimum ice concentration - real(kind=kind_phys),parameter:: cimin =0.15 -#endif -!> 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 -! integer, parameter :: max_lon=8000, max_lat=4000, 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:: rlapse = 0.65e-2_kind_phys - real(kind=kind_phys), parameter:: cb2mb = 10.0_kind_phys, pa2mb = 0.01_kind_phys -! for wsm6 - real(kind=kind_phys),parameter:: rhowater = 1000._kind_phys ! density of water (kg/m^3) - real(kind=kind_phys),parameter:: rhosnow = 100._kind_phys ! density of snow (kg/m^3) - real(kind=kind_phys),parameter:: rhoair = 1.28_kind_phys ! density of air near surface (kg/m^3) - -#ifndef CCPP - real(kind=kind_phys) :: dxmax, dxmin, dxinv, rhc_max -! For min/max hourly rh02m and t02m - real(kind=kind_phys),parameter :: PQ0 = 379.90516E0_kind_phys - real(kind=kind_phys),parameter :: A2A = 17.2693882_kind_phys - real(kind=kind_phys),parameter :: A3 = 273.16_kind_phys - real(kind=kind_phys),parameter :: A4 = 35.86_kind_phys - real(kind=kind_phys),parameter :: RHmin = 1.0E-6_kind_phys -#endif - -!........................................! - end module physcons ! -!========================================! -!! @} diff --git a/gfsphysics/physics/physparam.f b/gfsphysics/physics/physparam.f deleted file mode 100644 index f78191278..000000000 --- a/gfsphysics/physics/physparam.f +++ /dev/null @@ -1,307 +0,0 @@ -!> \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 -!!\n =2:cloud optical property scheme based on Hu and Stamnes(1993) -updated - 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*26 -! data solar_file / 'solarconstantdata.txt ' / - data solar_file / '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 =5: OPAC climatoloy with new band mapping -!!\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 - -!> external aerosols data file: aerosol.dat - character, save :: aeros_file*26 -! data aeros_file / 'climaeropac_global.txt ' / - data aeros_file / '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*26 -!> external co2 global annual mean data tb: co2historicaldata_glob.txt - character, save :: co2gbl_file*26 -!> external co2 user defined data table: co2userdata.txt - character, save :: co2usr_file*26 -!> external co2 clim monthly cycle data tb: co2monthlycyc.txt - character, save :: co2cyc_file*26 - data co2dat_file / 'co2historicaldata_2004.txt' / !year is run-time selected - data co2gbl_file / 'co2historicaldata_glob.txt' / - data co2usr_file / 'co2userdata.txt ' / - data co2cyc_file / '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 overlapping control flag for SW -!!\n =0:use random cloud overlapping method -!!\n =1:use maximum-random cloud overlapping method -!!\n =2:use maximum cloud overlapping method -!!\n =3:use decorrelation length 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 =2:use maximum cloud overlapping method -!!\n =3:use decorrelation length overlapping method -!!\n Opr GFS/CFS=1; see IOVR_LW in run scripts - integer, save :: iovrlw = 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 - -!> 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*26 - data semis_file / 'sfc_emissivity_idx.txt ' / - -! ............................................. ! -!> \name -2.6- general purpose -! ............................................. ! - -!> vertical profile indexing flag - integer, save :: ivflip = 1 - -!> initial permutaion seed for mcica radiation - integer, save :: ipsd0 = 0 - integer, save :: ipsdlim = 1e8 -! -!...................................! - end module physparam ! -!===================================! -!! @} diff --git a/gfsphysics/physics/precpd.f b/gfsphysics/physics/precpd.f deleted file mode 100644 index 9c4ac6949..000000000 --- a/gfsphysics/physics/precpd.f +++ /dev/null @@ -1,719 +0,0 @@ -!> \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/gfsphysics/physics/precpd_shoc.f b/gfsphysics/physics/precpd_shoc.f deleted file mode 100644 index 4e6ed221f..000000000 --- a/gfsphysics/physics/precpd_shoc.f +++ /dev/null @@ -1,438 +0,0 @@ - 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/gfsphysics/physics/precpdp.f b/gfsphysics/physics/precpdp.f deleted file mode 100644 index 83c7202b3..000000000 --- a/gfsphysics/physics/precpdp.f +++ /dev/null @@ -1,570 +0,0 @@ - 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/gfsphysics/physics/progt2.f b/gfsphysics/physics/progt2.f deleted file mode 100644 index c4a24a22c..000000000 --- a/gfsphysics/physics/progt2.f +++ /dev/null @@ -1,246 +0,0 @@ - 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/gfsphysics/physics/progtm_module.f b/gfsphysics/physics/progtm_module.f deleted file mode 100644 index 6f5b3fccb..000000000 --- a/gfsphysics/physics/progtm_module.f +++ /dev/null @@ -1,93 +0,0 @@ - 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/gfsphysics/physics/rad_initialize.f b/gfsphysics/physics/rad_initialize.f deleted file mode 100644 index 23a97e7c4..000000000 --- a/gfsphysics/physics/rad_initialize.f +++ /dev/null @@ -1,217 +0,0 @@ -!----------------------------------- - 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, & - & icliq_sw,crick_proof,ccnorm, & - & imp_physics,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 ! -! icliq_sw : sw optical property for liquid clouds ! -! =0:input cld opt depth, ignoring iswcice setting ! -! =1:cloud optical property scheme based on Hu and ! -! Stamnes(1993) \cite hu_and_stamnes_1993 method ! -! =2:cloud optical property scheme based on Hu and ! -! Stamnes(1993) -updated ! -! iovr_sw/iovr_lw : control flag for cloud overlap (sw/lw rad) ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! =2: maximum overlap clouds (mcica only) ! -! =3: decorrelation-length overlap (mcica only) ! -! 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, & - & iaermdl, icldflg, & - & iovrsw , iovrlw , lcrick , lcnorm , lnoprec, & - & ialbflg, iemsflg, isubcsw, isubclw, ivflip , ipsd0, & - & iswcliq, & - & 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, icliq_sw, iflip, me, idate(4) - - real (kind=kind_phys), intent(in) :: si(levr+1) - integer, intent(in) :: imp_physics - - logical, intent(in) :: crick_proof, ccnorm, norad_precip - -! --- output: ( none ) - -! --- local: -! -!===> ... 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 - iaermdl = iaer/1000 ! control flag for aerosol scheme selection - if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) 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 ! no support for diag cloud opt prop scheme -! endif - - iswcliq = icliq_sw ! optical property for liquid clouds for sw - - 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,' icliq_sw=',icliq_sw, & - & ' iflip=',iflip,' me=',me - print *,' crick_proof=',crick_proof, & - & ' ccnorm=',ccnorm,' norad_precip=',norad_precip - endif - - call radinit & -! --- inputs: - & ( si, levr, imp_physics, 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/gfsphysics/physics/radiation_aerosols.f b/gfsphysics/physics/radiation_aerosols.f deleted file mode 100644 index 45a909ca8..000000000 --- a/gfsphysics/physics/radiation_aerosols.f +++ /dev/null @@ -1,4528 +0,0 @@ -!> \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,aerfld,xlon,xlat, ! -! IMAX,NLAY,NLP1, lsswr,lslwr, ! -! outputs: ! -! (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 asymmetry 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 ! -! jun 2018 --- h-m lin and y-t hou updated spectral band ! -! mapping method for aerosol optical properties. controled by ! -! internal variable lmap_new through namelist variable iaer. ! -! may 2019 --- sarah lu, restore the gocart option, allowing ! -! aerosol ext, ssa, asy determined from MERRA2 monthly climo ! -! with new spectral band mapping method ! -! ! -! 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 ! -! colarco et al., 2010 - jgr, v115, D14207 ! -! ! -! references for merra2 aerosol reanalysis: ! -! randles et al., 2017 - jclim, v30, 6823-6850 ! -! buchard et al., 2017 - jclim, v30, 6851-6871 ! -! ! -! 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 -!! Colarco et al., 2010 - jgr, v115, D14207\cite colarco_et_al_2010 -!! -!! - MERRA2 aerosol reanalysis: -!! Randles et al., 2017 - jclim, v30, 6823-6850\cite randles_et_al_2017 -!! Buchard et al., 2017 - jclim, v30, 6851-6871\cite buchard_et_al_2017 -!! -!! - Stratospheric volcanical aerosols: -!! Sato et al. 1993 \cite sato_et_al_1993 -!========================================! - module module_radiation_aerosols ! -!........................................! -! - use physparam,only : iaermdl, iaerflg, 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 aerclm_def, only : ntrcaerm - -! - 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 -! LW aerosols effect control flag -! =.true.:aerosol effect is included in LW radiation -! =.false.:aerosol effect is not included in LW radiation - logical, save :: lalwflg = .true. -! SW aerosols effect control flag -! =.true.:aerosol effect is included in SW radiation -! =.false.:aerosol effect is not included in SW radiation - logical, save :: laswflg = .true. -! stratospheric volcanic aerosol effect flag -! =.true.:historical events of stratosphere volcanic aerosol effect -! is included radiation (limited by data availability) -! =.false.:volcanic aerosol effect is not included in radiation - logical, save :: lavoflg = .true. - - logical, save :: lmap_new = .true. ! use new mapping method (set in aer_init) - -! --------------------------------------------------------------------- ! -! 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 / - - real (kind=kind_phys), dimension(NBDSW), save :: wvn_sw1, wvn_sw2 - real (kind=kind_phys), dimension(NBDLW), save :: wvn_lw1, wvn_lw2 -! --------------------------------------------------------------------- ! -! 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: -!> num of bands for aer data (gocart) - integer, parameter :: KAERBNDD=61 - integer, parameter :: KAERBNDI=56 -!> num of rh levels for rh-dep components - integer, parameter :: KRHLEV =36 -!> num of gocart rh indep aerosols - integer, parameter :: KCM1 = 5 -!> num of gocart rh dep aerosols - integer, parameter :: KCM2 = 10 -!> num of gocart aerosols - integer, parameter :: KCM = KCM1 + KCM2 - - 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 / - -!> \name relative humidity independent aerosol optical properties: -!! species: du001, du002, du003, du004, du005 -! extrhi_grt(KCM1,NSWLWBD) - extinction coefficient for sw+lw band -! scarhi_grt(KCM1,NSWLWBD) - scattering coefficient for sw+lw band -! ssarhi_grt(KCM1,NSWLWBD) - single scattering albedo for sw+lw band -! asyrhi_grt(KCM1,NSWLWBD) - asymmetry parameter for sw+lw band - real (kind=kind_phys),allocatable,save,dimension(:,:) :: & - & extrhi_grt, scarhi_grt, ssarhi_grt, asyrhi_grt -! -!> \name relative humidity dependent aerosol optical properties: -!! species : ss001, ss002, ss003, ss004, ss005, so4, -!! bcphobic, bcphilic, ocphobic, ocphilic -! extrhd_grt(KRHLEV,KCM2,NSWLWBD) - extinction coefficient for sw+lw band -! scarhd_grt(KRHLEV,KCM2,NSWLWBD) - scattering 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 - -!> extinction coefficient - real (kind=kind_phys),allocatable,save,dimension(:,:,:) :: & - & extrhd_grt, scarhd_grt, ssarhd_grt, asyrhd_grt - -!> gocart species - integer, parameter :: num_gc = 5 - character*2 :: gridcomp(num_gc) - integer, dimension (num_gc):: num_radius, radius_lower - integer, dimension (num_gc):: trc_to_aod - - data gridcomp /'DU', 'SS', 'SU', 'BC', 'OC'/ - data num_radius /5, 5, 1, 2, 2 / - data radius_lower /1, 6, 11, 12, 14 / - data trc_to_aod /1, 5, 4, 2, 3/ ! dust, soot, waso, suso, ssam - -! ======================================================================= -! --------------------------------------------------------------------- ! -! section-5 : module variables for aod diagnostic ! -! --------------------------------------------------------------------- ! -!! --- 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 ! -! =5 opac-clim new spectral mapping ! -! 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, gocart_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 - - 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 - -!> -# 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 - - wvn_sw1(:) = wvnsw1(:) - wvn_sw2(:) = wvnsw2(:) - wvn_lw1(:) = wvnlw1(:) - wvn_lw2(:) = wvnlw2(:) - -! note: for result consistency, the defalt opac-clim aeros setting still use -! old spectral band mapping. use iaermdl=5 to use new mapping method - - if ( iaermdl == 0 ) then ! opac-climatology scheme - lmap_new = .false. - - wvn_sw1(2:NBDSW-1) = wvn_sw1(2:NBDSW-1) + 1 - wvn_lw1(2:NBDLW) = wvn_lw1(2:NBDLW) + 1 - else - lmap_new = .true. - endif - - 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 .or. iaermdl==5 ) then ! opac-climatology scheme - - call clim_aerinit & -! --- inputs: - & ( solfwv, eirfwv, me & -! --- outputs: - & ) - - elseif ( iaermdl==1 .or. iaermdl==2 ) then ! gocart clim/prog scheme - - call gocart_aerinit & -! --- inputs: - & ( solfwv, eirfwv, me & -! --- outputs: - & ) - - 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; 5:opac-clim+new mapping ! -! 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 .or. iaermdl==5 ) 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, ik, ibs, ibe - - real (kind=kind_phys) :: sumsol, sumir, fac, tmp, wvs, wve - - 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 - - ibs = 1 - ibe = 1 - wvs = wvn_sw1(1) - wve = wvn_sw1(1) - nv_aod = 1 - do ib = 2, NSWBND - mb = ib + NSWSTR - 1 - if ( wvn_sw2(mb) >= wvn550 .and. wvn550 >= wvn_sw1(mb) ) then - nv_aod = ib ! sw band number covering 550nm wavelenth - endif - - if ( wvn_sw1(mb) < wvs ) then - wvs = wvn_sw1(mb) - ibs = ib - endif - if ( wvn_sw1(mb) > wve ) then - wve = wvn_sw1(mb) - ibe = ib - endif - enddo - -!$omp parallel do private(ib,mb,ii,iw1,iw2,iw,sumsol,fac,tmp,ibs,ibe) - do ib = 1, NSWBND - mb = ib + NSWSTR - 1 - ii = 1 - iw1 = nint(wvn_sw1(mb)) - iw2 = nint(wvn_sw2(mb)) - - Lab_swdowhile : do while ( iw1 > iendwv(ii) ) - if ( ii == NAERBND ) exit Lab_swdowhile - ii = ii + 1 - enddo Lab_swdowhile - - if ( lmap_new ) then - if (ib == ibs) then - sumsol = f_zero - else - sumsol = -0.5 * solfwv(iw1) - endif - if (ib == ibe) then - fac = f_zero - else - fac = -0.5 - endif - solbnd(ib) = sumsol - else - sumsol = f_zero - endif - 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 - - if ( lmap_new ) then - tmp = fac * solfwv(iw2) - solwaer(ib,ii) = solwaer(ib,ii) + tmp - solbnd(ib) = solbnd(ib) + tmp - 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 - - ibs = 1 - ibe = 1 - if (NLWBND > 1 ) then - wvs = wvn_lw1(1) - wve = wvn_lw1(1) - do ib = 2, NLWBND - mb = ib + NLWSTR - 1 - if ( wvn_lw1(mb) < wvs ) then - wvs = wvn_lw1(mb) - ibs = ib - endif - if ( wvn_lw1(mb) > wve ) then - wve = wvn_lw1(mb) - ibe = ib - endif - enddo - endif - -!$omp parallel do private(ib,ii,iw1,iw2,iw,mb,sumir,fac,tmp,ibs,ibe) - 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(wvn_lw1(mb)) - iw2 = nint(wvn_lw2(mb)) - endif - - Lab_lwdowhile : do while ( iw1 > iendwv(ii) ) - if ( ii == NAERBND ) exit Lab_lwdowhile - ii = ii + 1 - enddo Lab_lwdowhile - - if ( lmap_new ) then - if (ib == ibs) then - sumir = f_zero - else - sumir = -0.5 * eirfwv(iw1) - endif - if (ib == ibe) then - fac = f_zero - else - fac = -0.5 - endif - eirbnd(ib) = sumir - else - sumir = f_zero - endif - 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 - - if ( lmap_new ) then - tmp = fac * eirfwv(iw2) - eirwaer(ib,ii) = eirwaer(ib,ii) + tmp - eirbnd(ib) = eirbnd(ib) + tmp - 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 - - if ( iaermdl == 0 .or. iaermdl==5 ) then ! opac-climatology scheme - call trop_update - endif - - 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,aerfld,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 ! -! aerfld - prescribed aerosol mixing rat IMAX*NLAY*NTRCAER! -! 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 - real (kind=kind_phys), dimension(:,:,:),intent(in):: aerfld - - 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). - - if ( iaermdl==0 .or. iaermdl==5 ) 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 & - & ) - -! - elseif ( iaermdl==1 .or. iaermdl==2) then ! use gocart aerosols - - call aer_property_gocart & -! --- inputs: - & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk,laersw,laerlw, & - & IMAX,NLAY,NLP1, & -! --- outputs: - & aerosw,aerolw,aerodp & - & ) - endif ! end if_iaerflg_block - - -! --- 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 - - 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 ( wvn_sw1(mb) > 20000 ) then ! range of wvlth < 0.5mu - tmp2 = 0.74 - elseif ( wvn_sw2(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 * (wvn_sw2(mb)+wvn_sw1(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 * (wvn_lw2(m) + wvn_lw1(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 ( wvn_sw1(mb) > 20000 ) then ! range of wvlth < 0.5mu - tmp2 = 0.74 - elseif ( wvn_sw2(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 * (wvn_sw2(mb)+wvn_sw1(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 * (wvn_lw2(m) + wvn_lw1(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) - do m = 1, NSPC - aerodp(i,m+1) = spcodp(m) - enddo - - 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 -!----------------------------------- - -!> @} -!> This subroutine is the gocart 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 gel_go_ini General Algorithm -!! @{ -!----------------------------------- - subroutine gocart_aerinit & - & ( solfwv, eirfwv, me & - & ) - -! ================================================================== ! -! ! -! subprogram : gocart_aerinit ! -! ! -! gocart_aerinit is the gocart 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) ! -! ! -! module variables: ! -! 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 ! -! KCM1 - number of rh independent aeros species ! -! KCM2 - number of rh dependent aeros species ! -! ! -! usage: call gocart_init ! -! ! -! subprograms called: rd_gocart_luts, optavg_gocart ! -! ! -! ================================================================== ! - - implicit none - -! --- 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(kaerbndi,kcm1) :: & - & rhidext0_grt, rhidsca0_grt, rhidssa0_grt, rhidasy0_grt - real (kind=kind_phys), dimension(kaerbndd,krhlev,kcm2):: & - & rhdpext0_grt, rhdpsca0_grt, rhdpssa0_grt, rhdpasy0_grt - - real (kind=kind_phys), dimension(nswbnd,kaerbndd) :: solwaer - real (kind=kind_phys), dimension(nswbnd) :: solbnd - real (kind=kind_phys), dimension(nlwbnd,kaerbndd) :: eirwaer - real (kind=kind_phys), dimension(nlwbnd) :: eirbnd - - real (kind=kind_phys), dimension(nswbnd,kaerbndi) :: solwaer_du - real (kind=kind_phys), dimension(nswbnd) :: solbnd_du - real (kind=kind_phys), dimension(nlwbnd,kaerbndi) :: eirwaer_du - real (kind=kind_phys), dimension(nlwbnd) :: eirbnd_du - - integer, dimension(nswbnd) :: nv1, nv2, nv1_du, nv2_du - integer, dimension(nlwbnd) :: nr1, nr2, nr1_du, nr2_du - - integer, dimension(kaerbndd) :: iendwv - integer, dimension(kaerbndi) :: iendwv_du - real (kind=kind_phys), dimension(kaerbndd) :: wavelength - real (kind=kind_phys), dimension(kaerbndi) :: wavelength_du - real (kind=kind_phys) :: sumsol, sumir, sumsol_du, sumir_du - - integer :: i, j, k, mb, ib, ii, iix, iw, iw1, iw2 - -! -!===> ... begin here -! -! --- ... invoke gocart aerosol initialization - - - if (KCM /= ntrcaerm ) then - print *, 'ERROR in # of gocart aer species',KCM - stop 3000 - endif - -! --- ... aloocate and input aerosol optical data - - if ( .not. allocated( extrhi_grt ) ) then - allocate ( extrhi_grt ( kcm1,nswlwbd) ) - allocate ( scarhi_grt ( kcm1,nswlwbd) ) - allocate ( ssarhi_grt ( kcm1,nswlwbd) ) - allocate ( asyrhi_grt ( kcm1,nswlwbd) ) - allocate ( extrhd_grt (krhlev,kcm2,nswlwbd) ) - allocate ( scarhd_grt (krhlev,kcm2,nswlwbd) ) - allocate ( ssarhd_grt (krhlev,kcm2,nswlwbd) ) - allocate ( asyrhd_grt (krhlev,kcm2,nswlwbd) ) - endif - -! --- ... read tabulated GOCART aerosols optical data - - call rd_gocart_luts -! --- inputs: (in scope variables, module variables) -! --- outputs: (in scope variables) - -! --- ... convert wavelength to wavenumber -! wavelength and wavelength_du are read-in by rd_gocart_luts - - do i = 1, kaerbndd - iendwv(i) = int(10000. / wavelength(i)) - enddo - - do i = 1, kaerbndi - iendwv_du(i) = int(10000. / wavelength_du(i)) - enddo - -! --- ... compute solar flux weights and interval indices for mapping -! spectral bands between sw radiation and aerosol data - - if ( laswflg ) then - solbnd (:) = f_zero - solbnd_du (:)= f_zero - do i=1,nswbnd - do j=1,kaerbndd - solwaer(i,j) = f_zero - enddo - do j=1,kaerbndi - solwaer_du(i,j) = f_zero - enddo - enddo - - do ib = 1, nswbnd - mb = ib + nswstr - 1 - ii = 1 - iix = 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 - -! -- for rd-dependent - do while ( iw1 > iendwv(ii) ) - if ( ii == kaerbndd ) exit - ii = ii + 1 - enddo - sumsol = f_zero - nv1(ib) = ii - -! -- for rd-independent - do while ( iw1 > iendwv_du(iix) ) - if ( iix == kaerbndi ) exit - iix = iix + 1 - enddo - sumsol_du = f_zero - nv1_du(ib) = iix - - do iw = iw1, iw2 -! -- for rd-dependent - solbnd(ib) = solbnd(ib) + solfwv(iw) - sumsol = sumsol + solfwv(iw) - - if ( iw == iendwv(ii) ) then - solwaer(ib,ii) = sumsol - if ( ii < kaerbndd ) then - sumsol = f_zero - ii = ii + 1 - endif - endif - -! -- for rd-independent - solbnd_du(ib) = solbnd_du(ib) + solfwv(iw) - sumsol_du = sumsol_du + solfwv(iw) - - if ( iw == iendwv_du(iix) ) then - solwaer_du(ib,iix) = sumsol_du - if ( iix < kaerbndi ) then - sumsol_du = f_zero - iix = iix + 1 - endif - endif - enddo - - if ( iw2 /= iendwv(ii) ) then - solwaer(ib,ii) = sumsol - endif - if ( iw2 /= iendwv_du(iix) ) then - solwaer_du(ib,iix) = sumsol_du - endif - - nv2(ib) = ii - nv2_du(ib) = iix - 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 - eirbnd_du (:) = f_zero - do i=1,nlwbnd - do j=1,kaerbndd - eirwaer(i,j) = f_zero - enddo - do j=1,kaerbndi - eirwaer_du(i,j) = f_zero - enddo - enddo - - do ib = 1, nlwbnd - ii = 1 - iix = 1 - if ( nlwbnd == 1 ) then - iw1 = 400 ! corresponding 25 mu - iw2 = 2500 ! corresponding 4 mu - else - mb = ib + nlwstr - 1 - iw1 = nint(wvnlw1(mb)) - iw2 = nint(wvnlw2(mb)) - endif - -! -- for rd-dependent - do while ( iw1 > iendwv(ii) ) - if ( ii == kaerbndd ) exit - ii = ii + 1 - enddo - sumir = f_zero - nr1(ib) = ii - -! -- for rd-independent - do while ( iw1 > iendwv_du(iix) ) - if ( iix == kaerbndi ) exit - iix = iix + 1 - enddo - sumir_du = f_zero - nr1_du(ib) = iix - - do iw = iw1, iw2 -! -- for rd-dependent - eirbnd(ib) = eirbnd(ib) + eirfwv(iw) - sumir = sumir + eirfwv(iw) - - if ( iw == iendwv(ii) ) then - eirwaer(ib,ii) = sumir - - if ( ii < kaerbndd ) then - sumir = f_zero - ii = ii + 1 - endif - endif - -! -- for rd-independent - eirbnd_du(ib) = eirbnd_du(ib) + eirfwv(iw) - sumir_du = sumir_du + eirfwv(iw) - - if ( iw == iendwv_du(iix) ) then - eirwaer_du(ib,iix) = sumir_du - - if ( iix < kaerbndi ) then - sumir_du = f_zero - iix = iix + 1 - endif - endif - enddo - - if ( iw2 /= iendwv(ii) ) then - eirwaer(ib,ii) = sumir - endif - if ( iw2 /= iendwv_du(iix) ) then - eirwaer_du(ib,iix) = sumir_du - endif - - nr2(ib) = ii - nr2_du(ib) = iix - enddo ! end do_ib_block for lw - endif ! end if_lalwflg_block - -! --- compute spectral band mean properties for each species - - call optavg_gocart -! --- inputs: (in-scope variables, module variables) -! --- outputs: (module variables) - - -! --- check print -! if (me == 0) then -! do ib = 1, NSWBND -! mb = ib + NSWSTR - 1 -! print *, ' wvnsw1,wvnsw2 :',wvnsw1(mb),wvnsw2(mb) -! print *, ' After optavg_gocart, for sw band:',ib -! print *, ' extrhi:', extrhi_grt(:,ib) -! print *, ' scarhi:', scarhi_grt(:,ib) -! print *, ' ssarhi:', ssarhi_grt(:,ib) -! print *, ' asyrhi:', asyrhi_grt(:,ib) -! do i = 1, KRHLEV -! print *, ' extrhd for rhlev:',i -! print *, extrhd_grt(i,:,ib) -! print *, ' scarhd for rhlev:',i -! print *, scarhd_grt(i,:,ib) -! print *, ' ssarhd for rhlev:',i -! print *, ssarhd_grt(i,:,ib) -! print *, ' asyrhd for rhlev:',i -! print *, asyrhd_grt(i,:,ib) -! enddo -! enddo -! print *, ' wvnlw1 :',wvnlw1 -! print *, ' wvnlw2 :',wvnlw2 -! do ib = 1, NLWBND -! ii = NSWBND + ib -! print *,' After optavg_gocart, for lw band:',ib -! print *,' extrhi_grt:', extrhi_grt(:,ii) -! print *,' scarhi_grt:', scarhi_grt(:,ii) -! print *,' ssarhi_grt:', ssarhi_grt(:,ii) -! print *,' asyrhi_grt:', asyrhi_grt(:,ii) -! do i = 1, KRHLEV -! print *,' extrhd for rhlev:',i -! print *, extrhd_grt(i,:,ib) -! print *,' scarhd for rhlev:',i -! print *, scarhd_grt(i,:,ib) -! print *,' ssarhd for rhlev:',i -! print *, ssarhd_grt(i,:,ib) -! print *,' asyrhd for rhlev:',i -! print *, asyrhd_grt(i,:,ib) -! enddo -! enddo -! endif - -! ================= - contains -! ================= - -!----------------------------- - subroutine rd_gocart_luts -!............................. -! --- inputs: (in scope variables, module variables) -! --- outputs: (in scope variables) - -! ==================================================================== ! -! ! -! subprogram: rd_gocart_luts ! -! read GMAO pre-tabultaed aerosol optical data for dust, seasalt, ! -! sulfate, black carbon, and organic carbon aerosols ! -! ! -! major local variables: ! -! for handling spectral band structures ! -! iendwv - ending wvnum (cm**-1) for each band kaerbndd ! -! iendwv_du - ending wvnum (cm**-1) for each band kaerbndi ! -! for handling optical properties of rh independent species (kcm1) ! -! 1=du001, 2=du002, 3=du003, 4=du004, 5=du005 ! -! rhidext0_grt - extinction coefficient kaerbndi*kcm1 ! -! rhidsca0_grt - scattering coefficient kaerbndi*kcm1 ! -! rhidssa0_grt - single scattering albedo kaerbndi*kcm1 ! -! rhidasy0_grt - asymmetry parameter kaerbndi*kcm1 ! -! for handling optical properties of rh ndependent species (kcm2) ! -! 1=ss001, 2=ss002, 3=ss003, 4=ss004, 5=ss005, 6=so4, ! -! 7=bcphobic, 8=bcphilic, 9=ocphobic, 10=ocphilic ! -! rhdpext0_grt - extinction coefficient kaerbndd*krhlev*kcm2! -! rhdpsca0_grt - scattering coefficient kaerbndd*krhlev*kcm2! -! rhdpssa0_grt - single scattering albedo kaerbndd*krhlev*kcm2! -! rhdpasy0_grt - asymmetry parameter kaerbndd*krhlev*kcm2! -! ! -! usage: call rd_gocart_luts ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: (none) -! --- output: (none) - -! --- locals: - integer :: iradius, ik, ibeg - integer, parameter :: numspc = 5 ! # of aerosol species - -! - input tabulated aerosol optical spectral data from GSFC - real, dimension(kaerbndd) :: lambda ! wavelength (m) for non-dust - real, dimension(kaerbndi) :: lambda_du ! wavelength (m) for dust - real, dimension(krhlev) :: rh ! relative humidity (fraction) - real, dimension(kaerbndd,krhlev,numspc) :: bext! extinction efficiency (m2/kg) - real, dimension(kaerbndd,krhlev,numspc) :: bsca! scattering efficiency (m2/kg) - real, dimension(kaerbndd,krhlev,numspc) :: g ! asymmetry factor (dimensionless) - real, dimension(kaerbndi,krhlev,numspc) :: bext_du! extinction efficiency (m2/kg) - real, dimension(kaerbndi,krhlev,numspc) :: bsca_du! scattering efficiency (m2/kg) - real, dimension(kaerbndi,krhlev,numspc) :: g_du ! asymmetry factor (dimensionless) -! - logical :: file_exist - character*50 :: fin, dummy - -! --- read LUTs for dust aerosols - fin='optics_'//gridcomp(1)//'.dat' - inquire (file=trim(fin), exist=file_exist) - if ( file_exist ) then - close(niaercm) - open (unit=niaercm, file=fin, status='OLD') - rewind(niaercm) - else - print *,' Requested luts file ',trim(fin),' not found' - print *,' ** Stopped in rd_gocart_luts ** ' - stop 1220 - endif ! end if_file_exist_block - - iradius = 5 -! read lambda and compute mpwavelength (m) - read(niaercm,'(a40)') dummy - read(niaercm,*) (lambda_du(i), i=1, kaerbndi) -! read rh, relative humidity (fraction) - read(niaercm,'(a40)') dummy - read(niaercm,*) (rh(i), i=1, krhlev) -! read bext (m2 (kg dry mass)-1) - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (bext_du(i,j,k), i=1,kaerbndi) - enddo - enddo -! read bsca (m2 (kg dry mass)-1) - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (bsca_du(i,j,k), i=1, kaerbndi) - enddo - enddo -! read g (dimensionless) - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (g_du(i,j,k), i=1, kaerbndi) - enddo - enddo - -! fill rhidext0 local arrays for dust aerosols (flip i-index) - do i = 1, kaerbndi ! convert from m to micron - j = kaerbndi -i + 1 ! flip i-index - wavelength_du(j) = 1.e6 * lambda_du(i) - enddo - do k = 1, iradius - do i = 1, kaerbndi - ii = kaerbndi -i + 1 - rhidext0_grt(ii,k) = bext_du(i,1,k) - rhidsca0_grt(ii,k) = bsca_du(i,1,k) - if ( bext_du(i,1,k) /= f_zero) then - rhidssa0_grt(ii,k) = bsca_du(i,1,k)/bext_du(i,1,k) - else - rhidssa0_grt(ii,k) = f_one - endif - rhidasy0_grt(ii,k) = g_du(i,1,k) - enddo - enddo - -! --- read LUTs for non-dust aerosols - do ib = 2, num_gc ! loop thru SS, SU, BC, OC - fin='optics_'//gridcomp(ib)//'.dat' - inquire (file=trim(fin), exist=file_exist) - if ( file_exist ) then - close(niaercm) - open (unit=niaercm, file=fin, status='OLD') - rewind(niaercm) - else - print *,' Requested luts file ',trim(fin),' not found' - print *,' ** Stopped in rd_gocart_luts ** ' - stop 1222 - endif ! end if_file_exist_block - - ibeg = radius_lower(ib) - kcm1 - iradius = num_radius(ib) - -! read lambda and compute mpwavelength (m) - read(niaercm,'(a40)') dummy - read(niaercm,*) (lambda(i), i=1, kaerbndd) -! read rh, relative humidity (fraction) - read(niaercm,'(a40)') dummy - read(niaercm,*) (rh(i), i=1, krhlev) -! read bext - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (bext(i,j,k), i=1,kaerbndd) - enddo - enddo -! read bsca - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (bsca(i,j,k), i=1, kaerbndd) - enddo - enddo -! read g - do k = 1, iradius - read(niaercm,'(a40)') dummy - do j=1, krhlev - read(niaercm,*) (g(i,j,k), i=1, kaerbndd) - enddo - enddo - -! fill rhdpext0 local arrays for non-dust aerosols (flip i-index) - do i = 1, kaerbndd ! convert from m to micron - j = kaerbndd -i + 1 ! flip i-index - wavelength(j) = 1.e6 * lambda(i) - enddo - do k = 1, iradius - ik = ibeg + k - 1 - do i = 1, kaerbndd - ii = kaerbndd -i + 1 - do j = 1, krhlev - rhdpext0_grt(ii,j,ik) = bext(i,j,k) - rhdpsca0_grt(ii,j,ik) = bsca(i,j,k) - if ( bext(i,j,k) /= f_zero) then - rhdpssa0_grt(ii,j,ik) = bsca(i,j,k)/bext(i,j,k) - else - rhdpssa0_grt(ii,j,ik) = f_one - endif - rhdpasy0_grt(ii,j,ik) = g(i,j,k) - enddo - enddo - enddo - - enddo !! ib-loop - - return -!................................... - end subroutine rd_gocart_luts -!----------------------------------- - -!-------------------------------- - subroutine optavg_gocart -!................................ -! --- inputs: (in-scope variables, module variables) -! --- outputs: (module variables) - -! ==================================================================== ! -! ! -! subprogram: optavg_gocart ! -! ! -! compute mean aerosol optical properties over each sw radiation ! -! spectral band for each of the species components. This program ! -! follows optavg routine (in turn 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 ! -! nv1_du,nv2_du(nswbnd) - start/end spectral band indices of aer data! -! for each sw radiation spectral band ! -! nr1_du,nr2_du(nlwbnd) - start/end spectral band indices of aer data! -! for each ir radiation spectral band ! -! solwaer (nswbnd,kaerbndd) ! -! - solar flux weight over each sw radiation band ! -! vs each aerosol data spectral band ! -! eirwaer (nlwbnd,kaerbndd) ! -! - ir flux weight over each lw radiation band ! -! vs each aerosol data spectral band ! -! solwaer_du (nswbnd,kaerbndi) ! -! - solar flux weight over each sw radiation band ! -! vs each aerosol data spectral band ! -! eirwaer_du (nlwbnd,kaerbndi) ! -! - 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 ! -! solbnd_du(nswbnd) - solar flux weight over each sw radiation band ! -! eirbnd_du(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 - do nb = 1, nswbnd - rsolbd = f_one / solbnd_du(nb) - do nc = 1, kcm1 ! --- for rh independent aerosol species - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nv1_du(nb), nv2_du(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_du(nb,ni) - - sumk = sumk + rhidext0_grt(ni,nc)*solwaer_du(nb,ni) - sums = sums + rhidsca0_grt(ni,nc)*solwaer_du(nb,ni) - sumok = sumok + rhidssa0_grt(ni,nc)*solwaer_du(nb,ni) & - & * rhidext0_grt(ni,nc) - sumokg = sumokg + rhidssa0_grt(ni,nc)*solwaer_du(nb,ni) & - & * rhidext0_grt(ni,nc)*rhidasy0_grt(ni,nc) - enddo - - refb = sumreft * rsolbd - - extrhi_grt(nc,nb) = sumk * rsolbd - scarhi_grt(nc,nb) = sums * 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 - - rsolbd = f_one / solbnd(nb) - do nc = 1, kcm2 ! --- for rh dependent aerosol species - do nh = 1, krhlev - 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_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) - sums = sums + rhdpsca0_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 - scarhd_grt(nh,nc,nb) = sums * 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 - - enddo ! end do_nb_block for sw - endif ! end if_laswflg_block - -! --- ... loop for each lw radiation spectral band - - if ( lalwflg ) then - - do nb = 1, nlwbnd - - ib = nswbnd + nb - - rirbd = f_one / eirbnd_du(nb) - do nc = 1, kcm1 ! --- for rh independent aerosol species - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nr1_du(nb), nr2_du(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_du(nb,ni) - - sumk = sumk + rhidext0_grt(ni,nc)*eirwaer_du(nb,ni) - sums = sums + rhidsca0_grt(ni,nc)*eirwaer_du(nb,ni) - sumok = sumok + rhidssa0_grt(ni,nc)*eirwaer_du(nb,ni) & - & * rhidext0_grt(ni,nc) - sumokg = sumokg + rhidssa0_grt(ni,nc)*eirwaer_du(nb,ni) & - & * rhidext0_grt(ni,nc)*rhidasy0_grt(ni,nc) - enddo - - refb = sumreft * rirbd - - extrhi_grt(nc,ib) = sumk * rirbd - scarhi_grt(nc,ib) = sums * 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 - - rirbd = f_one / eirbnd(nb) - do nc = 1, kcm2 ! --- for rh dependent aerosol species - do nh = 1, krhlev - 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_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) - sums = sums + rhdpsca0_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 - scarhd_grt(nh,nc,ib) = sums * 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 - - enddo ! end do_nb_block for lw - endif ! end if_lalwflg_block -! - return - return -!................................... - end subroutine optavg_gocart -!----------------------------------- - -!................................... - end subroutine gocart_aerinit -!----------------------------------- -!! @} - -!> This subroutine 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 -!!\param aerfld (IMAX,NLAY,NTRCAER), aer tracer concentrations -!!\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_go_aer_pro General Algorithm -!! @{ -!----------------------------------- - subroutine aer_property_gocart & -!................................... - -! --- inputs: - & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk, laersw,laerlw, & - & imax,nlay,nlp1, & -! --- outputs: - & aerosw,aerolw,aerodp & - & ) - -! ================================================================== ! -! ! -! aer_property_gocart maps prescribed gocart 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! -! aerfld - prescribed aer tracer mixing ratios IMAX*NLAY*NTRCAER! -! 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 ! -! ! -! 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) ! -! ! -! usage: call aer_property_gocart ! -! ! -! ================================================================== ! - -! --- inputs: - integer, intent(in) :: IMAX, NLAY, NLP1 - 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 - real (kind=kind_phys), dimension(:,:,:),intent(in):: aerfld - -! --- outputs: - real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & - & aerosw, aerolw - real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp - -! --- locals: - real (kind=kind_phys), dimension(nlay,nswlwbd):: tauae,ssaae,asyae - real (kind=kind_phys), dimension(nspc) :: spcodp - - real (kind=kind_phys),dimension(nlay,kcm) :: aerms - real (kind=kind_phys),dimension(nlay) :: dz1, rh1 - real (kind=kind_phys) :: plv, tv, rho - integer :: i, m, m1, k - -! -!===> ... begin here -! - lab_do_IMAXg : do i = 1, IMAX - -! --- initialize tauae, ssaae, asyae - do m = 1, NSWLWBD - do k = 1, NLAY - tauae(k,m) = f_zero - ssaae(k,m) = f_one - asyae(k,m) = f_zero - enddo - enddo - -! --- set floor value for aerms (kg/m3) - do k = 1, NLAY - do m = 1, kcm - aerms(k,m) = 1.e-15 - enddo - enddo - - do m = 1, nspc - spcodp(m) = f_zero - enddo - - do k = 1, NLAY - rh1(k) = rhlay(i,k) ! - dz1(k) = 1000.*dz (i,k) ! thickness converted from km to m - 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 - - do m = 1, KCM - aerms(k,m) = aerfld(i,k,m)*rho ! dry mass (kg/m3) - enddo -! -! --- calculate sw/lw aerosol optical properties for the -! corresponding frequency bands - - call aeropt -! --- inputs: (in-scope variables) -! --- outputs: (in-scope variables) - - enddo ! end_do_k_loop - -! ---------------------------------------------------------------------- - -! --- update aerosw and aerolw arrays - 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 - -! --- update diagnostic aod arrays - do k = 1, NLAY - aerodp(i,1) = aerodp(i,1) + tauae(k,nv_aod) - enddo - - do m = 1, NSPC - aerodp(i,m+1) = spcodp(m) - enddo - - 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_IMAXg - -! ================= - contains -! ================= - -!-------------------------------- - subroutine aeropt -!................................ - -! --- inputs: (in scope variables) -! --- outputs: (in scope variables) - -! ================================================================== ! -! ! -! compute aerosols optical properties in NSWLWBD bands for gocart ! -! aerosol species ! -! ! -! input variables: ! -! rh1 - relative humidity % NLAY ! -! dz1 - layer thickness m NLAY ! -! aerms - aerosol mass concentration kg/m3 NLAY*KCM ! -! 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 ! -! ! -! ================================================================== ! - -! --- inputs: -! --- outputs: - -! --- locals: - real (kind=kind_phys) :: drh0, drh1, rdrh - real (kind=kind_phys) :: cm, ext01, sca01, asy01, ssa01 - real (kind=kind_phys) :: ext1, asy1, ssa1, sca1 - real (kind=kind_phys) :: sum_tau,sum_asy,sum_ssa,tau,asy,ssa - integer :: ih1, ih2, nbin, ib, ntrc, ktrc - -! --- linear interp coeffs for rh-dep species - ih2 = 1 - do while ( rh1(k) > 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(k) - rhlev_grt(ih1) - if ( ih1 == ih2 ) then - rdrh = f_zero - else - rdrh = drh1 / drh0 - endif - -! --- compute optical properties for each spectral bands - do ib = 1, nswlwbd - - sum_tau = f_zero - sum_ssa = f_zero - sum_asy = f_zero - -! --- determine tau, ssa, asy for dust aerosols - ext1 = f_zero - asy1 = f_zero - sca1 = f_zero - ssa1 = f_zero - do m = 1, kcm1 - cm = max(aerms(k,m),0.0) * dz1(k) - ext1 = ext1 + cm*extrhi_grt(m,ib) - sca1 = sca1 + cm*scarhi_grt(m,ib) - ssa1 = ssa1 + cm*extrhi_grt(m,ib) * ssarhi_grt(m,ib) - asy1 = asy1 + cm*scarhi_grt(m,ib) * asyrhi_grt(m,ib) - enddo ! m-loop - tau = ext1 - if (ext1 > f_zero) ssa=min(f_one, ssa1/ext1) - if (sca1 > f_zero) asy=min(f_one, asy1/sca1) - -! --- update aod from individual species - if ( ib==nv_aod ) then - spcodp(1) = spcodp(1) + tau - 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 - -! --- determine tau, ssa, asy for non-dust aerosols - do ntrc = 2, nspc - ext1 = f_zero - asy1 = f_zero - sca1 = f_zero - ssa1 = f_zero - ktrc = trc_to_aod(ntrc) - do nbin = 1, num_radius(ntrc) - m1 = radius_lower(ntrc) + nbin - 1 - m = m1 - num_radius(1) ! exclude dust aerosols - cm = max(aerms(k,m1),0.0) * dz1(k) - ext01 = extrhd_grt(ih1,m,ib) + & - & rdrh * (extrhd_grt(ih2,m,ib)-extrhd_grt(ih1,m,ib)) - sca01 = scarhd_grt(ih1,m,ib) + & - & rdrh * (scarhd_grt(ih2,m,ib)-scarhd_grt(ih1,m,ib)) - ssa01 = ssarhd_grt(ih1,m,ib) + & - & rdrh * (ssarhd_grt(ih2,m,ib)-ssarhd_grt(ih1,m,ib)) - asy01 = asyrhd_grt(ih1,m,ib) + & - & rdrh * (asyrhd_grt(ih2,m,ib)-asyrhd_grt(ih1,m,ib)) - ext1 = ext1 + cm*ext01 - sca1 = sca1 + cm*sca01 - ssa1 = ssa1 + cm*ext01 * ssa01 - asy1 = asy1 + cm*sca01 * asy01 - enddo ! end_do_nbin_loop - tau = ext1 - if (ext1 > f_zero) ssa=min(f_one, ssa1/ext1) - if (sca1 > f_zero) asy=min(f_one, asy1/sca1) -! --- update aod from individual species - if ( ib==nv_aod ) then - spcodp(ktrc) = spcodp(ktrc) + tau - 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 ! end_do_ntrc_loop - -! --- determine total tau, ssa, asy for aerosol mixture - tauae(k,ib) = sum_tau - if (sum_tau > f_zero) ssaae(k,ib) = sum_ssa / sum_tau - if (sum_ssa > f_zero) asyae(k,ib) = sum_asy / sum_ssa - - enddo ! end_do_ib_loop -! - return -!................................ - end subroutine aeropt -!-------------------------------- - -!................................... - end subroutine aer_property_gocart -!----------------------------------- -!! @} -! -! ======================================================================= - -!..........................................! - end module module_radiation_aerosols ! -!==========================================! -!> @} diff --git a/gfsphysics/physics/radiation_astronomy.f b/gfsphysics/physics/radiation_astronomy.f deleted file mode 100644 index e17cf3bc2..000000000 --- a/gfsphysics/physics/radiation_astronomy.f +++ /dev/null @@ -1,1011 +0,0 @@ -!> \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(26) :: 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(15:26) = '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(15:26) = '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(15:26) = '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(15:26) = '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,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) ! -! 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(:), 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 = jdate(1) - imon = jdate(2) - iday = jdate(3) - ihr = jdate(5) - imin = jdate(6) - isec = jdate(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 - -!> -# Call prtime() - call prtime & -! --- inputs: - & ( jd, fjd, dlt, alp, r1, solcon ) -! --- outputs: ( none ) - - endif - -! --- ... setting up calculation parameters used by subr coszmn - - nswr = max(1, 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 - - nstp = max(6, nswr) - anginc = pid12 * dtswh / float(nstp) - - 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, & ! --- 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 ! -! ! -! 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 - -! --- outputs: - real (kind=kind_phys), intent(out) :: coszen(:), coszdg(:) - -! --- locals: - real (kind=kind_phys) :: coszn, cns, solang, rstp - - 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)-0.5)*anginc + sollag - do i = 1, IM - coszn = sindec * sinlat(i) + cosdec * coslat(i) & - & * 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 -! - 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/gfsphysics/physics/radiation_clouds.f b/gfsphysics/physics/radiation_clouds.f deleted file mode 100644 index 99d58b677..000000000 --- a/gfsphysics/physics/radiation_clouds.f +++ /dev/null @@ -1,3408 +0,0 @@ -!> \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, imp_physics, me ) ! -! outputs: ! -! ( none ) ! -! ! -! 'progcld1' --- zhao/moorthi prognostic cloud scheme ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, ! -! IX, NLAY, NLP1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! effrl,effri,effrr,effrs,effr_in, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! 'progcld2' --- ferrier prognostic cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, ! -! IX, NLAY, NLP1, lmfshal, lmfdeep2, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! deltaq,sup,kdt,me, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! 'progcld4' --- gfdl-lin cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! -! xlat,xlon,slmsk, dz, delp, ! -! ix, nlay, nlp1, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! 'progcld4o' --- inactive ! -! ! -! 'progcld5' --- thompson/wsm6 cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk, dz, delp, ! -! ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, ! -! ix, nlay, nlp1, ! -! uni_cld, lmfshal, lmfdeep2, cldcov, ! -! re_cloud,re_ice,re_snow, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! 'progclduni' --- for unified clouds with MG microphys! -! inputs: ! -! (plyr,plvl,tlyr,tvly,ccnd,ncnd, ! -! xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, ! -! effrl,effri,effrr,effrs,effr_in, ! -! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! -! ! -! internal accessable only subroutines: ! -! 'gethml' --- get diagnostic hi, mid, low clouds ! -! ! -! ! -! cloud array description: ! -! 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)! -! ! -! 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 ! -! feb 2017 a. cheng - add odepth output, effective radius input ! -! Jan 2018 S Moorthi - update to include physics from ipdv4 ! -! jun 2018 h-m lin/y-t hou - removed the legacy subroutine ! -! 'diagcld1' for diagnostic cloud scheme, added new cloud ! -! overlapping method of de-correlation length, and optimized ! -! the code structure. ! -! ! -!!!!! ========================================================== !!!!! -!!!!! 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 -!! - progcld4() --- gfdl-lin cloud microphysics -!! - progcld5() --- thompson/wsm6 cloud microphysics -!! - progclduni() --- unified clouds with MG microphys -!! -!! and one internally accessable only subroutines: -!! - gethml() --- get diagnostic hi, mid, low,total,BL clouds -!! -!> \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 Cloud properties in the GFS model are derived from atmospheric -!! condition and cloud condensate amount(NCEP Office Note 441). Cloud -!! condensate information can be provided by one of the choices of -!! different cloud microphysics built in the model. The legacy version -!! of diagnostic cloud scheme in the early GFS has been discontinued. -!! \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, 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 - -!> 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 - -!> upper limit of boundary layer clouds - integer :: llyr = 2 -!> maximum-random cloud overlapping method - integer :: iovr = 1 - - public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld4o - - -! ================= - 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, imp_physics, 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 ! -! imp_physics : MP identifier ! -! me : print control flag ! -! ! -! outputs: (none) ! -! to module variables ! -! ! -! external module variables: (in physparam) ! -! icldflg : cloud optical property scheme control flag ! -! =0: abort! diagnostic cloud method discontinued ! -! =1: model use prognostic cloud method ! -! imp_physics : cloud microphysics scheme control flag ! -! =99: zhao/carr/sundqvist microphysics cloud ! -! =98: zhao/carr/sundqvist microphysics cloud+pdfcld! -! =11: GFDL microphysics cloud ! -! =8: Thompson microphysics ! -! =6: WSM6 microphysics ! -! =10: MG microphysics ! -! iovrsw/iovrlw : sw/lw control flag for cloud overlapping scheme ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! =2: maximum overlap clouds (mcica only) ! -! =3: decorrelation-length overlap (mcica only) ! -! 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, imp_physics - - 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 - print *,' - Diagnostic Cloud Method has been discontinued' - stop - - else - if (me == 0) then - print *,' - Using Prognostic Cloud Method' - if (imp_physics == 99) then - print *,' --- Zhao/Carr/Sundqvist microphysics' - elseif (imp_physics == 98) then - print *,' --- zhao/carr/sundqvist + pdf cloud' - elseif (imp_physics == 11) then - print *,' --- GFDL Lin cloud microphysics' - elseif (imp_physics == 8) then - print *,' --- Thompson cloud microphysics' - elseif (imp_physics == 6) then - print *,' --- WSM6 cloud microphysics' - elseif (imp_physics == 10) then - print *,' --- MG cloud microphysics' - else - print *,' !!! ERROR in cloud microphysc specification!!!', & - & ' imp_physics (NP3D) =',imp_physics - 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 dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\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 -!!\param de_lgth (IX), clouds decorrelation length (km) -!>\section gen_progcld1 General Algorithm -!> @{ -!----------------------------------- - subroutine progcld1 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & effrl,effri,effrr,effrs,effr_in, & - & clouds,clds,mtop,mbot,de_lgth & ! --- 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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, effr_in - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & - & effrl, effri, effrr, effrs - - 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - 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, clwf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - 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 - - if(effr_in) then - 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) = effrl (i,k) - rei (i,k) = effri (i,k) - rer (i,k) = effrr (i,k) - res (i,k) = effrs (i,k) - tem2d (i,k) = min(1.0, max(0.0,(con_ttp-tlyr(i,k))*0.05)) - clwf(i,k) = 0.0 - enddo - enddo - else - 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 - endif -! - 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - - do k = 1, NLAY - do i = 1, IX - 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 - -!> -# Compute effective liquid cloud droplet radius over land. - - if(.not. effr_in) then - 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 - endif - - 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. - - 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 ! 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. - - if(.not.effr_in) then - 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 - endif - -! - 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) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -!> -# 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, dz, de_lgth, & - & 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 dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\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 -!!\param de_lgth (IX), clouds decorrelation length (km) -!>\section gen_progcld2 General Algorithm -!> @{ -!----------------------------------- - subroutine progcld2 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, & - & IX, NLAY, NLP1, lmfshal, lmfdeep2, & - & clouds,clds,mtop,mbot,de_lgth & ! --- 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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, & - & dz, delp - - 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - 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), rxlat(ix) - - 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-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 & - & ) - - - do k = 1, NLAY - do i = 1, IX - tem2d(i,k) = (con_g * plyr(i,k)) & - & / (con_rd* delp(i,k)) - enddo - enddo - -!> -# Calculate layer cloud fraction. - - 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 - - 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) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -!> -# 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, dz, de_lgth, & - & 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 dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\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 -!!\param de_lgth (ix), clouds decorrelation length (km) -!!\section gen_progcld3 General Algorithm -!> @{ -!----------------------------------- - subroutine progcld3 & - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: - & xlat,xlon,slmsk, dz, delp, & - & ix, nlay, nlp1, & - & deltaq,sup,kdt,me, & - & clouds,clds,mtop,mbot,de_lgth & ! --- 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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, dz, delp -! & 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - 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, clwf - - real (kind=kind_phys) :: ptop1(ix,nk_clds+1), rxlat(ix) - - 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, ix - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ - - do k = 1, nlay - do i = 1, ix - 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 - -!> -# 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. - - 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 - - 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) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -!> -# 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, dz, de_lgth, & - & ix,nlay, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld3 -!----------------------------------- - - -!----------------------------------- - subroutine progcld4 & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & - & xlat,xlon,slmsk,cldtot, dz, delp, & - & IX, NLAY, NLP1, & -! --- outputs: - & clouds,clds,mtop,mbot,de_lgth & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld4 computes cloud related quantities using ! -! GFDL Lin MP 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 progcld4 ! -! ! -! 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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, cnvw, cnvc, & - & delp, dz - - 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -! --- compute liquid/ice condensate path in g/m**2 - - do k = 1, NLAY - do i = 1, IX - 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 - -! --- 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) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -! --- 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, dz, de_lgth, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld4 -!----------------------------------- - -!----------------------------------- - subroutine progcld4o & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & - & xlat,xlon,slmsk, dz, delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & - & IX, NLAY, NLP1, & -! --- outputs: - & clouds,clds,mtop,mbot,de_lgth & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld4o computes cloud related quantities using ! -! GFDL Lin MP prognostic cloud microphysics scheme. Moist species ! -! from MP are fed into the corresponding arrays for calcuation of ! -! ! -! 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 progcld4o ! -! ! -! 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,NTRAC) : 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & - & ntclamt - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, delp, dz - - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw - 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot - - 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 ) ) - cldtot(i,k) = clw(i,k,ntclamt) - enddo - enddo - -! --- 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -! --- compute liquid/ice condensate path in g/m**2 - - do k = 1, NLAY - do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) - enddo - enddo - -! --- 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) = crp(i,k) - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) - clouds(i,k,9) = rei(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -! --- 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, dz, de_lgth, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld4o -!----------------------------------- - -!----------------------------------- - - subroutine progcld5 & - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & - & IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & re_cloud,re_ice,re_snow, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld5 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, ! -! 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 progcld5 ! -! ! -! 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,ntrac) : 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & - & re_cloud, re_ice, re_snow - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - 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 - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - 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, clwf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - 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) = re_cloud(i,k) - rei (i,k) = re_ice(i,k) - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = re_snow(i,K) -! 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 - - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) - enddo - enddo -!> -# 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - - do k = 1, NLAY - do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) - enddo - 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. - - 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 ! 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 - -! - 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) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -!> -# 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, dz, de_lgth, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld5 -!................................... - -!> @} - -!> 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 dz (IX,NLAY), layer thickness (km) -!!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) -!!\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 -!!\param de_lgth (IX), clouds decorrelation length (km) -!>\section gen_progclduni General Algorithm -!> @{ -!----------------------------------- - subroutine progclduni & - & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & - & effrl,effri,effrr,effrs,effr_in, & - & clouds,clds,mtop,mbot,de_lgth & ! --- 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 ! -! ccnd (IX,NLAY,ncnd) : layer cloud condensate amount ! -! water, ice, rain, snow (+ graupel) ! -! ncnd : number of layer cloud condensate types (max of 4) ! -! 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 ! -! cldtot : unified cloud fracrion from moist physics ! -! effrl (ix,nlay) : effective radius for liquid water ! -! effri (ix,nlay) : effective radius for ice water ! -! effrr (ix,nlay) : effective radius for rain water ! -! effrs (ix,nlay) : effective radius for snow water ! -! effr_in : logical - if .true. use input effective radii ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! ! -! 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 ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! 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, ncnd - logical, intent(in) :: effr_in - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr,& - & tlyr, tvly, cldtot, effrl, effri, effrr, effrs, dz, delp - - 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 - - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & - & crp, csp, rew, rei, res, rer - real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - real (kind=kind_phys) :: tem1, tem2, tem3 - - integer :: i, k, id, nf, n - -! -!===> ... begin here -! -! do nf=1,nf_clds -! do k=1,nlay -! do i=1,ix -! clouds(i,k,nf) = 0.0 -! enddo -! enddo -! enddo -! - 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 - enddo - enddo - do n=1,ncnd - do k = 1, NLAY - do i = 1, IX - cndf(i,k,n) = ccnd(i,k,n) - enddo - enddo - enddo - if ( lcrick ) then ! vertical smoorthing - do n=1,ncnd - do i = 1, IX - cndf(i,1,n) = 0.75*ccnd(i,1,n) + 0.25*ccnd(i,2,n) - cndf(i,nlay,n) = 0.75*ccnd(i,nlay,n) + 0.25*ccnd(i,nlay-1,n) - enddo - do k = 2, NLAY-1 - do i = 1, IX - cndf(i,K,n) = 0.25 * (ccnd(i,k-1,n) + ccnd(i,k+1,n)) & - & + 0.5 * ccnd(i,k,n) - enddo - enddo - enddo - endif - -!> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - - if (ncnd == 2) then - do k = 1, NLAY - do i = 1, IX - tem1 = gfac * delp(i,k) - cwp(i,k) = cndf(i,k,1) * tem1 - cip(i,k) = cndf(i,k,2) * tem1 - enddo - enddo - elseif (ncnd == 4) then - do k = 1, NLAY - do i = 1, IX - tem1 = gfac * delp(i,k) - cwp(i,k) = cndf(i,k,1) * tem1 - cip(i,k) = cndf(i,k,2) * tem1 - crp(i,k) = cndf(i,k,3) * tem1 - csp(i,k) = cndf(i,k,4) * tem1 - enddo - enddo - endif - - 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 - -! assign/calculate efective radii for cloud water, ice, rain, snow - - if (effr_in) then - do k = 1, NLAY - do i = 1, IX - rew(i,k) = effrl (i,k) - rei(i,k) = max(10.0, min(150.0,effri (i,k))) - rer(i,k) = effrr (i,k) - res(i,k) = effrs (i,k) - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - 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 - enddo - enddo -!> -# Compute effective liquid cloud droplet radius over land. - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - tem1 = min(1.0, max(0.0, (con_ttp-tlyr(i,k))*0.05)) - rew(i,k) = 5.0 + 5.0 * tem1 - enddo - endif - enddo - -!> -# 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 - endif -! - 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 - -!> -# 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 i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later - - if ( iovr == 3 ) then - do i = 1, ix - de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) - enddo - endif - -!> -# 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, dz, de_lgth, & - & IX,NLAY, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progclduni -!----------------------------------- -!> @} - - -!> 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 dz (IX,NLAY), layer thickness (km) -!> \param de_lgth (IX), clouds decorrelation length (km) -!> \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, dz, de_lgth, & ! --- 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) ! -! dz (ix,nlay) : layer thickness (km) ! -! de_lgth(ix) : clouds vertical de-correlation length (km) ! -! 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 ! -! =2 maximum overlapping ( for mcica only ) ! -! =3 decorr-length ovlp ( for mcica only ) ! -! ! -! ==================== end of description ===================== ! -! - implicit none! - -! --- inputs: - integer, intent(in) :: IX, NLAY - - real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & - & cldtot, cldcnv, dz - real (kind=kind_phys), dimension(:), intent(in) :: de_lgth - -! --- 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), dz1(ix) - real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt, alfa - - 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 - - elseif ( iovr == 1 ) then ! 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 - - elseif ( iovr == 2 ) then ! maximum overlap all levels - - cl1(:) = 0.0 - - do k = kstr, kend, kinc - do i = 1, IX - ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) - if (ccur >= climit) cl1(i) = max( cl1(i), ccur ) - enddo - - if (k == llyr) then - do i = 1, IX - clds(i,5) = cl1(i) ! save bl cloud - enddo - endif - enddo - - do i = 1, IX - clds(i,4) = cl1(i) ! save total cloud - enddo - - elseif ( iovr == 3 ) then ! random if clear-layer divided, - ! otherwise de-corrlength method - do i = 1, ix - dz1(i) = - dz(i,kstr) - enddo - - 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 - alfa = exp( -0.5*((dz1(i)+dz(i,k)))/de_lgth(i) ) - dz1(i) = dz(i,k) - cl2(i) = alfa * min(cl2(i), (1.0 - ccur)) & ! maximum part - & + (1.0 - alfa) * (cl2(i) * (1.0 - ccur)) ! random part - else ! clear layer - cl1(i) = cl1(i) * cl2(i) - cl2(i) = 1.0 - if (k /= kend) dz1(i) = -dz(i,k+kinc) - 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 -!----------------------------------- -!! @} - -! -!........................................! - end module module_radiation_clouds ! -!========================================! -!> @} diff --git a/gfsphysics/physics/radiation_gases.f b/gfsphysics/physics/radiation_gases.f deleted file mode 100644 index 79e049e1a..000000000 --- a/gfsphysics/physics/radiation_gases.f +++ /dev/null @@ -1,1169 +0,0 @@ -!> \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*26 - 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(19:22),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(19:22),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/gfsphysics/physics/radiation_surface.f b/gfsphysics/physics/radiation_surface.f deleted file mode 100644 index 9ae258a0c..000000000 --- a/gfsphysics/physics/radiation_surface.f +++ /dev/null @@ -1,839 +0,0 @@ -!> \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'. ! -! jun 2018 h-m lin/y-t hou - correct error in clim-scheme of ! -! weak/strong factor and restore to the orig form ! -! ! -!!!!! ========================================================== !!!!! -!!!!! 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 - use surface_perturbation, only : ppfbet -! - 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, & - & albPpert, pertalb, & ! sfc-perts, mgehne - & 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, albPpert ! sfc-perts, mgehne - real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne - -! --- 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, m, s, alpha, beta, albtmp - - real (kind=kind_phys) ffw, dtgd - - integer :: i, k, kk, iflag - -! -!===> ... 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.1 / (f_one + 0.2*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 - 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 -! - -! sfc-perts, mgehne *** -! perturb all 4 kinds of surface albedo, sfcalb(:,1:4) - if (pertalb>0.0) then - do i = 1, imax - do kk=1, 4 - ! compute beta distribution parameters for all 4 albedos - m = sfcalb(i,kk) - s = pertalb*m*(1.-m) - alpha = m*m*(1.-m)/(s*s)-m - beta = alpha*(1.-m)/m - ! compute beta distribution value corresponding - ! to the given percentile albPpert to use as new albedo - call ppfbet(albPpert(i),alpha,beta,iflag,albtmp) - sfcalb(i,kk) = albtmp - enddo - enddo ! end_do_i_loop - endif - -! *** sfc-perts, mgehne - - - 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/gfsphysics/physics/radlw_datatb.f b/gfsphysics/physics/radlw_datatb.f deleted file mode 100644 index 622b72b03..000000000 --- a/gfsphysics/physics/radlw_datatb.f +++ /dev/null @@ -1,32462 +0,0 @@ -!> \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/gfsphysics/physics/radlw_main.f b/gfsphysics/physics/radlw_main.f deleted file mode 100644 index dae7329bb..000000000 --- a/gfsphysics/physics/radlw_main.f +++ /dev/null @@ -1,6755 +0,0 @@ -!> \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, ! -! dzlyr,delpin,de_lgth, ! -! npts, nlay, nlp1, lprnt, ! -! outputs: ! -! hlwc,topflx,sfcflx,cldtau, ! -!! 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'. ! -! FEB 2017 A.Cheng - add odpth output, effective radius input ! -! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! -! method 'de-correlation-length' for mcica application ! -! ! -!!!!! ============================================================== !!!!! -!!!!! 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 dzlyr layer thickness (km) -!!\param delpin layer pressure thickness (mb) -!!\param de_lgth cloud decorrelation length (km) -!!\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 cldtau spectral band layer cloud optical depth (approx 10 mu) -!!\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, & - & dzlyr,delpin,de_lgth, & - & npts, nlay, nlp1, lprnt, & - & hlwc,topflx,sfcflx,cldtau, & ! --- 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) ! -! 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) ! -! 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) ! -! dzlyr(npts,nlay) : layer thickness (km) ! -! delpin(npts,nlay): layer pressure thickness (mb) ! -! de_lgth(npts) : cloud decorrelation length (km) ! -! 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) ! -! cldtau(npts,nlay): approx 10mu band layer cloud optical depth ! -! ! -!! 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 ! -! =1: input cld liqp & reliq, hu & stamnes (1993) ! -! =2: not used ! -! ilwcice - control flag for ice-cloud optical properties ! -! =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) ! -! =3: decorrelation-length overlap (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, dzlyr, delpin - - 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, de_lgth - - real (kind=kind_phys), dimension(npts,nlay,nbands,3),intent(in):: & - & aerosols - -! --- outputs: - real (kind=kind_phys), dimension(npts,nlay), intent(out) :: hlwc - real (kind=kind_phys), dimension(npts,nlay), intent(out) :: cldtau - - 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, dz - - 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, & - & delgth - - 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 - cldtau(:,:) = 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 - if (iovrlw == 3) delgth= de_lgth(iplon) ! clouds decorr-length - -!> -# 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) = delpin(iplon,k1) - tavel(k)= tlyr(iplon,k1) - tz(k) = tlvl(iplon,k1) - dz(k) = dzlyr(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) = delpin(iplon,k) - tavel(k)= tlyr(iplon,k) - tz(k) = tlvl(iplon,k+1) - dz(k) = dzlyr(iplon,k) - -! --- ... 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), dz, delgth, & -! --- outputs: - & cldfmc, taucld & - & ) - -! --- ... save computed layer cloud optical depth for output -! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) - - if (ivflip == 0) then ! input from toa to sfc - do k = 1, nlay - k1 = nlp1 - k - cldtau(iplon,k1) = taucld( 7,k) - enddo - else ! input from sfc to toa - do k = 1, nlay - cldtau(iplon,k) = taucld( 7,k) - enddo - endif ! end if_ivflip_block - - 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) ! -! =3: decorrelation-length overlap (for isubclw>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>3 ) 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=',iovrlw,' is not 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, dz, de_lgth, & - & 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 ! -! ! -! dz - real, layer thickness (km) nlay ! -! de_lgth- real, layer cloud decorrelation length (km) 1 ! -! 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, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- 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, dz, de_lgth, & -! --- 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, dz, de_lgth, &! --- 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. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth - real, layer cloud decorrelation length (km) 1 ! -! ! -! 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; =3:decorr ! -! ! -! ===================== end of definitions ==================== ! - - implicit none - -! --- inputs: - integer, intent(in) :: nlay, ipseed - - real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- outputs: - logical, dimension(ngptlw,nlay), intent(out) :: lcloudy - -! --- locals: - real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & - & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & - & cdfun2(ngptlw,nlay) - - 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 - - case( 3 ) ! decorrelation length overlap - -! --- compute overlapping factors based on layer midpoint distances -! and decorrelation depths - - do k = nlay, 2, -1 - fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) - enddo - -! --- setup 2 sets of random numbers - - call random_number ( rand2d, stat ) - - k1 = 0 - do k = 1, nlay - do n = 1, ngptlw - k1 = k1 + 1 - cdfunc(n,k) = rand2d(k1) - enddo - enddo - - call random_number ( rand2d, stat ) - - k1 = 0 - do k = 1, nlay - do n = 1, ngptlw - k1 = k1 + 1 - cdfun2(n,k) = rand2d(k1) - enddo - enddo - -! --- then working from the top down: -! if a random number (from an independent set -cdfun2) is smaller then the -! scale factor: use the upper layer's number, otherwise use a new random -! number (keep the original assigned one). - - do k = nlay-1, 1, -1 - k1 = k + 1 - - do n = 1, ngptlw - if ( cdfun2(n,k) <= fac_lcf(k1) ) then - cdfunc(n,k) = cdfunc(n,k1) - endif - 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/gfsphysics/physics/radlw_param.f b/gfsphysics/physics/radlw_param.f deleted file mode 100644 index 3f1fe92ba..000000000 --- a/gfsphysics/physics/radlw_param.f +++ /dev/null @@ -1,162 +0,0 @@ -!> \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., 350., 500., 630., 700., 820., 980., 1080., & - & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. / - 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/gfsphysics/physics/radsw_datatb.f b/gfsphysics/physics/radsw_datatb.f deleted file mode 100644 index 9188d889f..000000000 --- a/gfsphysics/physics/radsw_datatb.f +++ /dev/null @@ -1,22641 +0,0 @@ -!> \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 ! -! jun 2018 -- h-m lin/y-t hou updated with aer's newer ! -! version of v3.9-v4.0 liq cloud optical property ! -! coeffs for hu and stamnes scheme ! -! ! -! ********* 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! -! xxxliq2 (updated) 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) -!>\name updated Hu and Stamnes (1993) coef for cloud liquid condensate (used if iswcliq=2) - -!> extinction coefficients - real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & - & extliq1, extliq2 -!> single scattering albedo coefficients - real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & - & ssaliq1, ssaliq2 -!> asymmetry coefficients - real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & - & asyliq1, asyliq2 - -!>\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 / - -! --- ... updated extinction coefficient from hu and stamnes - data extliq2(:, 16) / & - & 9.004493E-01,6.366723E-01,4.542354E-01,3.468253E-01,2.816431E-01,& - & 2.383415E-01,2.070854E-01,1.831854E-01,1.642115E-01,1.487539E-01,& - & 1.359169E-01,1.250900E-01,1.158354E-01,1.078400E-01,1.008646E-01,& - & 9.472307E-02,8.928000E-02,8.442308E-02,8.005924E-02,7.612231E-02,& - & 7.255153E-02,6.929539E-02,6.631769E-02,6.358153E-02,6.106231E-02,& - & 5.873077E-02,5.656924E-02,5.455769E-02,5.267846E-02,5.091923E-02,& - & 4.926692E-02,4.771154E-02,4.623923E-02,4.484385E-02,4.351539E-02,& - & 4.224615E-02,4.103385E-02,3.986538E-02,3.874077E-02,3.765462E-02,& - & 3.660077E-02,3.557384E-02,3.457615E-02,3.360308E-02,3.265000E-02,& - & 3.171770E-02,3.080538E-02,2.990846E-02,2.903000E-02,2.816461E-02,& - & 2.731539E-02,2.648231E-02,2.566308E-02,2.485923E-02,2.407000E-02,& - & 2.329615E-02,2.253769E-02,2.179615E-02 / - data extliq2(:, 17) / & - & 6.741200e-01,5.390739e-01,4.198767e-01,3.332553e-01,2.735633e-01,& - & 2.317727e-01,2.012760e-01,1.780400e-01,1.596927e-01,1.447980e-01,& - & 1.324480e-01,1.220347e-01,1.131327e-01,1.054313e-01,9.870534e-02,& - & 9.278200e-02,8.752599e-02,8.282933e-02,7.860600e-02,7.479133e-02,& - & 7.132800e-02,6.816733e-02,6.527401e-02,6.261266e-02,6.015934e-02,& - & 5.788867e-02,5.578134e-02,5.381667e-02,5.198133e-02,5.026067e-02,& - & 4.864466e-02,4.712267e-02,4.568066e-02,4.431200e-02,4.300867e-02,& - & 4.176600e-02,4.057400e-02,3.942534e-02,3.832066e-02,3.725068e-02,& - & 3.621400e-02,3.520533e-02,3.422333e-02,3.326400e-02,3.232467e-02,& - & 3.140535e-02,3.050400e-02,2.962000e-02,2.875267e-02,2.789800e-02,& - & 2.705934e-02,2.623667e-02,2.542667e-02,2.463200e-02,2.385267e-02,& - & 2.308667e-02,2.233667e-02,2.160067e-02 / - data extliq2(:, 18) / & - & 9.250861e-01,6.245692e-01,4.347038e-01,3.320208e-01,2.714869e-01,& - & 2.309516e-01,2.012592e-01,1.783315e-01,1.600369e-01,1.451000e-01,& - & 1.326838e-01,1.222069e-01,1.132554e-01,1.055146e-01,9.876000e-02,& - & 9.281386e-02,8.754000e-02,8.283078e-02,7.860077e-02,7.477769e-02,& - & 7.130847e-02,6.814461e-02,6.524615e-02,6.258462e-02,6.012847e-02,& - & 5.785462e-02,5.574231e-02,5.378000e-02,5.194461e-02,5.022462e-02,& - & 4.860846e-02,4.708462e-02,4.564154e-02,4.427462e-02,4.297231e-02,& - & 4.172769e-02,4.053693e-02,3.939000e-02,3.828462e-02,3.721692e-02,& - & 3.618000e-02,3.517077e-02,3.418923e-02,3.323077e-02,3.229154e-02,& - & 3.137154e-02,3.047154e-02,2.959077e-02,2.872308e-02,2.786846e-02,& - & 2.703077e-02,2.620923e-02,2.540077e-02,2.460615e-02,2.382693e-02,& - & 2.306231e-02,2.231231e-02,2.157923e-02 / - data extliq2(:, 19) / & - & 9.298960e-01,5.776460e-01,4.083450e-01,3.211160e-01,2.666390e-01,& - & 2.281990e-01,1.993250e-01,1.768080e-01,1.587810e-01,1.440390e-01,& - & 1.317720e-01,1.214150e-01,1.125540e-01,1.048890e-01,9.819600e-02,& - & 9.230201e-02,8.706900e-02,8.239698e-02,7.819500e-02,7.439899e-02,& - & 7.095300e-02,6.780700e-02,6.492900e-02,6.228600e-02,5.984600e-02,& - & 5.758599e-02,5.549099e-02,5.353801e-02,5.171400e-02,5.000500e-02,& - & 4.840000e-02,4.688500e-02,4.545100e-02,4.409300e-02,4.279700e-02,& - & 4.156100e-02,4.037700e-02,3.923800e-02,3.813800e-02,3.707600e-02,& - & 3.604500e-02,3.504300e-02,3.406500e-02,3.310800e-02,3.217700e-02,& - & 3.126600e-02,3.036800e-02,2.948900e-02,2.862400e-02,2.777500e-02,& - & 2.694200e-02,2.612300e-02,2.531700e-02,2.452800e-02,2.375100e-02,& - & 2.299100e-02,2.224300e-02,2.151201e-02 / - data extliq2(:, 20) / & - & 8.780964e-01,5.407031e-01,3.961100e-01,3.166645e-01,2.640455e-01,& - & 2.261070e-01,1.974820e-01,1.751775e-01,1.573415e-01,1.427725e-01,& - & 1.306535e-01,1.204195e-01,1.116650e-01,1.040915e-01,9.747550e-02,& - & 9.164800e-02,8.647649e-02,8.185501e-02,7.770200e-02,7.394749e-02,& - & 7.053800e-02,6.742700e-02,6.457999e-02,6.196149e-02,5.954450e-02,& - & 5.730650e-02,5.522949e-02,5.329450e-02,5.148500e-02,4.979000e-02,& - & 4.819600e-02,4.669301e-02,4.527050e-02,4.391899e-02,4.263500e-02,& - & 4.140500e-02,4.022850e-02,3.909500e-02,3.800199e-02,3.694600e-02,& - & 3.592000e-02,3.492250e-02,3.395050e-02,3.300150e-02,3.207250e-02,& - & 3.116250e-02,3.027100e-02,2.939500e-02,2.853500e-02,2.768900e-02,& - & 2.686000e-02,2.604350e-02,2.524150e-02,2.445350e-02,2.368049e-02,& - & 2.292150e-02,2.217800e-02,2.144800e-02 / - data extliq2(:, 21) / & - & 7.937480e-01,5.123036e-01,3.858181e-01,3.099622e-01,2.586829e-01,& - & 2.217587e-01,1.939755e-01,1.723397e-01,1.550258e-01,1.408600e-01,& - & 1.290545e-01,1.190661e-01,1.105039e-01,1.030848e-01,9.659387e-02,& - & 9.086775e-02,8.577807e-02,8.122452e-02,7.712711e-02,7.342193e-02,& - & 7.005387e-02,6.697840e-02,6.416000e-02,6.156903e-02,5.917484e-02,& - & 5.695807e-02,5.489968e-02,5.298097e-02,5.118806e-02,4.950645e-02,& - & 4.792710e-02,4.643581e-02,4.502484e-02,4.368547e-02,4.241001e-02,& - & 4.118936e-02,4.002193e-02,3.889711e-02,3.781322e-02,3.676387e-02,& - & 3.574549e-02,3.475548e-02,3.379033e-02,3.284678e-02,3.192420e-02,& - & 3.102032e-02,3.013484e-02,2.926258e-02,2.840839e-02,2.756742e-02,& - & 2.674258e-02,2.593064e-02,2.513258e-02,2.435000e-02,2.358064e-02,& - & 2.282581e-02,2.208548e-02,2.135936e-02 / - data extliq2(:, 22) / & - & 7.533129e-01,5.033129e-01,3.811271e-01,3.062757e-01,2.558729e-01,& - & 2.196828e-01,1.924372e-01,1.711714e-01,1.541086e-01,1.401114e-01,& - & 1.284257e-01,1.185200e-01,1.100243e-01,1.026529e-01,9.620142e-02,& - & 9.050714e-02,8.544428e-02,8.091714e-02,7.684000e-02,7.315429e-02,& - & 6.980143e-02,6.673999e-02,6.394000e-02,6.136000e-02,5.897715e-02,& - & 5.677000e-02,5.472285e-02,5.281286e-02,5.102858e-02,4.935429e-02,& - & 4.778000e-02,4.629714e-02,4.489142e-02,4.355857e-02,4.228715e-02,& - & 4.107285e-02,3.990857e-02,3.879000e-02,3.770999e-02,3.666429e-02,& - & 3.565000e-02,3.466286e-02,3.370143e-02,3.276143e-02,3.184143e-02,& - & 3.094000e-02,3.005714e-02,2.919000e-02,2.833714e-02,2.750000e-02,& - & 2.667714e-02,2.586714e-02,2.507143e-02,2.429143e-02,2.352428e-02,& - & 2.277143e-02,2.203429e-02,2.130857e-02 / - data extliq2(:, 23) / & - & 7.079894e-01,4.878198e-01,3.719852e-01,3.001873e-01,2.514795e-01,& - & 2.163013e-01,1.897100e-01,1.689033e-01,1.521793e-01,1.384449e-01,& - & 1.269666e-01,1.172326e-01,1.088745e-01,1.016224e-01,9.527085e-02,& - & 8.966240e-02,8.467543e-02,8.021144e-02,7.619344e-02,7.255676e-02,& - & 6.924996e-02,6.623030e-02,6.346261e-02,6.091499e-02,5.856325e-02,& - & 5.638385e-02,5.435930e-02,5.247156e-02,5.070699e-02,4.905230e-02,& - & 4.749499e-02,4.602611e-02,4.463581e-02,4.331543e-02,4.205647e-02,& - & 4.085241e-02,3.969978e-02,3.859033e-02,3.751877e-02,3.648168e-02,& - & 3.547468e-02,3.449553e-02,3.354072e-02,3.260732e-02,3.169438e-02,& - & 3.079969e-02,2.992146e-02,2.905875e-02,2.821201e-02,2.737873e-02,& - & 2.656052e-02,2.575586e-02,2.496511e-02,2.418783e-02,2.342500e-02,& - & 2.267646e-02,2.194177e-02,2.122146e-02 / - data extliq2(:, 24) / & - & 6.850164e-01,4.762468e-01,3.642001e-01,2.946012e-01,2.472001e-01,& - & 2.128588e-01,1.868537e-01,1.664893e-01,1.501142e-01,1.366620e-01,& - & 1.254147e-01,1.158721e-01,1.076732e-01,1.005530e-01,9.431306e-02,& - & 8.879891e-02,8.389232e-02,7.949714e-02,7.553857e-02,7.195474e-02,& - & 6.869413e-02,6.571444e-02,6.298286e-02,6.046779e-02,5.814474e-02,& - & 5.599141e-02,5.399114e-02,5.212443e-02,5.037870e-02,4.874321e-02,& - & 4.720219e-02,4.574813e-02,4.437160e-02,4.306460e-02,4.181810e-02,& - & 4.062603e-02,3.948252e-02,3.838256e-02,3.732049e-02,3.629192e-02,& - & 3.529301e-02,3.432190e-02,3.337412e-02,3.244842e-02,3.154175e-02,& - & 3.065253e-02,2.978063e-02,2.892367e-02,2.808221e-02,2.725478e-02,& - & 2.644174e-02,2.564175e-02,2.485508e-02,2.408303e-02,2.332365e-02,& - & 2.257890e-02,2.184824e-02,2.113224e-02 / - data extliq2(:, 25) / & - & 6.673017e-01,4.664520e-01,3.579398e-01,2.902234e-01,2.439904e-01,& - & 2.104149e-01,1.849277e-01,1.649234e-01,1.488087e-01,1.355515e-01,& - & 1.244562e-01,1.150329e-01,1.069321e-01,9.989310e-02,9.372070e-02,& - & 8.826450e-02,8.340622e-02,7.905378e-02,7.513109e-02,7.157859e-02,& - & 6.834588e-02,6.539114e-02,6.268150e-02,6.018621e-02,5.788098e-02,& - & 5.574351e-02,5.375699e-02,5.190412e-02,5.017099e-02,4.854497e-02,& - & 4.701490e-02,4.557030e-02,4.420249e-02,4.290304e-02,4.166427e-02,& - & 4.047820e-02,3.934232e-02,3.824778e-02,3.719236e-02,3.616931e-02,& - & 3.517597e-02,3.420856e-02,3.326566e-02,3.234346e-02,3.144122e-02,& - & 3.055684e-02,2.968798e-02,2.883519e-02,2.799635e-02,2.717228e-02,& - & 2.636182e-02,2.556424e-02,2.478114e-02,2.401086e-02,2.325657e-02,& - & 2.251506e-02,2.178594e-02,2.107301e-02 / - data extliq2(:, 26) / & - & 6.552414e-01,4.599454e-01,3.538626e-01,2.873547e-01,2.418033e-01,& - & 2.086660e-01,1.834885e-01,1.637142e-01,1.477767e-01,1.346583e-01,& - & 1.236734e-01,1.143412e-01,1.063148e-01,9.933905e-02,9.322026e-02,& - & 8.780979e-02,8.299230e-02,7.867554e-02,7.478450e-02,7.126053e-02,& - & 6.805276e-02,6.512143e-02,6.243211e-02,5.995541e-02,5.766712e-02,& - & 5.554484e-02,5.357246e-02,5.173222e-02,5.001069e-02,4.839505e-02,& - & 4.687471e-02,4.543861e-02,4.407857e-02,4.278577e-02,4.155331e-02,& - & 4.037322e-02,3.924302e-02,3.815376e-02,3.710172e-02,3.608296e-02,& - & 3.509330e-02,3.412980e-02,3.319009e-02,3.227106e-02,3.137157e-02,& - & 3.048950e-02,2.962365e-02,2.877297e-02,2.793726e-02,2.711500e-02,& - & 2.630666e-02,2.551206e-02,2.473052e-02,2.396287e-02,2.320861e-02,& - & 2.246810e-02,2.174162e-02,2.102927e-02 / - data extliq2(:, 27) / & - & 6.430901e-01,4.532134e-01,3.496132e-01,2.844655e-01,2.397347e-01,& - & 2.071236e-01,1.822976e-01,1.627640e-01,1.469961e-01,1.340006e-01,& - & 1.231069e-01,1.138441e-01,1.058706e-01,9.893678e-02,9.285166e-02,& - & 8.746871e-02,8.267411e-02,7.837656e-02,7.450257e-02,7.099318e-02,& - & 6.779929e-02,6.487987e-02,6.220168e-02,5.973530e-02,5.745636e-02,& - & 5.534344e-02,5.337986e-02,5.154797e-02,4.983404e-02,4.822582e-02,& - & 4.671228e-02,4.528321e-02,4.392997e-02,4.264325e-02,4.141647e-02,& - & 4.024259e-02,3.911767e-02,3.803309e-02,3.698782e-02,3.597140e-02,& - & 3.498774e-02,3.402852e-02,3.309340e-02,3.217818e-02,3.128292e-02,& - & 3.040486e-02,2.954230e-02,2.869545e-02,2.786261e-02,2.704372e-02,& - & 2.623813e-02,2.544668e-02,2.466788e-02,2.390313e-02,2.315136e-02,& - & 2.241391e-02,2.168921e-02,2.097903e-02 / - data extliq2(:, 28) / & - & 6.367074e-01,4.495768e-01,3.471263e-01,2.826149e-01,2.382868e-01,& - & 2.059640e-01,1.813562e-01,1.619881e-01,1.463436e-01,1.334402e-01,& - & 1.226166e-01,1.134096e-01,1.054829e-01,9.858838e-02,9.253790e-02,& - & 8.718582e-02,8.241830e-02,7.814482e-02,7.429212e-02,7.080165e-02,& - & 6.762385e-02,6.471838e-02,6.205388e-02,5.959726e-02,5.732871e-02,& - & 5.522402e-02,5.326793e-02,5.144230e-02,4.973440e-02,4.813188e-02,& - & 4.662283e-02,4.519798e-02,4.384833e-02,4.256541e-02,4.134253e-02,& - & 4.017136e-02,3.904911e-02,3.796779e-02,3.692364e-02,3.591182e-02,& - & 3.492930e-02,3.397230e-02,3.303920e-02,3.212572e-02,3.123278e-02,& - & 3.035519e-02,2.949493e-02,2.864985e-02,2.781840e-02,2.700197e-02,& - & 2.619682e-02,2.540674e-02,2.462966e-02,2.386613e-02,2.311602e-02,& - & 2.237846e-02,2.165660e-02,2.094756e-02 / - data extliq2(:, 29) / & - & 4.298416e-01,4.391639e-01,3.975030e-01,3.443028e-01,2.957345e-01,& - & 2.556461e-01,2.234755e-01,1.976636e-01,1.767428e-01,1.595611e-01,& - & 1.452636e-01,1.332156e-01,1.229481e-01,1.141059e-01,1.064208e-01,& - & 9.968527e-02,9.373833e-02,8.845221e-02,8.372112e-02,7.946667e-02,& - & 7.561807e-02,7.212029e-02,6.893166e-02,6.600944e-02,6.332277e-02,& - & 6.084277e-02,5.854721e-02,5.641361e-02,5.442639e-02,5.256750e-02,& - & 5.082499e-02,4.918556e-02,4.763694e-02,4.617222e-02,4.477861e-02,& - & 4.344861e-02,4.217999e-02,4.096111e-02,3.978638e-02,3.865361e-02,& - & 3.755473e-02,3.649028e-02,3.545361e-02,3.444361e-02,3.345666e-02,& - & 3.249167e-02,3.154722e-02,3.062083e-02,2.971250e-02,2.882083e-02,& - & 2.794611e-02,2.708778e-02,2.624500e-02,2.541750e-02,2.460528e-02,& - & 2.381194e-02,2.303250e-02,2.226833e-02 / - -! --- ... updated single scattering albedo from hu and stamnes - data ssaliq2(:, 16) / & - & 8.362119e-01,8.098460e-01,7.762291e-01,7.486042e-01,7.294172e-01,& - & 7.161000e-01,7.060656e-01,6.978387e-01,6.907193e-01,6.843551e-01,& - & 6.785668e-01,6.732450e-01,6.683191e-01,6.637264e-01,6.594307e-01,& - & 6.554033e-01,6.516115e-01,6.480295e-01,6.446429e-01,6.414306e-01,& - & 6.383783e-01,6.354750e-01,6.327068e-01,6.300665e-01,6.275376e-01,& - & 6.251245e-01,6.228136e-01,6.205944e-01,6.184720e-01,6.164330e-01,& - & 6.144742e-01,6.125962e-01,6.108004e-01,6.090740e-01,6.074200e-01,& - & 6.058381e-01,6.043209e-01,6.028681e-01,6.014836e-01,6.001626e-01,& - & 5.988957e-01,5.976864e-01,5.965390e-01,5.954379e-01,5.943972e-01,& - & 5.934019e-01,5.924624e-01,5.915579e-01,5.907025e-01,5.898913e-01,& - & 5.891213e-01,5.883815e-01,5.876851e-01,5.870158e-01,5.863868e-01,& - & 5.857821e-01,5.852111e-01,5.846579e-01 / - data ssaliq2(:, 17) / & - & 6.995459e-01,7.158012e-01,7.076001e-01,6.927244e-01,6.786434e-01,& - & 6.673545e-01,6.585859e-01,6.516314e-01,6.459010e-01,6.410225e-01,& - & 6.367574e-01,6.329554e-01,6.295119e-01,6.263595e-01,6.234462e-01,& - & 6.207274e-01,6.181755e-01,6.157678e-01,6.134880e-01,6.113173e-01,& - & 6.092495e-01,6.072689e-01,6.053717e-01,6.035507e-01,6.018001e-01,& - & 6.001134e-01,5.984951e-01,5.969294e-01,5.954256e-01,5.939698e-01,& - & 5.925716e-01,5.912265e-01,5.899270e-01,5.886771e-01,5.874746e-01,& - & 5.863185e-01,5.852077e-01,5.841460e-01,5.831249e-01,5.821474e-01,& - & 5.812078e-01,5.803173e-01,5.794616e-01,5.786443e-01,5.778617e-01,& - & 5.771236e-01,5.764191e-01,5.757400e-01,5.750971e-01,5.744842e-01,& - & 5.739012e-01,5.733482e-01,5.728175e-01,5.723214e-01,5.718383e-01,& - & 5.713827e-01,5.709471e-01,5.705330e-01 / - data ssaliq2(:, 18) / & - & 9.929711e-01,9.896942e-01,9.852408e-01,9.806820e-01,9.764512e-01,& - & 9.725375e-01,9.688677e-01,9.653832e-01,9.620552e-01,9.588522e-01,& - & 9.557475e-01,9.527265e-01,9.497731e-01,9.468756e-01,9.440270e-01,& - & 9.412230e-01,9.384592e-01,9.357287e-01,9.330369e-01,9.303778e-01,& - & 9.277502e-01,9.251546e-01,9.225907e-01,9.200553e-01,9.175521e-01,& - & 9.150773e-01,9.126352e-01,9.102260e-01,9.078485e-01,9.055057e-01,& - & 9.031978e-01,9.009306e-01,8.987010e-01,8.965177e-01,8.943774e-01,& - & 8.922869e-01,8.902430e-01,8.882551e-01,8.863182e-01,8.844373e-01,& - & 8.826143e-01,8.808499e-01,8.791413e-01,8.774940e-01,8.759019e-01,& - & 8.743650e-01,8.728941e-01,8.714712e-01,8.701065e-01,8.688008e-01,& - & 8.675409e-01,8.663295e-01,8.651714e-01,8.640637e-01,8.629943e-01,& - & 8.619762e-01,8.609995e-01,8.600581e-01 / - data ssaliq2(:, 19) / & - & 9.910612e-01,9.854226e-01,9.795008e-01,9.742920e-01,9.695996e-01,& - & 9.652274e-01,9.610648e-01,9.570521e-01,9.531397e-01,9.493086e-01,& - & 9.455413e-01,9.418362e-01,9.381902e-01,9.346016e-01,9.310718e-01,& - & 9.275957e-01,9.241757e-01,9.208038e-01,9.174802e-01,9.142058e-01,& - & 9.109753e-01,9.077895e-01,9.046433e-01,9.015409e-01,8.984784e-01,& - & 8.954572e-01,8.924748e-01,8.895367e-01,8.866395e-01,8.837864e-01,& - & 8.809819e-01,8.782267e-01,8.755231e-01,8.728712e-01,8.702802e-01,& - & 8.677443e-01,8.652733e-01,8.628678e-01,8.605300e-01,8.582593e-01,& - & 8.560596e-01,8.539352e-01,8.518782e-01,8.498915e-01,8.479790e-01,& - & 8.461384e-01,8.443645e-01,8.426613e-01,8.410229e-01,8.394495e-01,& - & 8.379428e-01,8.364967e-01,8.351117e-01,8.337820e-01,8.325091e-01,& - & 8.312874e-01,8.301169e-01,8.289985e-01 / - data ssaliq2(:, 20) / & - & 9.969802e-01,9.950445e-01,9.931448e-01,9.914272e-01,9.898652e-01,& - & 9.884250e-01,9.870637e-01,9.857482e-01,9.844558e-01,9.831755e-01,& - & 9.819068e-01,9.806477e-01,9.794000e-01,9.781666e-01,9.769461e-01,& - & 9.757386e-01,9.745459e-01,9.733650e-01,9.721953e-01,9.710398e-01,& - & 9.698936e-01,9.687583e-01,9.676334e-01,9.665192e-01,9.654132e-01,& - & 9.643208e-01,9.632374e-01,9.621625e-01,9.611003e-01,9.600518e-01,& - & 9.590144e-01,9.579922e-01,9.569864e-01,9.559948e-01,9.550239e-01,& - & 9.540698e-01,9.531382e-01,9.522280e-01,9.513409e-01,9.504772e-01,& - & 9.496360e-01,9.488220e-01,9.480327e-01,9.472693e-01,9.465333e-01,& - & 9.458211e-01,9.451344e-01,9.444732e-01,9.438372e-01,9.432268e-01,& - & 9.426391e-01,9.420757e-01,9.415308e-01,9.410102e-01,9.405115e-01,& - & 9.400326e-01,9.395716e-01,9.391313e-01 / - data ssaliq2(:, 21) / & - & 9.980034e-01,9.968572e-01,9.958696e-01,9.949747e-01,9.941241e-01,& - & 9.933043e-01,9.924971e-01,9.916978e-01,9.909023e-01,9.901046e-01,& - & 9.893087e-01,9.885146e-01,9.877195e-01,9.869283e-01,9.861379e-01,& - & 9.853523e-01,9.845715e-01,9.837945e-01,9.830217e-01,9.822567e-01,& - & 9.814935e-01,9.807356e-01,9.799815e-01,9.792332e-01,9.784845e-01,& - & 9.777424e-01,9.770042e-01,9.762695e-01,9.755416e-01,9.748152e-01,& - & 9.740974e-01,9.733873e-01,9.726813e-01,9.719861e-01,9.713010e-01,& - & 9.706262e-01,9.699647e-01,9.693144e-01,9.686794e-01,9.680596e-01,& - & 9.674540e-01,9.668657e-01,9.662926e-01,9.657390e-01,9.652019e-01,& - & 9.646820e-01,9.641784e-01,9.636945e-01,9.632260e-01,9.627743e-01,& - & 9.623418e-01,9.619227e-01,9.615194e-01,9.611341e-01,9.607629e-01,& - & 9.604057e-01,9.600622e-01,9.597322e-01 / - data ssaliq2(:, 22) / & - & 9.988219e-01,9.981767e-01,9.976168e-01,9.971066e-01,9.966195e-01,& - & 9.961566e-01,9.956995e-01,9.952481e-01,9.947982e-01,9.943495e-01,& - & 9.938955e-01,9.934368e-01,9.929825e-01,9.925239e-01,9.920653e-01,& - & 9.916096e-01,9.911552e-01,9.907067e-01,9.902594e-01,9.898178e-01,& - & 9.893791e-01,9.889453e-01,9.885122e-01,9.880837e-01,9.876567e-01,& - & 9.872331e-01,9.868121e-01,9.863938e-01,9.859790e-01,9.855650e-01,& - & 9.851548e-01,9.847491e-01,9.843496e-01,9.839521e-01,9.835606e-01,& - & 9.831771e-01,9.827975e-01,9.824292e-01,9.820653e-01,9.817124e-01,& - & 9.813644e-01,9.810291e-01,9.807020e-01,9.803864e-01,9.800782e-01,& - & 9.797821e-01,9.794958e-01,9.792179e-01,9.789509e-01,9.786940e-01,& - & 9.784460e-01,9.782090e-01,9.779789e-01,9.777553e-01,9.775425e-01,& - & 9.773387e-01,9.771420e-01,9.769529e-01 / - data ssaliq2(:, 23) / & - & 9.998902e-01,9.998395e-01,9.997915e-01,9.997442e-01,9.997016e-01,& - & 9.996600e-01,9.996200e-01,9.995806e-01,9.995411e-01,9.995005e-01,& - & 9.994589e-01,9.994178e-01,9.993766e-01,9.993359e-01,9.992948e-01,& - & 9.992533e-01,9.992120e-01,9.991723e-01,9.991313e-01,9.990906e-01,& - & 9.990510e-01,9.990113e-01,9.989716e-01,9.989323e-01,9.988923e-01,& - & 9.988532e-01,9.988140e-01,9.987761e-01,9.987373e-01,9.986989e-01,& - & 9.986597e-01,9.986239e-01,9.985861e-01,9.985485e-01,9.985123e-01,& - & 9.984762e-01,9.984415e-01,9.984065e-01,9.983722e-01,9.983398e-01,& - & 9.983078e-01,9.982758e-01,9.982461e-01,9.982157e-01,9.981872e-01,& - & 9.981595e-01,9.981324e-01,9.981068e-01,9.980811e-01,9.980580e-01,& - & 9.980344e-01,9.980111e-01,9.979908e-01,9.979690e-01,9.979492e-01,& - & 9.979316e-01,9.979116e-01,9.978948e-01 / - data ssaliq2(:, 24) / & - & 9.999978e-01,9.999948e-01,9.999915e-01,9.999905e-01,9.999896e-01,& - & 9.999887e-01,9.999888e-01,9.999888e-01,9.999870e-01,9.999854e-01,& - & 9.999855e-01,9.999856e-01,9.999839e-01,9.999834e-01,9.999829e-01,& - & 9.999809e-01,9.999816e-01,9.999793e-01,9.999782e-01,9.999779e-01,& - & 9.999772e-01,9.999764e-01,9.999756e-01,9.999744e-01,9.999744e-01,& - & 9.999736e-01,9.999729e-01,9.999716e-01,9.999706e-01,9.999692e-01,& - & 9.999690e-01,9.999675e-01,9.999673e-01,9.999660e-01,9.999654e-01,& - & 9.999647e-01,9.999647e-01,9.999625e-01,9.999620e-01,9.999614e-01,& - & 9.999613e-01,9.999607e-01,9.999604e-01,9.999594e-01,9.999589e-01,& - & 9.999586e-01,9.999567e-01,9.999550e-01,9.999557e-01,9.999542e-01,& - & 9.999546e-01,9.999539e-01,9.999536e-01,9.999526e-01,9.999523e-01,& - & 9.999508e-01,9.999534e-01,9.999507e-01 / - data ssaliq2(:, 25) / & - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999995e-01,& - & 9.999995e-01,9.999990e-01,9.999991e-01,9.999991e-01,9.999990e-01,& - & 9.999989e-01,9.999988e-01,9.999988e-01,9.999986e-01,9.999988e-01,& - & 9.999986e-01,9.999987e-01,9.999986e-01,9.999985e-01,9.999985e-01,& - & 9.999985e-01,9.999985e-01,9.999983e-01,9.999983e-01,9.999981e-01,& - & 9.999981e-01,9.999986e-01,9.999985e-01,9.999983e-01,9.999984e-01,& - & 9.999982e-01,9.999983e-01,9.999982e-01,9.999980e-01,9.999981e-01,& - & 9.999978e-01,9.999979e-01,9.999985e-01,9.999985e-01,9.999983e-01,& - & 9.999983e-01,9.999983e-01,9.999983e-01 / - data ssaliq2(:, 26) / & - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& - & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999991e-01,& - & 9.999990e-01,9.999992e-01,9.999995e-01,9.999986e-01,9.999994e-01,& - & 9.999985e-01,9.999980e-01,9.999984e-01,9.999983e-01,9.999979e-01,& - & 9.999969e-01,9.999977e-01,9.999971e-01,9.999969e-01,9.999969e-01,& - & 9.999965e-01,9.999970e-01,9.999985e-01,9.999973e-01,9.999961e-01,& - & 9.999968e-01,9.999952e-01,9.999970e-01,9.999974e-01,9.999965e-01,& - & 9.999969e-01,9.999970e-01,9.999970e-01,9.999960e-01,9.999923e-01,& - & 9.999958e-01,9.999937e-01,9.999960e-01,9.999953e-01,9.999946e-01,& - & 9.999946e-01,9.999957e-01,9.999951e-01 / - data ssaliq2(:, 27) / & - & 1.000000e+00,1.000000e+00,9.999983e-01,9.999979e-01,9.999965e-01,& - & 9.999949e-01,9.999948e-01,9.999918e-01,9.999917e-01,9.999923e-01,& - & 9.999908e-01,9.999889e-01,9.999902e-01,9.999895e-01,9.999881e-01,& - & 9.999882e-01,9.999876e-01,9.999866e-01,9.999866e-01,9.999858e-01,& - & 9.999860e-01,9.999852e-01,9.999836e-01,9.999831e-01,9.999818e-01,& - & 9.999808e-01,9.999816e-01,9.999800e-01,9.999783e-01,9.999780e-01,& - & 9.999763e-01,9.999746e-01,9.999731e-01,9.999713e-01,9.999762e-01,& - & 9.999740e-01,9.999670e-01,9.999703e-01,9.999687e-01,9.999666e-01,& - & 9.999683e-01,9.999667e-01,9.999611e-01,9.999635e-01,9.999600e-01,& - & 9.999635e-01,9.999594e-01,9.999601e-01,9.999586e-01,9.999559e-01,& - & 9.999569e-01,9.999558e-01,9.999523e-01,9.999535e-01,9.999529e-01,& - & 9.999553e-01,9.999495e-01,9.999490e-01 / - data ssaliq2(:, 28) / & - & 9.999920e-01,9.999873e-01,9.999855e-01,9.999832e-01,9.999807e-01,& - & 9.999778e-01,9.999754e-01,9.999721e-01,9.999692e-01,9.999651e-01,& - & 9.999621e-01,9.999607e-01,9.999567e-01,9.999546e-01,9.999521e-01,& - & 9.999491e-01,9.999457e-01,9.999439e-01,9.999403e-01,9.999374e-01,& - & 9.999353e-01,9.999315e-01,9.999282e-01,9.999244e-01,9.999234e-01,& - & 9.999189e-01,9.999130e-01,9.999117e-01,9.999073e-01,9.999020e-01,& - & 9.998993e-01,9.998987e-01,9.998922e-01,9.998893e-01,9.998869e-01,& - & 9.998805e-01,9.998778e-01,9.998751e-01,9.998708e-01,9.998676e-01,& - & 9.998624e-01,9.998642e-01,9.998582e-01,9.998547e-01,9.998546e-01,& - & 9.998477e-01,9.998487e-01,9.998466e-01,9.998403e-01,9.998412e-01,& - & 9.998406e-01,9.998342e-01,9.998326e-01,9.998333e-01,9.998328e-01,& - & 9.998290e-01,9.998276e-01,9.998249e-01 / - data ssaliq2(:, 29) / & - & 8.383753e-01,8.461471e-01,8.373325e-01,8.212889e-01,8.023834e-01,& - & 7.829501e-01,7.641777e-01,7.466000e-01,7.304023e-01,7.155998e-01,& - & 7.021259e-01,6.898840e-01,6.787615e-01,6.686479e-01,6.594414e-01,& - & 6.510417e-01,6.433668e-01,6.363335e-01,6.298788e-01,6.239398e-01,& - & 6.184633e-01,6.134055e-01,6.087228e-01,6.043786e-01,6.003439e-01,& - & 5.965910e-01,5.930917e-01,5.898280e-01,5.867798e-01,5.839264e-01,& - & 5.812576e-01,5.787592e-01,5.764163e-01,5.742189e-01,5.721598e-01,& - & 5.702286e-01,5.684182e-01,5.667176e-01,5.651237e-01,5.636253e-01,& - & 5.622228e-01,5.609074e-01,5.596713e-01,5.585089e-01,5.574223e-01,& - & 5.564002e-01,5.554411e-01,5.545397e-01,5.536914e-01,5.528967e-01,& - & 5.521495e-01,5.514457e-01,5.507818e-01,5.501623e-01,5.495750e-01,& - & 5.490192e-01,5.484980e-01,5.480046e-01 / - -! --- ... updated asymmetry parameter from hu and stamnes - data asyliq2(:, 16) / & - & 8.038165e-01,8.014154e-01,7.942381e-01,7.970521e-01,8.086621e-01,& - & 8.233392e-01,8.374127e-01,8.495742e-01,8.596945e-01,8.680497e-01,& - & 8.750005e-01,8.808589e-01,8.858749e-01,8.902403e-01,8.940939e-01,& - & 8.975379e-01,9.006450e-01,9.034741e-01,9.060659e-01,9.084561e-01,& - & 9.106675e-01,9.127198e-01,9.146332e-01,9.164194e-01,9.180970e-01,& - & 9.196658e-01,9.211421e-01,9.225352e-01,9.238443e-01,9.250841e-01,& - & 9.262541e-01,9.273620e-01,9.284081e-01,9.294002e-01,9.303395e-01,& - & 9.312285e-01,9.320715e-01,9.328716e-01,9.336271e-01,9.343427e-01,& - & 9.350219e-01,9.356647e-01,9.362728e-01,9.368495e-01,9.373956e-01,& - & 9.379113e-01,9.383987e-01,9.388608e-01,9.392986e-01,9.397132e-01,& - & 9.401063e-01,9.404776e-01,9.408299e-01,9.411641e-01,9.414800e-01,& - & 9.417787e-01,9.420633e-01,9.423364e-01 / - data asyliq2(:, 17) / & - & 8.941000e-01,9.054049e-01,9.049510e-01,9.027216e-01,9.021636e-01,& - & 9.037878e-01,9.069852e-01,9.109817e-01,9.152013e-01,9.193040e-01,& - & 9.231177e-01,9.265712e-01,9.296606e-01,9.324048e-01,9.348419e-01,& - & 9.370131e-01,9.389529e-01,9.406954e-01,9.422727e-01,9.437088e-01,& - & 9.450221e-01,9.462308e-01,9.473488e-01,9.483830e-01,9.493492e-01,& - & 9.502541e-01,9.510999e-01,9.518971e-01,9.526455e-01,9.533554e-01,& - & 9.540249e-01,9.546571e-01,9.552551e-01,9.558258e-01,9.563603e-01,& - & 9.568713e-01,9.573569e-01,9.578141e-01,9.582485e-01,9.586604e-01,& - & 9.590525e-01,9.594218e-01,9.597710e-01,9.601052e-01,9.604181e-01,& - & 9.607159e-01,9.609979e-01,9.612655e-01,9.615184e-01,9.617564e-01,& - & 9.619860e-01,9.622009e-01,9.624031e-01,9.625957e-01,9.627792e-01,& - & 9.629530e-01,9.631171e-01,9.632746e-01 / - data asyliq2(:, 18) / & - & 8.574638e-01,8.351383e-01,8.142977e-01,8.083068e-01,8.129284e-01,& - & 8.215827e-01,8.307238e-01,8.389963e-01,8.460481e-01,8.519273e-01,& - & 8.568153e-01,8.609116e-01,8.643892e-01,8.673941e-01,8.700248e-01,& - & 8.723707e-01,8.744902e-01,8.764240e-01,8.782057e-01,8.798593e-01,& - & 8.814063e-01,8.828573e-01,8.842261e-01,8.855196e-01,8.867497e-01,& - & 8.879164e-01,8.890316e-01,8.900941e-01,8.911118e-01,8.920832e-01,& - & 8.930156e-01,8.939091e-01,8.947663e-01,8.955888e-01,8.963786e-01,& - & 8.971350e-01,8.978617e-01,8.985590e-01,8.992243e-01,8.998631e-01,& - & 9.004753e-01,9.010602e-01,9.016192e-01,9.021542e-01,9.026644e-01,& - & 9.031535e-01,9.036194e-01,9.040656e-01,9.044894e-01,9.048933e-01,& - & 9.052789e-01,9.056481e-01,9.060004e-01,9.063343e-01,9.066544e-01,& - & 9.069604e-01,9.072512e-01,9.075290e-01 / - data asyliq2(:, 19) / & - & 8.349569e-01,8.034579e-01,7.932136e-01,8.010156e-01,8.137083e-01,& - & 8.255339e-01,8.351938e-01,8.428286e-01,8.488944e-01,8.538187e-01,& - & 8.579255e-01,8.614473e-01,8.645338e-01,8.672908e-01,8.697947e-01,& - & 8.720843e-01,8.742015e-01,8.761718e-01,8.780160e-01,8.797479e-01,& - & 8.813810e-01,8.829250e-01,8.843907e-01,8.857822e-01,8.871059e-01,& - & 8.883724e-01,8.895810e-01,8.907384e-01,8.918456e-01,8.929083e-01,& - & 8.939284e-01,8.949060e-01,8.958463e-01,8.967486e-01,8.976129e-01,& - & 8.984463e-01,8.992439e-01,9.000094e-01,9.007438e-01,9.014496e-01,& - & 9.021235e-01,9.027699e-01,9.033859e-01,9.039772e-01,9.045419e-01,& - & 9.050819e-01,9.055975e-01,9.060907e-01,9.065607e-01,9.070093e-01,& - & 9.074389e-01,9.078475e-01,9.082388e-01,9.086117e-01,9.089678e-01,& - & 9.093081e-01,9.096307e-01,9.099410e-01 / - data asyliq2(:, 20) / & - & 8.109692e-01,7.846657e-01,7.881928e-01,8.009509e-01,8.131208e-01,& - & 8.230400e-01,8.309448e-01,8.372920e-01,8.424837e-01,8.468166e-01,& - & 8.504947e-01,8.536642e-01,8.564256e-01,8.588513e-01,8.610011e-01,& - & 8.629122e-01,8.646262e-01,8.661720e-01,8.675752e-01,8.688582e-01,& - & 8.700379e-01,8.711300e-01,8.721485e-01,8.731027e-01,8.740010e-01,& - & 8.748499e-01,8.756564e-01,8.764239e-01,8.771542e-01,8.778523e-01,& - & 8.785211e-01,8.791601e-01,8.797725e-01,8.803589e-01,8.809173e-01,& - & 8.814552e-01,8.819705e-01,8.824611e-01,8.829311e-01,8.833791e-01,& - & 8.838078e-01,8.842148e-01,8.846044e-01,8.849756e-01,8.853291e-01,& - & 8.856645e-01,8.859841e-01,8.862904e-01,8.865801e-01,8.868551e-01,& - & 8.871182e-01,8.873673e-01,8.876059e-01,8.878307e-01,8.880462e-01,& - & 8.882501e-01,8.884453e-01,8.886339e-01 / - data asyliq2(:, 21) / & - & 7.838510e-01,7.803151e-01,7.980477e-01,8.144160e-01,8.261784e-01,& - & 8.344240e-01,8.404278e-01,8.450391e-01,8.487593e-01,8.518741e-01,& - & 8.545484e-01,8.568890e-01,8.589560e-01,8.607983e-01,8.624504e-01,& - & 8.639408e-01,8.652945e-01,8.665301e-01,8.676634e-01,8.687121e-01,& - & 8.696855e-01,8.705933e-01,8.714448e-01,8.722454e-01,8.730014e-01,& - & 8.737180e-01,8.743982e-01,8.750436e-01,8.756598e-01,8.762481e-01,& - & 8.768089e-01,8.773427e-01,8.778532e-01,8.783434e-01,8.788089e-01,& - & 8.792530e-01,8.796784e-01,8.800845e-01,8.804716e-01,8.808411e-01,& - & 8.811923e-01,8.815276e-01,8.818472e-01,8.821504e-01,8.824408e-01,& - & 8.827155e-01,8.829777e-01,8.832269e-01,8.834631e-01,8.836892e-01,& - & 8.839034e-01,8.841075e-01,8.843021e-01,8.844866e-01,8.846631e-01,& - & 8.848304e-01,8.849910e-01,8.851425e-01 / - data asyliq2(:, 22) / & - & 7.760783e-01,7.890215e-01,8.090192e-01,8.230252e-01,8.321369e-01,& - & 8.384258e-01,8.431529e-01,8.469558e-01,8.501499e-01,8.528899e-01,& - & 8.552899e-01,8.573956e-01,8.592570e-01,8.609098e-01,8.623897e-01,& - & 8.637169e-01,8.649184e-01,8.660097e-01,8.670096e-01,8.679338e-01,& - & 8.687896e-01,8.695880e-01,8.703365e-01,8.710422e-01,8.717092e-01,& - & 8.723378e-01,8.729363e-01,8.735063e-01,8.740475e-01,8.745661e-01,& - & 8.750560e-01,8.755275e-01,8.759731e-01,8.764000e-01,8.768071e-01,& - & 8.771942e-01,8.775628e-01,8.779126e-01,8.782483e-01,8.785626e-01,& - & 8.788610e-01,8.791482e-01,8.794180e-01,8.796765e-01,8.799207e-01,& - & 8.801522e-01,8.803707e-01,8.805777e-01,8.807749e-01,8.809605e-01,& - & 8.811362e-01,8.813047e-01,8.814647e-01,8.816131e-01,8.817588e-01,& - & 8.818930e-01,8.820230e-01,8.821445e-01 / - data asyliq2(:, 23) / & - & 7.847907e-01,8.099917e-01,8.257428e-01,8.350423e-01,8.411971e-01,& - & 8.457241e-01,8.493010e-01,8.522565e-01,8.547660e-01,8.569311e-01,& - & 8.588181e-01,8.604729e-01,8.619296e-01,8.632208e-01,8.643725e-01,& - & 8.654050e-01,8.663363e-01,8.671835e-01,8.679590e-01,8.686707e-01,& - & 8.693308e-01,8.699433e-01,8.705147e-01,8.710490e-01,8.715497e-01,& - & 8.720219e-01,8.724669e-01,8.728849e-01,8.732806e-01,8.736550e-01,& - & 8.740099e-01,8.743435e-01,8.746601e-01,8.749610e-01,8.752449e-01,& - & 8.755143e-01,8.757688e-01,8.760095e-01,8.762375e-01,8.764532e-01,& - & 8.766579e-01,8.768506e-01,8.770323e-01,8.772049e-01,8.773690e-01,& - & 8.775226e-01,8.776679e-01,8.778062e-01,8.779360e-01,8.780587e-01,& - & 8.781747e-01,8.782852e-01,8.783892e-01,8.784891e-01,8.785824e-01,& - & 8.786705e-01,8.787546e-01,8.788336e-01 / - data asyliq2(:, 24) / & - & 8.054324e-01,8.266282e-01,8.378075e-01,8.449848e-01,8.502166e-01,& - & 8.542268e-01,8.573477e-01,8.598022e-01,8.617689e-01,8.633859e-01,& - & 8.647536e-01,8.659354e-01,8.669807e-01,8.679143e-01,8.687577e-01,& - & 8.695222e-01,8.702207e-01,8.708591e-01,8.714446e-01,8.719836e-01,& - & 8.724812e-01,8.729426e-01,8.733689e-01,8.737665e-01,8.741373e-01,& - & 8.744834e-01,8.748070e-01,8.751131e-01,8.754011e-01,8.756676e-01,& - & 8.759219e-01,8.761599e-01,8.763857e-01,8.765984e-01,8.767999e-01,& - & 8.769889e-01,8.771669e-01,8.773373e-01,8.774969e-01,8.776469e-01,& - & 8.777894e-01,8.779237e-01,8.780505e-01,8.781703e-01,8.782820e-01,& - & 8.783886e-01,8.784894e-01,8.785844e-01,8.786736e-01,8.787584e-01,& - & 8.788379e-01,8.789130e-01,8.789849e-01,8.790506e-01,8.791141e-01,& - & 8.791750e-01,8.792324e-01,8.792867e-01 / - data asyliq2(:, 25) / & - & 8.249534e-01,8.391988e-01,8.474107e-01,8.526860e-01,8.563983e-01,& - & 8.592389e-01,8.615144e-01,8.633790e-01,8.649325e-01,8.662504e-01,& - & 8.673841e-01,8.683741e-01,8.692495e-01,8.700309e-01,8.707328e-01,& - & 8.713650e-01,8.719432e-01,8.724676e-01,8.729498e-01,8.733922e-01,& - & 8.737981e-01,8.741745e-01,8.745225e-01,8.748467e-01,8.751512e-01,& - & 8.754315e-01,8.756962e-01,8.759450e-01,8.761774e-01,8.763945e-01,& - & 8.766021e-01,8.767970e-01,8.769803e-01,8.771511e-01,8.773151e-01,& - & 8.774689e-01,8.776147e-01,8.777533e-01,8.778831e-01,8.780050e-01,& - & 8.781197e-01,8.782301e-01,8.783323e-01,8.784312e-01,8.785222e-01,& - & 8.786096e-01,8.786916e-01,8.787688e-01,8.788411e-01,8.789122e-01,& - & 8.789762e-01,8.790373e-01,8.790954e-01,8.791514e-01,8.792018e-01,& - & 8.792517e-01,8.792990e-01,8.793429e-01 / - data asyliq2(:, 26) / & - & 8.323091e-01,8.429776e-01,8.498123e-01,8.546929e-01,8.584295e-01,& - & 8.613489e-01,8.636324e-01,8.654303e-01,8.668675e-01,8.680404e-01,& - & 8.690174e-01,8.698495e-01,8.705666e-01,8.711961e-01,8.717556e-01,& - & 8.722546e-01,8.727063e-01,8.731170e-01,8.734933e-01,8.738382e-01,& - & 8.741590e-01,8.744525e-01,8.747295e-01,8.749843e-01,8.752210e-01,& - & 8.754437e-01,8.756524e-01,8.758472e-01,8.760288e-01,8.762030e-01,& - & 8.763603e-01,8.765122e-01,8.766539e-01,8.767894e-01,8.769130e-01,& - & 8.770310e-01,8.771422e-01,8.772437e-01,8.773419e-01,8.774355e-01,& - & 8.775221e-01,8.776047e-01,8.776802e-01,8.777539e-01,8.778216e-01,& - & 8.778859e-01,8.779473e-01,8.780031e-01,8.780562e-01,8.781097e-01,& - & 8.781570e-01,8.782021e-01,8.782463e-01,8.782845e-01,8.783235e-01,& - & 8.783610e-01,8.783953e-01,8.784273e-01 / - data asyliq2(:, 27) / & - & 8.396448e-01,8.480172e-01,8.535934e-01,8.574145e-01,8.600835e-01,& - & 8.620347e-01,8.635500e-01,8.648003e-01,8.658758e-01,8.668248e-01,& - & 8.676697e-01,8.684220e-01,8.690893e-01,8.696807e-01,8.702046e-01,& - & 8.706676e-01,8.710798e-01,8.714478e-01,8.717778e-01,8.720747e-01,& - & 8.723431e-01,8.725889e-01,8.728144e-01,8.730201e-01,8.732129e-01,& - & 8.733907e-01,8.735541e-01,8.737100e-01,8.738533e-01,8.739882e-01,& - & 8.741164e-01,8.742362e-01,8.743485e-01,8.744530e-01,8.745512e-01,& - & 8.746471e-01,8.747373e-01,8.748186e-01,8.748973e-01,8.749732e-01,& - & 8.750443e-01,8.751105e-01,8.751747e-01,8.752344e-01,8.752902e-01,& - & 8.753412e-01,8.753917e-01,8.754393e-01,8.754843e-01,8.755282e-01,& - & 8.755662e-01,8.756039e-01,8.756408e-01,8.756722e-01,8.757072e-01,& - & 8.757352e-01,8.757653e-01,8.757932e-01 / - data asyliq2(:, 28) / & - & 8.374590e-01,8.465669e-01,8.518701e-01,8.547627e-01,8.565745e-01,& - & 8.579065e-01,8.589717e-01,8.598632e-01,8.606363e-01,8.613268e-01,& - & 8.619560e-01,8.625340e-01,8.630689e-01,8.635601e-01,8.640084e-01,& - & 8.644180e-01,8.647885e-01,8.651220e-01,8.654218e-01,8.656908e-01,& - & 8.659294e-01,8.661422e-01,8.663334e-01,8.665037e-01,8.666543e-01,& - & 8.667913e-01,8.669156e-01,8.670242e-01,8.671249e-01,8.672161e-01,& - & 8.672993e-01,8.673733e-01,8.674457e-01,8.675103e-01,8.675713e-01,& - & 8.676267e-01,8.676798e-01,8.677286e-01,8.677745e-01,8.678178e-01,& - & 8.678601e-01,8.678986e-01,8.679351e-01,8.679693e-01,8.680013e-01,& - & 8.680334e-01,8.680624e-01,8.680915e-01,8.681178e-01,8.681428e-01,& - & 8.681654e-01,8.681899e-01,8.682103e-01,8.682317e-01,8.682498e-01,& - & 8.682677e-01,8.682861e-01,8.683041e-01 / - data asyliq2(:, 29) / & - & 7.877069e-01,8.244281e-01,8.367971e-01,8.409074e-01,8.429859e-01,& - & 8.454386e-01,8.489350e-01,8.534141e-01,8.585814e-01,8.641267e-01,& - & 8.697999e-01,8.754223e-01,8.808785e-01,8.860944e-01,8.910354e-01,& - & 8.956837e-01,9.000392e-01,9.041091e-01,9.079071e-01,9.114479e-01,& - & 9.147462e-01,9.178234e-01,9.206903e-01,9.233663e-01,9.258668e-01,& - & 9.282006e-01,9.303847e-01,9.324288e-01,9.343418e-01,9.361356e-01,& - & 9.378176e-01,9.393939e-01,9.408736e-01,9.422622e-01,9.435670e-01,& - & 9.447900e-01,9.459395e-01,9.470199e-01,9.480335e-01,9.489852e-01,& - & 9.498782e-01,9.507168e-01,9.515044e-01,9.522470e-01,9.529409e-01,& - & 9.535946e-01,9.542071e-01,9.547838e-01,9.553256e-01,9.558351e-01,& - & 9.563139e-01,9.567660e-01,9.571915e-01,9.575901e-01,9.579685e-01,& - & 9.583239e-01,9.586602e-01,9.589766e-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,42,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/gfsphysics/physics/radsw_main.f b/gfsphysics/physics/radsw_main.f deleted file mode 100644 index cf2640d78..000000000 --- a/gfsphysics/physics/radsw_main.f +++ /dev/null @@ -1,5492 +0,0 @@ -!> \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, ! -! dzlyr,delpin,de_lgth, ! -! cosz,solcon,NDAY,idxday, ! -! npts, nlay, nlp1, lprnt, ! -! outputs: ! -! hswc,topflx,sfcflx,cldtau, ! -!! 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! -! jun 2018 yu-tai hou --updated cloud optical coeffs with ! -! aer's newer version v3.9-v4.0 for hu and stamnes ! -! scheme. (used if iswcliq=2); added new option of ! -! cloud overlap method 'de-correlation-length'. ! -! ! -!!!!! ============================================================== !!!!! -!!!!! 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/) -!! @{ -! FEB 2017 A.Cheng - add odpth output, effective radius input ! -!========================================! - 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 cldtau spectral band layer cloud optical depth (approx 0.55 mu) -!!\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, & - & dzlyr,delpin,de_lgth, & - & cosz,solcon,NDAY,idxday, & - & npts, nlay, nlp1, lprnt, & - & hswc,topflx,sfcflx,cldtau, & ! --- 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) ! -! 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) ! -! 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 ! -! dzlyr(npts,nlay) : layer thickness in km ! -! delpin(npts,nlay): layer pressure thickness (mb) ! -! de_lgth(npts) : clouds decorrelation length (km) ! -! 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 ! -! cldtau(npts,nlay): spectral band layer cloud optical depth (~0.55 mu) -! ! -!!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: use updated coeffs for hu and stamnes scheme ! -! 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 ! -! =3: decorrelation-length overlap clouds ! -! 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, dzlyr, delpin - 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, & - & de_lgth(npts) - -! --- outputs: - real (kind=kind_phys), dimension(npts,nlay), intent(out) :: hswc - real (kind=kind_phys), dimension(npts,nlay), intent(out) :: cldtau - - 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, dz - - 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, delgth - -! --- 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 - cldtau(:,:) = 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) - if (iovrsw == 3) delgth = de_lgth(j1) ! clouds decorr-length - -!> -# 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) = delpin(j1,kk) - dz (k) = dzlyr (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) = delpin(j1,k) - dz (k) = dzlyr (j1,k) - -! --- ... 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 - do k = 1, nlay - zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator - 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), dz, delgth, & -! --- outputs: - & taucw, ssacw, asycw, cldfrc, cldfmc & - & ) - -! --- ... save computed layer cloud optical depth for output -! rrtm band 10 is approx to the 0.55 mu spectrum - - if (ivflip == 0) then ! input from toa to sfc - do k = 1, nlay - kk = nlp1 - k - cldtau(j1,kk) = taucw(k,10) - enddo - else ! input from sfc to toa - do k = 1, nlay - cldtau(j1,k) = taucw(k,10) - enddo - endif ! end if_ivflip_block - - 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 ! -! =3: decorrelation-length overlap 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) ! -! ! -! ******************************************************************* ! -! ! -! 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>3 ) 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 - - if ( isubcsw==0 .and. iovrsw>2 ) then - if (me == 0) then - print *,' *** IOVRSW=',iovrsw,' is not available for', & - & ' ISUBCSW=0 setting!!' - print *,' The program will use maximum/random overlap', & - & ' instead.' - endif - - iovrsw = 1 - 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, dz, delgth, & - & 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) ! -! dz - real, layer thickness (km) nlay ! -! delgth- real, layer cloud decorrelation length (km) 1 ! -! ! -! 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. ! -! iswcliq=2 : updated coeffs for hu and stamnes (1993) by aer ! -! w v3.9-v4.0. ! -! ! -! 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, delgth - - real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & - & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, cfrac, dz - -! --- 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 - factor = refliq - 1.5 - index = max( 1, min( 57, int( factor ) )) - fint = factor - float(index) - - if ( iswcliq == 1 ) then - 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 - elseif ( iswcliq == 2 ) then ! use updated coeffs - do ib = nblow, nbhgh - extcoliq = max(f_zero, extliq2(index,ib) & - & + fint*(extliq2(index+1,ib)-extliq2(index,ib)) ) - ssacoliq = max(f_zero, min(f_one, ssaliq2(index,ib) & - & + fint*(ssaliq2(index+1,ib)-ssaliq2(index,ib)) )) - - asycoliq = max(f_zero, min(f_one, asyliq2(index,ib) & - & + fint*(asyliq2(index+1,ib)-asyliq2(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, dz, delgth, & -! --- 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, dz, de_lgth, & ! --- 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. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth-real, layer cloud decorrelation length (km) 1 ! -! ! -! 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 overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: cloud decorrelation-length overlap method ! -! ! -! ===================== end of definitions ==================== ! - - implicit none - -! --- inputs: - integer, intent(in) :: nlay, ipseed - - real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- outputs: - logical, dimension(nlay,ngptsw), intent(out):: lcloudy - -! --- locals: - real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & - & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & - & cdfun2(nlay,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 - - case( 3 ) ! decorrelation length overlap - -! --- compute overlapping factors based on layer midpoint distances -! and decorrelation depths - - do k = nlay, 2, -1 - fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) - enddo - -! --- setup 2 sets of random numbers - - call random_number ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(k,n) = rand2d(k1) - enddo - enddo - - call random_number ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfun2(k,n) = rand2d(k1) - enddo - enddo - -! --- then working from the top down: -! if a random number (from an independent set -cdfun2) is smaller then the -! scale factor: use the upper layer's number, otherwise use a new random -! number (keep the original assigned one). - - do n = 1, ngptsw - do k = nlay-1, 1, -1 - k1 = k + 1 - if ( cdfun2(k,n) <= fac_lcf(k1) ) then - cdfunc(k,n) = cdfunc(k1,n) - endif - 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/gfsphysics/physics/radsw_param.f b/gfsphysics/physics/radsw_param.f deleted file mode 100644 index 29e671494..000000000 --- a/gfsphysics/physics/radsw_param.f +++ /dev/null @@ -1,202 +0,0 @@ -!> \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, 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 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/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f deleted file mode 100644 index 4ad7882ef..000000000 --- a/gfsphysics/physics/rascnvv2.f +++ /dev/null @@ -1,4620 +0,0 @@ - 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, t0c => con_t0c - implicit none - SAVE -! - integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s - - integer, parameter :: idnmax=999 - real (kind=kind_phys), parameter :: delt_c=1800.0d0/3600.0d0 & -! 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.0d0, adjts_s=0.5d0 -! - logical, parameter :: fix_ncld_hr=.true. -! - real (kind=kind_phys), parameter :: ZERO=0.0d0, HALF=0.5d0 & - &, pt25=0.25d0, ONE=1.0d0 & - &, TWO=2.0d0, FOUR=4.0d0 & - &, twoo3=two/3.0d0 & - &, FOUR_P2=4.d2, ONE_M10=1.0d-10& - &, ONE_M6=1.0d-6, ONE_M5=1.0d-5 & - &, ONE_M2=1.0d-2, ONE_M1=1.0d-1 & - &, oneolog10=one/log(10.0d0) & - &, cfmax=0.1d0 & - &, deg2rad=pi/180.d0 & ! conversion factor from degree to radians - &, cmb2pa = 100.0d0 ! Conversion from hPa to Pa -! - real(kind=kind_phys), parameter :: & - & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & - &, onebcp = one / cp & - &, GRAVFAC = GRAV / CMB2PA, ELOCP = ALHL * onebcp & - &, ELFOCP = (ALHL+ALHF) * onebcp & - &, oneoalhl = one/alhl & - &, CMPOR = CMB2PA / RGAS & - &, picon = half*pi*onebg, VTPEXP = -0.3636d0 & - &, dpnegcr = 150.0d0 & -! &, dpnegcr = 100.0 & -! &, dpnegcr = 200.0 & -! &, ddunc1 = 0.4, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, ddunc1 = 0.25d0, ddunc2=one-ddunc1 & uncentering for vvel in dd -! &, ddunc1 = 0.3, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, zfac = 0.28888889d-4 * ONEBG - &, c0ifac = 0.07d0 ! following Han et al, 2016 MWR -! -! 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, pcrit_lcl & - &, testmboalhl, testmbi - -! PARAMETER (DD_DP=0.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! - PARAMETER (DD_DP=0.5d0, RKNOB=1.0d0, EKNOB=1.0d0) -! PARAMETER (DD_DP=0.5, RKNOB=2.0, EKNOB=1.0) -! - PARAMETER (RHMAX=1.0d0 ) ! MAX RELATIVE HUMIDITY - PARAMETER (QUAD_LAM=1.0d0) ! MASK FOR QUADRATIC LAMBDA -! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (RHRAM=0.05d0) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (HCRITD=4000.0d0) ! Critical Moist Static Energy for Deep clouds - PARAMETER (HCRITS=2000.0d0) ! Critical Moist Static Energy for Shallow Clouds - PARAMETER (pcrit_lcl=250.0d0)! Critical pressure difference between boundary layer top -! and lifting condensation level (hPa) - -! 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.0d0) -! parameter (qudfac=quad_lam*pt25) ! Yogesh's - parameter (testmb=0.1d0, testmbi=one/testmb) - parameter (testmboalhl=testmb/alhl) -! - real(kind=kind_phys) facdt - - real(kind=kind_phys), parameter :: almax=1.0d-2 - &, almin1=0.0d0, almin2=0.0d0 - -! real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX -! -! 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=1.00E-5, ALMIN2=2.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.0d0, bldmin=25.0d0 -!! real(kind=kind_phys), parameter :: BLDMAX = 350.0 -! -! - 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) - parameter (TF=233.16d0, TCR=273.16d0, TCRF=one/(TCR-TF),TCL=2.0d0) -! -! 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.01097d-4*DT)*(3600.0d0/DT)**0.57777778d0 - end subroutine set_ras_afc - - subroutine ras_init(levs, me) -! - Implicit none -! - integer levs, me -! - real(kind=kind_phys), 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/ -! - real(kind=kind_phys) tem, actop, tem1, tem2 - integer i, l - 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 = one / (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) = zero - AD(16) = zero -! - 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.34d0*SQRT(1.2d0)* (0.001d0)**0.1364d0 -! - if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & - &, ' DETRAINING AT NORMALIZED PRESSURE ABOVE ',DD_DP -! - first = .false. - endif -! - end subroutine ras_init - end module module_ras -! - module module_rascnv -! - USE MACHINE , ONLY : kind_phys - implicit none - SAVE -! - LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth, do_aw & - &, CUMFRC - - real(kind=kind_phys), parameter :: frac=0.5d0, crtmsf=0.0d0 & - &, rhfacs=0.75d0, rhfacl=0.75d0 & -! &, rhfacs=0.70, rhfacl=0.70 & - &, face=5.0d0, delx=10000.0d0 & - &, ddfac=face*delx*0.001d0 & - &, max_neg_bouy=0.15d0 -! &, max_neg_bouy=pt25 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! PARAMETER ( REVAP = .true., CUMFRC=.true.) - PARAMETER (do_aw = .true., CUMFRC=.true.) -! PARAMETER (do_aw = .false., CUMFRC=.true.) - PARAMETER (WRKFUN = .FALSE., UPDRET = .FALSE., vsmooth=.false.) -! PARAMETER (CRTFUN = .TRUE., CALKBL = .false., BOTOP=.true.) - PARAMETER (CRTFUN = .TRUE., CALKBL = .true., BOTOP=.true.) -! -! 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.0d0, pgfbot=0.0d0 & -! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & - &, pgfgrad=(pgfbot-pgftop)*0.001d0 -! - 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, ccwfac & - &, nrcm, rhc, ud_mf, dd_mf, det_mf & - &, c00, qw0, c00i, qi0, dlqfac & - &, lprnt, ipr, kdt, revap & - &, 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, trcmin, ntk) -! &, mp_phys, trcmin) -! &, 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, mp_phys, kdt - Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, mp_phys, kdt,ntk - integer, dimension(im) :: kbot, ktop, kcnv, kpbl -! - 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_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 & - &, c00, c00i, dlqfac - real(kind=kind_phys), dimension(ix,nrcm):: rannum - real(kind=kind_phys) ccin(ix,k,trac+2) - real(kind=kind_phys) trcmin(trac+2) - - real(kind=kind_phys) DT, facmb, dtf, qw0, qi0 -! -! 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 - &, qoi_l, qli_l, qii_l - real(kind=kind_phys), dimension(k+1) :: prs, psj, phi_h, flx, flxd - - - integer, dimension(100) :: ic - real(kind=kind_phys), parameter :: clwmin=1.0d-10 -! - real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) - &, trcfac(:,:), rcu(:,:) - real(kind=kind_phys) dtvd(2,4) -! &, DPI(K) - real(kind=kind_phys) CFAC, TEM, sgc, ccwf, tem1, tem2, rain & - &, wfnc,tla,pl,qiid,qlid, c0, c0i, dlq_fac, sumq& - &, rainp -! - Integer KCR, KFX, NCMX, NC, KTEM, I, ii, Lm1, l & - &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & - &, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib & - &, kblmn, ksfc - real(kind=kind_phys) sgcs(k,im) -! - LOGICAL lprint -! LOGICAL lprint, ctei -! -! Scavenging related parameters -! - real fscav_(trac+2) ! Fraction scavenged per km -! - fscav_ = zero ! By default no scavenging - if (trac > 0) then - do i=1,trac - fscav_(i) = fscav(i) - enddo - endif - -! if (me == 0) write(0,*)' rann=',rannum(1,:),' kdt=',kdt -! if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', -! & ccwfac(ipr),' mp_phys=',mp_phys -! &, ' fscav=',fscav,' trac=',trac -! &, ' rannum=',rannum(1,:) -! - km1 = k - 1 - kp1 = k + 1 - if (flipv) then - ksfc = 1 - else - ksfc = kp1 - endif -! - 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) = one ! For other tracers - rcu(l,n) = zero - enddo - enddo - endif -! -!!!!! initialization for microphysics ACheng - if(mp_phys == 10) then - do l=1,K - do i=1,im - QLCN(i,l) = zero - QICN(i,l) = zero - w_upi(i,l) = zero - cf_upi(i,l) = zero - CNV_MFD(i,l) = zero -! CNV_PRC3(i,l) = zero - CNV_DQLDT(i,l) = zero - CLCN(i,l) = zero - CNV_FICE(i,l) = zero - CNV_NDROP(i,l) = zero - CNV_NICE(i,l) = zero - enddo - enddo - endif -! - if (.not. allocated(alfint)) allocate(alfint(k,ntrc+4)) -! - call set_ras_afc(dt) -! - do l=1,k - do i=1,im - ud_mf(i,l) = zero - dd_mf(i,l) = zero - det_mf(i,l) = zero - enddo - enddo - DO IPT=1,IM - - lprint = lprnt .and. ipt == ipr - ia = ipr - - ccwf = half - if (ccwfac(ipt) >= zero) ccwf = ccwfac(ipt) - - dlq_fac = dlqfac(ipt) - tem = one + dlq_fac - c0 = c00(IPT) * tem - c0i = c00i(IPT) * tem - -! if (lprint) write(0,*)' c0=',c0,' c0i=',c0i,' dlq_fac=',dlq_fac, & -! & ' ccwf=',ccwf -! -! ctei = .false. -! if (ctei_r(ipt) > ctei_rm) ctei = .true. -! -! Compute NCRND : -! if flipv is true, then input variables are from bottom -! to top while RAS goes top to bottom -! - tem = one / prsi(ipt,ksfc) - - KRMIN = 1 - KRMAX = km1 - KFMAX = KRMAX - kblmx = 1 - kblmn = 1 - DO L=1,KM1 - 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.050d0) KRMIN = L -! IF (SGC <= 0.700d0) KRMAX = L -! IF (SGC <= 0.800d0) KRMAX = L - IF (SGC <= 0.760d0) KRMAX = L -! IF (SGC <= 0.930d0) KFMAX = L - IF (SGC <= 0.970d0) KFMAX = L ! Commented on 20060202 -! IF (SGC <= 0.700d0) kblmx = L ! Commented on 20101015 - IF (SGC <= 0.600d0) kblmx = L ! -! IF (SGC <= 0.650d0) kblmx = L ! Commented on 20060202 - IF (SGC <= 0.980d0) kblmn = L ! - ENDDO - krmin = max(krmin,2) - -! if (kdt == 1 .and. ipt == 1) write(0,*)' kblmn=',kblmn,kblmx -! if (lprint) write(0,*)' krmin=',krmin,' krmax=', -! &krmax,' kfmax=',kfmax,' tem=',tem -! - if (fix_ncld_hr) then -!!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001d0 -! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.10001 -! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/900) + 0.50001 -! 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 = one / 3600.0d0 - endif - NCRND = min(nrcm,max(NCRND, 1)) -! - KCR = MIN(K,KRMAX) - KTEM = MIN(K,KFMAX) - KFX = KTEM - KCR - -! if(lprint)write(0,*)' enter RASCNV k=',k,' ktem=',ktem -! &, ' krmax=',krmax,' kfmax=',kfmax -! &, ' krmin=',krmin,' ncrnd=',ncrnd & -! &, ' 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 - II = mod(i-1,nrcm) + 1 - IRND = (RANNUM(ipt,II)-0.0005d0)*(KCR-KRMIN+1) - IC(KFX+I) = IRND + KRMIN - ENDDO - ENDIF -! -! write(0,*)' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt -! if (lprint) then -! if (me == 0) then -! write(0,*)' ic=',ic(1:kfx+ncrnd) -! write(0,*)' tin',(tin(ia,l),l=k,1,-1) -! write(0,*)' qin',(qin(ia,l),l=k,1,-1),' kdt=',kdt,' me=',me -! write(0,*)' qwin',(ccin(ia,l,2),l=k,1,-1) -! write(0,*)' qiin',(ccin(ia,l,1),l=k,1,-1) -! endif -! -! -! lprint = lprnt .and. ipt == ipr - - do l=1,k - CLW(l) = zero - CLI(l) = zero - ! to be zero i.e. no environmental condensate!!! - QII(l) = zero - QLI(l) = zero -! Initialize heating, drying, cloudiness etc. - tcu(l) = zero - qcu(l) = zero - pcu(l) = zero - flx(l) = zero - flxd(l) = zero - do n=1,ntrc - rcu(l,n) = zero - enddo - enddo - flx(kp1) = zero - flxd(kp1) = zero - rain = zero -! - if (flipv) then ! Input variables are bottom to top! - do l=1,k - ll = kp1 - l - ! Transfer input prognostic data into local variable - toi(l) = tin(ipt,ll) - qoi(l) = qin(ipt,ll) - - PRSM(L) = prsl(ipt,ll) * facmb ! facmb is for conversion to MB - PSJM(L) = prslk(ipt,ll) - phi_l(L) = phil(ipt,ll) - rhc_l(L) = rhc(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.0d-20) uvi(l,n) = zero - enddo - endif - enddo - do l=1,kp1 - 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 -! - if (ccin(ipt,1,2) <= -999.0d0) then ! input ice/water are together - do l=1,k - ll = kp1 -l - 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 = kp1 -l ! Input variables are bottom to top! - QII(L) = ccin(ipt,ll,1) - QLI(L) = ccin(ipt,ll,2) - enddo - endif - KBL = MAX(MIN(k, kp1-KPBL(ipt)), k/2) -! - else ! Input variables are top to bottom! - - do l=1,k - ! Transfer input prognostic data into local variable - toi(l) = tin(ipt,l) - qoi(l) = qin(ipt,l) - - PRSM(L) = prsl(ipt, L) * facmb ! facmb is for conversion to MB - PSJM(L) = prslk(ipt,L) - phi_l(L) = phil(ipt,L) - rhc_l(L) = rhc(ipt,L) -! - if (ntrc > trac) then ! CUMFRC is true - uvi(l,trac+1) = uin(ipt,l) - uvi(l,trac+2) = vin(ipt,l) - endif -! - if (trac > 0) then ! tracers such as O3, dust etc - do n=1,trac - uvi(l,n) = ccin(ipt,l,n+2) - if (abs(uvi(l,n)) < 1.0d-20) uvi(l,n) = zero - enddo - endif - enddo - DO L=1,kp1 - PRS(L) = prsi(ipt,L) * facmb ! facmb is for conversion to MB - PSJ(L) = prsik(ipt,L) - phi_h(L) = phii(ipt,L) - ENDDO -! - if (ccin(ipt,1,2) <= -999.0d0) then ! input ice/water are together - do l=1,k - tem = ccin(ipt,l,1) & - & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) - ccin(ipt,l,2) = ccin(ipt,l,1) - tem - ccin(ipt,l,1) = tem - enddo - endif - if (advcld) then - do l=1,k - QII(L) = ccin(ipt,l,1) - QLI(L) = ccin(ipt,l,2) - enddo - endif -! - KBL = KPBL(ipt) -! - endif ! end of if (flipv) then -! -! if (lprnt .and. ipt == ipr) write(0,*)' phi_h=',phi_h(:) -! if(lprint) write(0,*)' PRS=',PRS -! if(lprint) write(0,*)' PRSM=',PRSM -! if (lprint) then -! write(0,*)' qns=',qns(ia),' qoi=',qn0(ia,k),'qin=',qin(ia,1) -! if (me == 0) then -! write(0,*)' toi',(tn0(ia,l),l=1,k) -! write(0,*)' 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(:,:) = one - elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = one - 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 - -! write(0,*)' 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)) - -! write(0,*)' l=',l,' dtvd=',dtvd(:,1) - - if (abs(dtvd(2,1)) > 1.0d-10) then - tem1 = dtvd(1,1) / dtvd(2,1) - tem2 = abs(tem1) - alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h - endif - -! write(0,*)' alfint=',alfint(l,1),' l=',l,' ipt=',ipt - - dtvd(1,1) = dtvd(2,1) -! - dtvd(2,2) = qoi(l) - qoi(lm1) - -! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) - - if (abs(dtvd(2,2)) > 1.0d-10) then - tem1 = dtvd(1,2) / dtvd(2,2) - tem2 = abs(tem1) - alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q - endif - dtvd(1,2) = dtvd(2,2) -! - dtvd(2,3) = qli(l) - qli(lm1) - -! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) - - if (abs(dtvd(2,3)) > 1.0d-10) then - tem1 = dtvd(1,3) / dtvd(2,3) - tem2 = abs(tem1) - alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql - endif - dtvd(1,3) = dtvd(2,3) -! - dtvd(2,4) = qii(l) - qii(lm1) - -! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) - - if (abs(dtvd(2,4)) > 1.0d-10) then - tem1 = dtvd(1,4) / dtvd(2,4) - tem2 = abs(tem1) - alfint(l,4) = one - half*(tem1 + tem2)/(one + 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) - -! write(0,*)' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l - - if (abs(dtvd(2,1)) > 1.0d-10) then - tem1 = dtvd(1,1) / dtvd(2,1) - tem2 = abs(tem1) - alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers - endif - dtvd(1,1) = dtvd(2,1) - enddo - enddo - endif - else - alfint(:,:) = half ! For second order scheme - endif - alfind(:) = half -! -! write(0,*)' after alfint for ipt=',ipt - -! Resolution dependent press grad correction momentum mixing - - if (CUMFRC) then - do l=krmin,k - tem = one - 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 -! write(0,*)' trcfac=',trcfac(krmin:k,1+trac) -! write(0,*)' alfint=',alfint(krmin:k,1) -! write(0,*)' alfinq=',alfint(krmin:k,2) -! write(0,*)' alfini=',alfint(krmin:k,4) -! write(0,*)' alfinu=',alfint(krmin:k,5) -! endif -! -! if (calkbl) kbl = k - - if (calkbl) then - kbl = kblmn - else - kbl = min(kbl, kblmn) - endif -! - DO NC=1,NCMX ! multi cloud loop -! - IB = IC(NC) ! cloud top level index - if (ib > kbl-1) cycle - -! lprint = lprnt .and. ipt == ipr .and. ib == 57 -! -! if (lprint) write(0,*)' 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 -! write(0,*)' toi=',(toi(ia,l),l=1,K) -! write(0,*)' qoi=',(qoi(ia,l),l=1,K),' kbl=',kbl -! write(0,*)' toi=',(toi(l),l=1,K) -! write(0,*)' qoi=',(qoi(l),l=1,K),' kbl=',kbl -! write(0,*)' prs=',(prs(l),l=1,K) -! endif -! - WFNC = zero - do L=IB,KP1 - FLX(L) = zero - FLXD(L) = zero - enddo -! -! if(lprint)then -! write(0,*) ' CALLING CLOUD TYPE IB= ', IB,' DT=',DT,' K=',K -! &, 'ipt=',ipt -! write(0,*) ' TOI=',(TOI(L),L=IB,K) -! write(0,*) ' QOI=',(QOI(L),L=IB,K) -! write(0,*) ' qliin=',qli -! write(0,*) ' qiiin=',qii -! endif -! - TLA = -10.0d0 -! - qiid = qii(ib) ! cloud top level ice before convection - qlid = qli(ib) ! cloud top level water before convection -! -! if(lprint) write(0,*)' uvitke=',uvi(ib:k,ntk-2), ' ib=',ib -! &,' trcmin=',trcmin(ntk-2) -! if (lprnt) then -! qoi_l(ib:k) = qoi(ib:k) -! qli_l(ib:k) = qli(ib:k) -! qii_l(ib:k) = qii(ib:k) -! endif - rainp = rain - - CALL CLOUD(K, KP1, IB, ntrc, kblmx, kblmn & - &, FRAC, MAX_NEG_BOUY, vsmooth, do_aw & - &, REVAP, WRKFUN, CALKBL, CRTFUN, 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_ & -! &, trcmin) - &, trcmin, ntk-2, c0, qw0, c0i, qi0, dlq_fac) -! &, ctei) - -! if(lprint) write(0,*)' uvitkea=',uvi(ib:k,ntk-2),' ib=',ib -! if (lprint) then -! write(0,*) ' rain=',rain,' ipt=',ipt -! write(0,*) ' after calling CLOUD TYPE IB= ', IB & -! &,' rain=',rain,' prskd=',prs(ib),' qli=',qli(ib),' qii=',qii(ib) -! &,' rainp=',rainp -! write(0,*) ' phi_h=',phi_h(K-5:KP1) -! write(0,*) ' TOI=',(TOI(L),L=1,K),' me=',me,' ib=',ib -! write(0,*) ' QOI=',(QOI(L),L=1,K) -! write(0,*) ' qliou=',qli -! write(0,*) ' qiiou=',qii -! sumq = 0.0 -! do l=ib,k -! sumq = sumq+(qoi(l)+qli(l)+qii(l)-qoi_l(l)-qli_l(l)-qii_l(l)) -! & * (prs(l+1)-prs(l)) * (100.0/grav) -! enddo -! write(0,*)' sumq=',sumq,' rainib=',rain-rainp,' ib=',ib - -! endif -! - if (flipv) then - do L=IB,K - 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 = kp1 - ib - det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) - - if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 - -! 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 - endif - - else - - do L=IB,K - ud_mf(ipt,l) = ud_mf(ipt,l) + flx(l+1) - dd_mf(ipt,l) = dd_mf(ipt,l) + flxd(l+1) - enddo - det_mf(ipt,ib) = det_mf(ipt,ib) + flx(ib) - - if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 -! if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ib=',ib -! &,' ud_mf=',ud_mf(ipt,:) - CNV_MFD(ipt,ib) = CNV_MFD(ipt,ib) + flx(ib)/dt -! if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ib) -! &,' ib=',ib,' kp1=',kp1 -! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) -! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt - CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) + flx(ib)* - & max(zero,(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,ib - endif - endif -! -! -! 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) = zero - QII(L) = zero - enddo - endif -! - ENDDO ! End of the NC loop! -! - RAINC(ipt) = rain * 0.001d0 ! Output rain is in meters - -! if (lprint) then -! write(0,*) ' convective precip=',rain*86400/dt,' mm/day' -! 1, ' ipt=',ipt -! write(0,*) ' toi',(tn0(imax,l),l=1,k) -! write(0,*) ' qoi',(qn0(imax,l),l=1,k) -! endif -! - -! - ktop(ipt) = kp1 - kbot(ipt) = 0 - - kcnv(ipt) = 0 - - - do l=k,1,-1 -! qli(l) = max(qli(l), zero) -! qii(l) = max(qii(l), zero) -! clw(i) = max(clw(i), zero) -! cli(i) = max(cli(i), zero) - - if (sgcs(l,ipt) < 0.93d0 .and. abs(tcu(l)) > one_m10) then -! if (sgcs(l,ipt) < 0.90d0 .and. tcu(l) .ne. 0.0) then -! if (sgcs(l,ipt) < 0.85d0 .and. 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) > zero .OR. & - & qli(l)+qii(l) > clwmin) ktop(ipt) = l - enddo - do l=1,km1 - if (clw(l)+cli(l) > zero .OR. & - & qli(l)+qii(l) > clwmin) kbot(ipt) = l - enddo -! - if (flipv) then - do l=1,k - 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 (mp_phys == 10) then - if (advcld) then - QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), zero) - QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), zero) - CNV_FICE(ipt,ll) = QICN(ipt,ll) - & / max(1.d-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.d-10,qii(l)+qli(l)) - endif -!! CNV_PRC3(ipt,ll) = PCU(l)/dt -! CNV_PRC3(ipt,ll) = zero -! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,ll - cf_upi(ipt,ll) = max(zero,min(0.02d0*log(one+ - & 500.0d0*ud_mf(ipt,ll)/dt), cfmax)) -! & 500*ud_mf(ipt,ll)/dt), 0.60)) -! if (lprint) write(0,*)' ll=',ll,' cf_upi=',cf_upi(ipt,ll) -! &,' ud_mf=',ud_mf(ipt,ll),' dt=',dt,' cfmax=',cfmax - 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.d-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 = 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 = 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 - ktop(ipt) - kbot(ipt) = kp1 - kbot(ipt) -! -! if (lprint) then -! write(0,*) ' tin',(tin(ia,l),l=k,1,-1) -! write(0,*) ' qin',(qin(ia,l),l=k,1,-1) -! endif -! - else - - do l=1,k - tin(ipt,l) = toi(l) ! Temperature - qin(ipt,l) = qoi(l) ! Specific humidity - uin(ipt,l) = uvi(l,trac+1) ! U momentum - vin(ipt,l) = uvi(l,trac+2) ! V momentum - -!! for 2M microphysics, always output these variables - if (mp_phys == 10) then - if (advcld) then - QLCN(ipt,l) = max(qli(l)-ccin(ipt,l,2), zero) - QICN(ipt,l) = max(qii(l)-ccin(ipt,l,1), zero) - CNV_FICE(ipt,l) = QICN(ipt,l) - & / max(1.d-10,QLCN(ipt,l)+QICN(ipt,l)) - else - QLCN(ipt,l) = qli(l) - QICN(ipt,l) = qii(l) - CNV_FICE(ipt,l) = qii(l)/max(1.d-10,qii(l)+qli(l)) - endif -!! CNV_PRC3(ipt,l) = PCU(l)/dt -! CNV_PRC3(ipt,l) = zero -! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,l - cf_upi(ipt,l) = max(zero,min(0.02d0*log(one+ - & 500.0d0*ud_mf(ipt,l)/dt), cfmax)) -! & 500*ud_mf(ipt,l)/dt), 0.60)) - CLCN(ipt,l) = cf_upi(ipt,l) !downdraft is below updraft - w_upi(ipt,l) = ud_mf(ipt,l)*toi(l)*rgas / - & (dt*max(cf_upi(ipt,l),1.d-12)*prsl(ipt,l)) - endif - - if (trac > 0) then - do n=1,trac - ccin(ipt,l,n+2) = uvi(l,n) ! Tracers - enddo - endif - enddo - if (advcld) then - do l=1,k - ccin(ipt,l,1) = qii(l) ! Cloud ice - ccin(ipt,l,2) = qli(l) ! Cloud water - enddo - else - do l=1,k - ccin(ipt,l,1) = ccin(ipt,l,1) + cli(l) - ccin(ipt,l,2) = ccin(ipt,l,2) + clw(l) - enddo - endif - endif -! -! -! if (lprint) then -! write(0,*) ' endtin',(tin(ia,l),l=k,1,-1) -! write(0,*) ' endqin',(qin(ia,l),l=k,1,-1) -! write(0,*) ' endqwin',(ccin(ia,l,2),l=k,1,-1) -! write(0,*) ' endqiin',(ccin(ia,l,1),l=k,1,-1) -! endif -! -! -! Velocity scale from the downdraft! -! - DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(KP1)-prs(K)) - -! if (lprint) write(0,*)' ddvel=',ddvel(ipt),' ddfac=',ddfac -! - 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.02d0 - 0.999999999d0 - IWK = MAX(1, MIN(IWK,16)) - ACR = (AC(IWK) + PL * AD(IWK)) * CCWF -! - RETURN - END - SUBROUTINE CLOUD( & - & K, KP1, KD, NTRC, KBLMX, kblmn & - &, FRACBL, MAX_NEG_BOUY, vsmooth, do_aw & - &, REVAP, WRKFUN, CALKBL, CRTFUN, 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_ & - &, trcmin, ntk, c0, qw0, c0i, qi0, dlq_fac) -! &, ctei) - -! -!*********************************************************************** -!******************** Relaxed Arakawa-Schubert ************************ -!****************** Plug Compatible Scalar Version ********************* -!************************ SUBROUTINE CLOUD **************************** -!************************ October 2004 **************************** -!******************** VERSION 2.0 (modified) ************************* -!************* Shrinivas.Moorthi@noaa.gov (301) 683-3718 ***** ******** -!*********************************************************************** -!*References: -!----------- -! 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. -! -! Relaxed Arakawa-Schubert Cumulus Parameterization (Version 2) -! with Convective Downdrafts - Unpublished Manuscript (2002) -! by Shrinivas Moorthi and Max 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(KP1) INPUT PRESSURE @ EDGES MB -!===> PRSM(K) INPUT PRESSURE @ LAYERS MB -!===> SGCS(K) INPUT Local sigma -!===> PHIH(KP1) INPUT GEOPOTENTIAL @ EDGES IN MKS units -!===> PHIL(K) INPUT GEOPOTENTIAL @ LAYERS IN MKS units -!===> PRJ(KP1) 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 -!===> kblmn INPUT lowest level the pbl can take -!===> DPD INPUT Critical normalized pressure (i.e. sigma) at the cloud top -! No downdraft calculation if the cloud top pressure is higher -! than DPD*PRS(KP1) -! -!===> TCU(K ) UPDATE TEMPERATURE TENDENCY DEG -!===> QCU(K ) UPDATE WATER VAPOR TENDENCY (G/G) -!===> RCU(K,NTRC)UPDATE TRACER TENDENCIES ND -!===> PCU(K) 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, WRKFUN, CALKBL, CRTFUN, CALCUP, ctei - LOGICAL REVAP, WRKFUN, CALKBL, CRTFUN, CALCUP - logical vsmooth, do_aw, lprnt - INTEGER K, KP1, KD, NTRC, kblmx, kblmn, ntk - - - real(kind=kind_phys), dimension(K) :: TOI, QOI, PRSM, QLI, QII& - &, PHIL, SGCS, rhc_ls & - &, alfind - real(kind=kind_phys), dimension(KP1) :: PRS, PHIH - real(kind=kind_phys), dimension(K,NTRC) :: ROI, trcfac - real(kind=kind_phys), dimension(ntrc) :: trcmin - real(kind=kind_phys) :: CD, 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 & - &, c0, qw0, c0i, qi0, dlq_fac - -! UPDATE ARGUMENTS - - real(kind=kind_phys), dimension(K) :: TCU, QCU, TCD, QCD, PCU - real(kind=kind_phys), dimension(KP1) :: FLX, FLXD - real(kind=kind_phys), dimension(K,NTRC) :: RCU - real(kind=kind_phys) :: CUP -! - real(kind=kind_phys), parameter :: ERRMIN=0.0001d0 & - &, ERRMI2=0.1d0*ERRMIN & -! &, rainmin=1.0e-9 & - &, rainmin=1.0d-8 & - &, oneopt9=one/0.09d0 & - &, oneopt4=one/0.04d0 - -! 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, sigf, rho - - real(kind=kind_phys), dimension(KD:KP1) :: GAF, GMS, GAM, DLB & - &, DLT, ETA, PRL, BUY, ETD, HOD, QOD, wvl - real(kind=kind_phys), dimension(KD:K-1) :: etzi - - real(kind=kind_phys) fscav_(ntrc) - - LOGICAL ep_wfn, cnvflg, LOWEST, 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), wcbase & - &, 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, delp -! &, almin1, almin2 - - INTEGER I, L, N, KD1, II, idh, lcon & - &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kmxh - &, kblh, kblm, kblpmn, kmax, kmaxm1, kmaxp1, klcl, kmin, kmxb -! -!*********************************************************************** -! -! almin2 = 0.2 * sqrt(pi/garea) -! almin1 = almin2 - - KM1 = K - 1 - KD1 = KD + 1 - - do l=1,K - tcd(L) = zero - qcd(L) = zero - enddo -! -! if (lprnt) then -! write(0,*) ' IN CLOUD for KD=',kd -! write(0,*) ' prs=',prs(Kd:KP1) -! write(0,*) ' phil=',phil(KD:K) -!! write(0,*) ' phih=',phih(kd:KP1),' kdt=',kdt -! write(0,*) ' phih=',phih(KD:KP1) -! write(0,*) ' toi=',toi(kd:k) -! write(0,*) ' qoi=',qoi(kd:k) -! endif -! - CLDFRD = zero - DOF = zero - PRL(KP1) = PRS(KP1) -! - DO L=KD,K - RNN(L) = zero - ZET(L) = zero - XI(L) = zero -! - TOL(L) = TOI(L) - QOL(L) = QOI(L) - PRL(L) = PRS(L) - CLL(L) = QLI(L) - CIL(L) = QII(L) - BUY(L) = zero - - wvl(l) = zero - ENDDO - wvl(kp1) = zero -! - if (vsmooth) then - do l=kd,k - wrk1(l) = tol(l) - wrk2(l) = qol(l) - enddo - do l=kd1,km1 - tol(l) = pt25*wrk1(l-1) + half*wrk1(l) + pt25*wrk1(l+1) - qol(l) = pt25*wrk2(l-1) + half*wrk2(l) + pt25*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) - - rho(l) = cmb2pa * pl / (rgas*tl*(one+nu*qol(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) = ONEOALHL * 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) = one + NU * QL - ETA(L) = ONE / (LTL(L) * VTF(L)) - - HOL(L) = TEM + QL * ALHL - HST(L) = TEM + QS * ALHL -! - ENDDO -! - ETA(KP1) = ZERO - GMS(K) = ZERO -! - AKT(KD) = HALF - GMS(KD) = ZERO -! - CLP = ZERO -! - GAM(KP1) = GAM(K) - GAF(KP1) = GAF(K) -! - DO L=K,KD1,-1 - DPHIB = PHIL(L) - PHIH(L+1) - DPHIT = PHIH(L) - PHIL(L) -! - DLB(L) = DPHIB * ETA(L) ! here eta contains 1/(L*(1+nu*q)) - 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 -! write(0,*) ' IN CLOUD for KD=',KD,' K=',K -! write(0,*) ' l=',l,' hol=',hol(l),' hst=',hst(l) -! write(0,*) ' TOL=',tol -! write(0,*) ' qol=',qol -! write(0,*) ' hol=',hol -! write(0,*) ' hst=',hst -! endif -! endif -! -! To determine KBL internally -- If KBL is defined externally -! the following two loop should be skipped -! -! if (lprnt) write(0,*) ' calkbl=',calkbl - - if (sgcs(kd) < 0.5d0) then - hcrit = hcritd - elseif (sgcs(kd) > 0.65d0) then - hcrit = hcrits - else - hcrit = (hcrits*(sgcs(kd)-0.5d0) + hcritd*(0.65d0-sgcs(kd))) - & * (one/0.15d0) - endif - 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)) > half * hcrit) then - kmxb = l - 1 - exit - endif - enddo - endif - kmaxm1 = kmax - 1 - kmaxp1 = kmax + 1 - kblpmn = kmax -! - dhdp(kmax:k) = zero - 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) > zero .and. l <= kmin) then - exit - endif - enddo - kbl = kmax - if (kblpmn < kmax) then - do l=kblpmn,kmaxm1 - if (hmax-hol(l) < half*hcrit) then - kbl = l - exit - endif - enddo - endif - -! if(lprnt) write(0,*)' kbl=',kbl,' 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) write(0,*)' klcl=',klcl -! 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.0d0,max(10.0d0,(prl(kmaxp1)-prl(kd))*0.10d0)) - if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii - -! if(lprnt) write(0,*)' 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) > half*hcrit) kbl = ii - endif - - if (prl(kbl) - prl(klcl) > pcrit_lcl) return -! -! KBL = min(kmax, MAX(KBL,KBLMX)) - KBL = min(kblmn, MAX(KBL,KBLMX)) -! kbl = min(kblh,kbl) -!!! -! tem1 = max(prl(kP1)-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(kp1)-prl(kbl) < tem1) then -! KTEM = MAX(KD+1, KBLMX) -! do l=k,KTEM,-1 -! tem = prl(kp1) - prl(l) -! if (tem > tem1) then -! kbl = min(kbl,l) -! exit -! endif -! enddo -! endif -! if (kbl == kblmx .and. kmax >= km1) kbl = k - 1 -!!! - - KPBL = KBL - -! if(lprnt)write(0,*)' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd -! if(lprnt)write(0,*)' tx3=',tx3,' tx1=',tx1,' tem=',tem -! &, ' hcrit=',hcrit,' kblmn=',kblmn - - ELSE - KBL = KPBL -! if(lprnt)write(0,*)' 2nd kbl=',kbl - ENDIF - -! if(lprnt)write(0,*)' after CALKBL l=',l,' hol=',hol(l) -! &, ' hst=',hst(l) -! - KBL = min(kmax, MAX(KBL,KD+2)) - KB1 = KBL - 1 -!! -! if (lprnt) write(0,*)' kbl=',kbl,' prlkbl=',prl(kbl),prl(kp1) - - if (PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd ) then -! & .or. PRL(Kmaxp1)-PRL(KBL) < bldmin) then - return - endif -! -! if (lprnt) write(0,*)' kbl=',kbl -! write(0,*)' kbl=',kbl,' kmax=',kmax,' kmaxp1=',kmaxp1,' k=',k -! - PRIS = ONE / (PRL(KP1)-PRL(KBL)) - PRISM = ONE / (PRL(Kmaxp1)-PRL(KBL)) - TX1 = ETA(KBL) ! geopotential height at KBL -! - GMS(KBL) = zero - XI(KBL) = zero - ZET(KBL) = zero -! - shal_fac = one -! if (prl(kbl)-prl(kd) < 300.0d0 .and. kmax == k) shal_fac = shalfac - if (prl(kbl)-prl(kd) < 350.0d0 .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) write(0,*)' l=',l,' eta=',eta(l),' kbl=',kbl - ENDDO - if (kmax < k) then - do l=kmaxp1,kp1 - eta(l) = zero - 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) write(0,*)' 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) - IDH = MAX(KD, IDH) ! Moorthi May, 31, 2019 -! - 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.0d0) & - & return -! - TX1 = RHFACS - QBL / TX1 ! Average RH - - cnvflg = (TEM > ZERO .OR. (LOWEST .AND. TEM1 >= ZERO)) & - & .AND. TX1 < RHRAM - -! if(lprnt) write(0,*)' 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)) write(0,*)' tx1=',tx1,' rhfacs=' -! &,rhfacs, ' tem=',tem,' hst=',hst(kd1) - - IF (.NOT. cnvflg) RETURN -! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0d0*TX1) )) -! - wcbase = 0.1d0 - 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 -! -! if (ntk > 0 .and. do_aw) then - if (ntk > 0) then - if (rbl(ntk) > zero) then - wcbase = min(two, max(wcbase, sqrt(twoo3*rbl(ntk)))) -! wcbase = min(one, max(wcbase, sqrt(twoo3*rbl(ntk)))) - endif - endif - -! if (lprnt) write(0,*)' wcbase=',wcbase,' rbl=', -! & rbl(ntk),' ntk=',ntk - - endif -! - TX4 = zero - TX5 = zero -! - 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 - lp1 = l + 1 - TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * half - ST2 = (GAF(L)+GAF(LP1)) * half -! - FCO(LP1) = TEM1 + ST2 * HBL - -! if(lprnt) write(0,*)' fco=',fco(l+1),' tem1=',tem1,' st2=',st2 -! &,' hbl=',hbl,' tx3=',tx3,' tem=',tem,' gaf=',gaf(l),' l=',l - - RNN(LP1) = ZET(LP1) * TEM1 + ST2 * TX4 - GMH(LP1) = XI(LP1) * 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(LP1) = (half*ALHF) * ST2 * (QIL(L)+QIL(LP1)) + ONE - ENDDO -! -! FOR THE CLOUD TOP -- L=KD -! - L = KD -! - lp1 = l + 1 - TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * half - ST2 = (GAF(L)+GAF(LP1)) * half -! - FCO(LP1) = TEM1 + ST2 * HBL - RNN(LP1) = ZET(LP1) * TEM1 + ST2 * TX4 - GMH(LP1) = XI(LP1) * 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) = zero - GMH(KBL) = zero -! - QIL(KD) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(KD))*TCRF)) - QLL(KD1) = (half*ALHF) * ST2 * (QIL(KD) + QIL(KD1)) + ONE - QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE -! -! if (lprnt) then -! write(0,*)' fco=',fco(kd:kbl) -! write(0,*)' qil=',qil(kd:kbl) -! write(0,*)' qll=',qll(kd:kbl) -! endif -! - st1 = qil(kd) - st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,zero)) - tem = c0 * (one-st1) - tem2 = st2*qi0 + tem*qw0 -! - DO L=KD,KB1 - lp1 = l + 1 - tx2 = akt(l) * eta(l) - tx1 = tx2 * tem2 - q0u(l) = tx1 - FCO(L) = FCO(LP1) - FCO(L) + tx1 - RNN(L) = RNN(LP1) - RNN(L) & - & + ETA(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*zet(l) - GMH(L) = GMH(LP1) - GMH(L) & - & + GMS(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*xi(l) -! - tem1 = (one-akt(l)) * eta(l) - -! if(lprnt) write(0,*)' qll=',qll(l),' st2=',st2,' tem=',tem -! &,' tx2=',tx2,' akt=',akt(l),' eta=',eta(l) - - AKT(L) = QLL(L) + (st2 + tem) * tx2 - -! if(lprnt) write(0,*)' akt==',akt(l),' l==',l - - AKC(L) = one / AKT(L) -! - st1 = half * (qil(l)+qil(lp1)) - st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,zero)) - tem = c0 * (one-st1) - tem2 = st2*qi0 + tem*qw0 -! - BKC(L) = QLL(LP1) - (st2 + tem) * tem1 -! - tx1 = tem1*tem2 - q0d(l) = tx1 - FCO(L) = FCO(L) + tx1 - RNN(L) = RNN(L) + tx1*zet(lp1) - GMH(L) = GMH(L) + tx1*xi(lp1) - ENDDO - -! if(lprnt) write(0,*)' akt=',akt(kd:kb1) -! if(lprnt) write(0,*)' akc=',akc(kd:kb1) - - qw00 = qw0 - qi00 = qi0 - ii = 0 - 777 continue -! -! if (lprnt) write(0,*)' after 777 ii=',ii,' ep_wfn=',ep_wfn -! - ep_wfn = .false. - RNN(KBL) = zero - TX3 = bkc(kb1) * (QIB + QLB) - TX4 = zero - TX5 = zero - DO L=KB1,KD1,-1 - TEM = BKC(L-1) * AKC(L) -! if (lprnt) write(0,*)' 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) write(0,*)' 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) write(0,*)' 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) write(0,*)' hsu=',hsu,' alm=',alm,' tx3=',tx3 - - HSU = HSU - ALM * TX3 -! - CLP = ZERO - ALM = -100.0d0 - HOS = HOL(KD) - QOS = QOL(KD) - QIS = CIL(KD) - QLS = CLL(KD) - - cnvflg = HBL > HSU .and. abs(tx1) > 1.0d-4 - -! if (lprnt) write(0,*)' 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 = one - st2 = hbl - hsu - -! if(lprnt) write(0,*)' tx2=',tx2,' tx1=',tx1,' st2=',st2 -! - if (tx2 == zero) then - alm = - st2 / tx1 - if (alm > almax) alm = -100.0d0 - else - x00 = tx2 + tx2 - epp = tx1 * tx1 - (x00+x00)*st2 - if (epp > zero) then - x00 = one / x00 - tem = sqrt(epp) - tem1 = (-tx1-tem)*x00 - tem2 = (-tx1+tem)*x00 - if (tem1 > almax) tem1 = -100.0d0 - if (tem2 > almax) tem2 = -100.0d0 - alm = max(tem1,tem2) - -! if (lprnt) write(0,*) ' tem1=',tem1,' tem2=',tem2,' alm=',alm -! &,' tx1=',tx1,' tem=',tem,' epp=',epp,' x00=',x00,' st2=',st2 - - endif - endif - -! if (lprnt) write(0,*)' 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 > zero) 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 == zero .and. qi00 == zero)) RETURN - CLP = one - ep_wfn = .true. - GO TO 888 - ENDIF -! -! if (lprnt) write(0,*)' 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 = zero - TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF - tx1 = PRL(KBL) - TEM - tx2 = min(900.0d0, max(tx1,100.0d0)) - tem1 = log(tx2*0.01d0) * oneolog10 - tem2 = one - tem1 - if ( kdt == 1 ) then -! rel_fac = (dt * facdt) / (tem1*12.0d0 + tem2*3.0d0) - rel_fac = (dt * facdt) / (tem1*6.0d0 + tem2*adjts_s) - else - rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*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 normalized MASS FLUX GOING OUT. -! GMS IS THE THICKNESS 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)) - ETAI(L) = one / ETA(L) - ENDDO - ETAI(KBL) = one - -! if (lprnt) write(0,*)' 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 = zero - dpneg = zero -! - DO L=KB1,KD1,-1 - lm1 = l - 1 - lp1 = l + 1 - DEL_ETA = ETA(L) - ETA(LP1) - HCCP = HCC + DEL_ETA*HOL(L) -! - QTLP = QST(LM1) - GAF(LM1)*HST(LM1) - QTVP = half * ((QTLP+QTL)*ETA(L) & - & + (GAF(L)+GAF(LM1))*HCCP) - ST1 = ETA(L)*Q0U(L) + ETA(LP1)*Q0D(L) - DETP = (BKC(L)*DET - (QTVP-QTV) & - & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) + ST1) * AKC(L) - -! if(lprnt) write(0,*)' detp=',detp,' bkc=',bkc(l),' det=',det -! if (lprnt .and. kd == 15) -! & write(0,*)' 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(LP1) - BKC(L) - RNS(L) = TEM1*DETP + TEM2*DET - ST1 - - qtp = half * (qil(L)+qil(LM1)) - tem2 = min(qtp*(detp-eta(l)*qw00), & - & (one-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) write(0,*)' hst=',hst(l),' ltl=',ltl(l),' nu=',nu -! if (lprnt .and. kd == 15) -! & write(0,*)' 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(LP1)*ST1 - ST2*(DET-TEM5*eta(lp1))) * DLB(L) - TEM4 = (TEM2 - ETA(L )*ST1 - ST2*(DETP-TEM5*eta(l))) * DLT(L) -! -! if (lprnt) then -! if (lprnt .and. kd == 12) then -! write(0,*)' tem3=',tem3,' tx1=',tx1,' st1=',st1,' eta1=',eta(l+1) -! &, ' st2=',st2,' det=',det,' tem5=',tem5,' dlb=',dlb(l) -! write(0,*)' tem4=',tem4,' tem2=',tem2,' detp=',detp -! &, ' eta=',eta(l),' dlt=',dlt(l),' rns=',rns(l),' l=',l -! write(0,*)' bt1=',tem3/(eta(l+1)*qrb(l)) -! &, ' bt2=',tem4/(eta(l)*qrt(l)) -! endif - - ST1 = TEM3 + TEM4 - -! if (lprnt) write(0,*)' wfn=',wfn,' st1=',st1,' l=',l,' ep_wfn=', -! &ep_wfn,' akm=',akm - - WFN = WFN + ST1 - AKM = AKM - min(ST1,ZERO) - -! if (lprnt) write(0,*)' wfn=',wfn,' akm=',akm - - if (st1 < zero .and. wfn < zero) then - dpneg = dpneg + prl(lp1) - prl(l) - endif - - BUY(L) = half * (tem3/(eta(lp1)*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) write(0,*)' ep_wfn=',ep_wfn,' ii=',ii,' rns=',rns(kd) -! &,' clp=',clp,' hst(kd)=',hst(kd) - - if (ep_wfn) then - IF ((qw00 == zero .and. qi00 == zero)) RETURN - if (ii == 0) then - ii = 1 - if (clp > zero .and. clp < one) 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 - lp1 = l + 1 - FCO(L) = FCO(L) - q0u(l) - q0d(l) - RNN(L) = RNN(L) - q0u(l)*zet(l) - q0d(l)*zet(lp1) - GMH(L) = GMH(L) - q0u(l)*xi(l) - q0d(l)*zet(lp1) - ETA(L) = ZET(L) - ZET(LP1) - GMS(L) = XI(L) - XI(LP1) - Q0U(L) = zero - Q0D(L) = zero - ENDDO - qw00 = zero - qi00 = zero - -! if (lprnt) write(0,*)' 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) write(0,*)' 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) write(0,*)' wfn=',wfn,' akm=',akm,' st1=',st1 -! &,' dpneg=',dpneg - - DET = DETP - HCC = HCCP - AKM = AKM / WFN - - -!*********************************************************************** -! - IF (WRKFUN) THEN ! If only to calculate workfunction save it and return - IF (WFN >= zero) WFNC = WFN - RETURN - ELSEIF (.NOT. CRTFUN) THEN - ACR = WFNC - ENDIF -! -!===> THIRD CHECK BASED ON CLOUD WORKFUNCTION -! - CALCUP = .FALSE. - - TEM = max(0.05d0, MIN(CD*200.0d0, MAX_NEG_BOUY)) - IF (.not. cnvflg .and. WFN > ACR .and. & - & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. - -! if (lprnt) write(0,*)' 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. zero) THEN -! IF (ALMIN1 .NE. ALMIN2) ST1 = one / max(ONE_M10,(ALMIN2-ALMIN1)) -! IF (ALM < ALMIN2) THEN -! CLP = CLP * max(zero, min(one,(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) write(0,*)' clp=',clp -! - CLP = CLP * RHC - dlq = zero - tem = one / (one + 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) = zero - ENDDO -! if (lprnt) write(0,*)' 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 (dpd > zero) THEN - TRAIN = zero - IF (CLP > zero) THEN - DO L=KD,KB1 - TRAIN = TRAIN + RNN(L) - ENDDO - ENDIF - - PL = (PRL(KD1) + PRL(KD))*HALF - IF (TRAIN > 1.0d-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. - ENDIF -! -! if (lprnt) then -! write(0,*)' BEFORE CALLING DDRFT KD=',kd,' DDFT=',DDFT -! &, ' PL=',PL,' TRAIN=',TRAIN -! write(0,*)' buy=',(buy(l),l=kd,kb1) -! endif - - IF (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) - CALL DDRFT( & - & K, KP1, KD & - &, TLA, ALFIND, wcbase & - &, 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, wvl, lprnt) - - ENDIF -! -! No Downdraft case (including case with no downdraft solution) -! --------------------------------------------------------- -! - IF (.NOT. DDFT) THEN - DO L=KD,KP1 - ETD(L) = zero - HOD(L) = zero - QOD(L) = zero - wvl(l) = zero - ENDDO - DO L=KD,K - EVP(L) = zero - ETZ(L) = zero - ENDDO - - ENDIF - -! if (lprnt) write(0,*) ' hod=',hod -! if (lprnt) write(0,*) ' etd=',etd -! if (lprnt) write(0,*) ' aft dd wvl=',wvl -! -! -!===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX -! Includes downdraft terms! - - avh = zero - -! -! 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 = zero -! tem1 = 1.0 -! if (kd1 == kbl) tem1 = 0.0 -! - tem2 = one - tem1 - TEM = DET * QIL(KD) - - - st1 = (HCC+ALHF*TEM-ETA(KD)*HST(KD)) / (one+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) write(0,*)' 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)) & - & + (one-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) = zero - GSD(KD) = zero -! - DO L=KD1,K - lm1 = l - 1 - 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(LM1) + ST1*HOL(L) - QB = ALFINT(L,2)*QOL(LM1) + ST2*QOL(L) - - TEM = ALFINT(L,4)*CIL(LM1) + ST4*CIL(L) - TEM2 = ALFINT(L,3)*CLL(LM1) + ST3*CLL(L) - - TEM1 = ETA(L) * (TEM - CIL(L)) - TEM3 = ETA(L) * (TEM2 - CLL(L)) - - HBD = ALFIND(L)*HOL(LM1) + ST5*HOL(L) - QBD = ALFIND(L)*QOL(LM1) + 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) write(0,*)' 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 + (one-QIL(L))*dlq(l)) * PRI(L) - QIL(L) = (TEM1 + QIL(L)*dlq(l)) * PRI(L) - - TEM1 = ETA(L) * (CIL(LM1) - TEM) - TEM3 = ETA(L) * (CLL(LM1) - TEM2) - - DH = ETA(L) * (HOL(LM1) - HB) - TEM5 - DS = DH - ALHL * ETA(L) * (QOL(LM1) - QB) & - & + ALHL * (TEM6 - EVP(LM1)) - - GMH(LM1) = GMH(LM1) + DH * PRI(LM1) - GMS(LM1) = GMS(LM1) + DS * PRI(LM1) -! -! if (lprnt) write(0,*)' 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(LM1) = GHD(LM1) - TEM5 * PRI(LM1) - GSD(LM1) = GSD(LM1) - (TEM5-ALHL*(TEM6-EVP(LM1))) * PRI(LM1) - - QIL(LM1) = QIL(LM1) + TEM1 * PRI(LM1) - QLL(LM1) = QLL(LM1) + TEM3 * PRI(LM1) - - -! if (lprnt) write(0,*)' 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(lm1)*(prs(l)-prs(lm1)) - - ENDDO -! - HBD = HOL(K) - QBD = QOL(K) - TEM5 = ETD(KP1) * (HOD(KP1) - HBD) - TEM6 = ETD(KP1) * (QOD(KP1) - 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) write(0,*)' 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 -! write(0,*)' gmh=',gmh -! write(0,*)' 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) * TESTMBOALHL - HST(L) = HST(L) + TEM2*(ONE+GAM(L))*TESTMB - QST(L) = QST(L) + TEM2*GAM(L) * TESTMBOALHL - CLL(L) = CLL(L) + QLL(L) * TESTMB - CIL(L) = CIL(L) + QIL(L) * TESTMB - ENDDO -! - if (alm > zero) then - HOS = HOS + GMH(KD) * TESTMB - QOS = QOS + (GMH(KD)-GMS(KD)) * TESTMBOALHL - QLS = QLS + QLL(KD) * TESTMB - QIS = QIS + QIL(KD) * TESTMB - else - st2 = one - st1s - HOS = HOS + (st1s*GMH(KD)+st2*GMH(KD1)) * TESTMB - QOS = QOS + (st1s * (GMH(KD)-GMS(KD)) & - & + st2 * (GMH(KD1)-GMS(KD1))) * TESTMBOALHL - 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)) * TESTMBOALHL - - 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) write(0,*)' 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*half)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(KB1))*TCRF)) -! - qtv = qbl - tx1 = qib + qlb -! - - DO L=KB1,KD1,-1 - lm1 = l - 1 - lp1 = l + 1 - DEL_ETA = ETA(L) - ETA(LP1) - HCCP = HCC + DEL_ETA*HOL(L) -! - QTLP = QST(LM1) - GAF(LM1)*HST(LM1) - QTVP = half * ((QTLP+QTL)*ETA(L) + (GAF(L)+GAF(LM1))*HCCP) - - DETP = (BKC(L)*TX1 - (QTVP-QTV) & - & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) & - & + ETA(L)*Q0U(L) + ETA(LP1)*Q0D(L)) * AKC(L) - IF (DETP <= ZERO) cnvflg = .TRUE. - - ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) - - TEM2 = (ALHF*half)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(LM1))*TCRF)) - TEM1 = HCCP + DETP * (TEM2+TX4) - - ST2 = LTL(L) * VTF(L) - TEM5 = CLL(L) + CIL(L) - AKM = AKM + & - & ( (TX2 -ETA(LP1)*ST1-ST2*(TX1-TEM5*eta(lp1))) * 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) * TESTMBI - - -!*********************************************************************** - -!===> MASS FLUX -! - AMB = - (WFN-ACR) / AKM -! -! if(lprnt) write(0,*)' wfn=',wfn,' acr=',acr,' akm=',akm & -! &,' amb=',amb,' KD=',kd,' cldfrd=',cldfrd & -! &,' rel_fac=',rel_fac,' prskd=',prs(kd) - -!===> RELAXATION AND CLIPPING FACTORS -! - AMB = AMB * CLP * rel_fac - -!!! 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) write(0,*)' AMB=',amb,' clp=',clp,' ambmax=',ambmax -!*********************************************************************** -!*************************RESULTS*************************************** -!*********************************************************************** - -!===> PRECIPITATION AND CLW DETRAINMENT -! - if (amb > zero) then - -! -! if (wvl(kd) > zero) then -! tx1 = one - amb * eta(kd) / (rho(kd)*wvl(kd)) -! sigf(kd) = max(zero, min(one, tx1 * tx1)) -! endif - if (do_aw) then - tx1 = (0.2d0 / max(alm, 1.0d-5)) - tx2 = one - min(one, pi * tx1 * tx1 / garea) -! if(lprnt) write(0,*)' kd=',kd,' alm=',alm,' tx1=',tx1 -! &,' garea=',garea,' pi=',pi,' tx2=',tx2 - tx2 = tx2 * tx2 -! if(lprnt) write(0,*)' kd=',kd,' wvl=',wvl(kd:k+1) -! if(lprnt) write(0,*)' kd=',kd,' eta=',eta(kd:k+1) -! if(lprnt) write(0,*)' kd=',kd,' rho=',rho(kd:k) -! comnet out the following for now - 07/23/18 -! do l=kd1,kbl -! lp1 = min(K, l+1) -! if (wvl(l) > zero .and. wvl(lp1) > zero) then -! tx1 = one - amb * (eta(l)+eta(lp1)) -! & / ((wvl(l)+wvl(lp1))*rho(l)*grav) -! sigf(l) = max(zero, min(one, tx1 * tx1)) -! else -! sigf(l) = min(one,tx2) -! endif -! sigf(l) = max(sigf(l), tx2) -! enddo -! sigf(kd) = sigf(kd1) -! if (kbl < k) then -! sigf(kbl+1:k) = sigf(kbl) -! endif - sigf(kd:k) = tx2 - else - sigf(kd:k) = one - endif - -! if(lprnt) write(0,*)' for kd=',kd,'sigf=',sigf(kd:k) -! - avt = zero - avq = zero - avr = dof * sigf(kbl) -! - DSFC = DSFC + AMB * ETD(K) * (one/DT) * sigf(kbl) -! -! DO L=KBL,KD,-1 - DO L=K,KD,-1 - PCU(L) = PCU(L) + AMB*RNN(L)*sigf(l) ! (A40) - avr = avr + rnn(l) * sigf(l) -! if(lprnt) write(0,*)' avr=',avr,' rnn=',rnn(l),' l=',l - ENDDO - pcu(k) = pcu(k) + amb * dof * sigf(kbl) -! -!===> TEMPARATURE AND Q CHANGE AND CLOUD MASS FLUX DUE TO CLOUD TYPE KD -! - TX1 = AMB * ONEBCP - TX2 = AMB * ONEOALHL - DO L=KD,K - delp = prs(l+1) - prs(l) - tx3 = amb * sigf(l) - ST1 = GMS(L) * TX1 * sigf(l) - TOI(L) = TOI(L) + ST1 - TCU(L) = TCU(L) + ST1 - TCD(L) = TCD(L) + GSD(L) * TX1 * sigf(l) -! - st1 = st1 - ELOCP * (QIL(L) + QLL(L)) * tx3 - - avt = avt + st1 * delp - - FLX(L) = FLX(L) + ETA(L) * tx3 - FLXD(L) = FLXD(L) + ETD(L) * tx3 -! - QII(L) = QII(L) + QIL(L) * tx3 - TEM = zero - - QLI(L) = QLI(L) + QLL(L) * tx3 + TEM - - ST1 = (GMH(L)-GMS(L)) * TX2 * sigf(l) - - QOI(L) = QOI(L) + ST1 - QCU(L) = QCU(L) + ST1 - QCD(L) = QCD(L) + (GHD(L)-GSD(L)) * TX2 * sigf(l) -! - avq = avq + (st1 + (QLL(L)+QIL(L))*tx3) * delp -! avq = avq + st1 * (prs(l+1)-prs(l)) -! avr = avr + (QLL(L) + QIL(L)*(1+alhf/alhl)) - avr = avr + (QLL(L) + QIL(L)) * delp * sigf(l) * gravcon - -! if(lprnt) write(0,*)' avr=',avr,' qll=',qll(l),' l=',l -! &, ' qil=',qil(l) - -! Correction for negative condensate! - if (qii(l) < zero) then - tem = qii(l) * elfocp - QOI(L) = QOI(L) + qii(l) - qcu(l) = qcu(l) + qii(l) - toi(l) = toi(l) - tem - tcu(l) = tcu(l) - tem - qii(l) = zero - endif - if (qli(l) < zero) then - tem = qli(l) * elocp - QOI(L) = QOI(L) + qli(l) - qcu(l) = qcu(l) + qli(l) - toi(l) = toi(l) - tem - tcu(l) = tcu(l) - tem - qli(l) = zero - endif - - ENDDO - avr = avr * amb -! -! Correction for negative condensate! -! if (advcld) then -! do l=kd,k -! if (qli(l) < zero) then -! qoi(l) = qoi(l) + qli(l) -! toi(l) = toi(l) - (alhl/cp) * qli(l) -! qli(l) = zero -! endif -! if (qii(l) < zero) then -! qoi(l) = qoi(l) + qii(l) -! toi(l) = toi(l) - ((alhl+alhf)/cp) * qii(l) -! qii(l) = zero -! endif -! enddo -! endif - -! -! -! if (lprnt) then -! write(0,*)' 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 -! write(0,*) ' 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 -! write(0,*) ' in CLOUD For KD=',KD -! write(0,*) ' TCU=',(tcu(l),l=kd,k) -! write(0,*) ' QCU=',(Qcu(l),l=kd,k) -! endif -! - TX1 = zero - TX2 = zero -! - IF (REVAP) THEN ! REEVAPORATION OF FALLING CONVECTIVE RAIN -! - tem = zero - do l=kd,kbl - IF (L < IDH .or. (.not. DDFT)) THEN - tem = tem + amb * rnn(l) * sigf(l) - endif - enddo - tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0d0/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(one, min(100.0d0,(6.25d10/max(garea,one))))) ! 20110530 - -! if (lprnt) write(0,*)' 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)) - cldfrd = clfrac - -! if (lprnt) then -! write(0,*) ' cldfrd=',cldfrd,' amb=',amb,' clfrac=',clfrac -! write(0,*) ' tx3=',tx3,' etakd=',eta(kd),' pri=',pri(kd) -! write(0,*) ' 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 - tem = amb * sigf(l) - TX2 = TX2 + tem * RNN(L) - CLDFRD = MIN(tem*CLDFR(L), clfrac) - ELSE - TX1 = TX1 + AMB * RNN(L) * sigf(l) - ENDIF - tx4 = zfac * phil(l) - tx4 = (one - tx4 * (one - half*tx4)) * afc -! - IF (TX1 > zero .OR. TX2 > zero) THEN - TEQ = TOI(L) - QEQ = QOI(L) - PL = half * (PRL(L+1)+PRL(L)) - - ST1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) - ST2 = ST1*ELFOCP + (one-ST1)*ELOCP - - CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) -! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) -! - DELTAQ = half * (QSTEQ*rhc_ls(l)-QEQ) / (one+ST2*DQDT) -! - QEQ = QEQ + DELTAQ - TEQ = TEQ - DELTAQ*ST2 -! - TEM1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) - TEM2 = TEM1*ELFOCP + (one-TEM1)*ELOCP - - CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) -! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) -! - DELTAQ = (QSTEQ*rhc_ls(l)-QEQ) / (one+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 = zero - if (tx1 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778d0 ) ) - ACTEVAP = MIN(TX1, TEM4*CLFRAC) - -! if(lprnt) write(0,*)' L=',L,' actevap=',actevap,' tem4=',tem4, -! &' clfrac=',clfrac,' potevap=',potevap,'tem4=',tem4 -! &,' tx1=',tx1,' rhc_ls=',rhc_ls(l) - - if (tx1 < rainmin*dt) actevap = min(tx1, potevap) -! - tem4 = zero - if (tx2 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778d0 ) ) - 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 * sigf(kbl) - ELSE - DO L=KD,K - TX1 = TX1 + AMB * RNN(L) * sigf(l) - ENDDO - CUP = CUP + TX1 + DOF * AMB * sigf(kbl) - ENDIF - -! if (lprnt) write(0,*)' 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,km1 - 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 - lm1 = l - 1 - ST1 = ONE - ALFIND(L) - HB = ALFIND(L) * HOL(LM1) + ST1 * HOL(L) - IF (ETZ(LM1) /= ZERO) THEN - TEM = ETZI(LM1) - IF (ETD(L) > ETD(LM1)) THEN - HOD(L) = (ETD(LM1)*(HOD(LM1)-HOL(LM1)) & - & + ETD(L) *(HOL(LM1)-HB) + ETZ(LM1)*HB) * TEM - ELSE - HOD(L) = (ETD(LM1)*(HOD(LM1)-HB) + ETZ(LM1)*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) > zero) then - DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001d0) - FNOSCAV = exp(- FSCAV_(N) * DELZKM) - else - FNOSCAV = one - endif - - GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOL(KD)) * trcfac(kd,n) & - & * FNOSCAV - DO L=KD1,K - if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001d0) - FNOSCAV = exp(- FSCAV_(N) * DELZKM) - endif - lm1 = l - 1 - ST1 = ONE - ALFINT(L,N+4) - ST2 = ONE - ALFIND(L) - HB = ALFINT(L,N+4) * HOL(LM1) + ST1 * HOL(L) - HBD = ALFIND(L) * HOL(LM1) + 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(LM1) - HB) * FNOSCAV - TEM5 - GMH(LM1) = GMH(LM1) + DH * PRI(LM1) * trcfac(l,n) - ENDDO -! - st2 = zero - DO L=KD,K - ST1 = GMH(L)*AMB*sigf(l) + st2 - st3 = HOL(L) + st1 - st2 = st3 - trcmin(n) ! if trcmin is defined limit change - if (st2 < zero) then - ROI(L,N) = trcmin(n) - RCU(L,N) = RCU(L,N) + ST1 - if (l < k) - & st2 = st2 * (prl(l+1)-prl(l))*pri(l+1) * (cmb2pa/grav) - else - ROI(L,N) = ST3 - RCU(L,N) = RCU(L,N) + ST1 - st2 = zero - endif - -! ROI(L,N) = HOL(L) + ST1 -! RCU(L,N) = RCU(L,N) + ST1 - -! if (l < k) then -! if (lprnt .and. n == ntk) write(0,*)' in ras roifin=',roi(l,n), -! &' hol=',hol(l),' gmh=',GMH(L),' amb=',amb,' l=',l -! &,' st2=',st2,' st3=',st3,' trcmin=',trcmin(n) -! &,' roi=',roi(l,n),' n=',n,' prl=',prl(l+1),prl(l),' pri=', -! & pri(l+1) -! else -! if (lprnt .and. n == ntk) write(0,*)' in ras roifin=',roi(l,n), -! &' hol=',hol(l),' gmh=',GMH(L),' amb=',amb,' l=',l -! &,' st2=',st2,' st3=',st3,' trcmin=',trcmin(n) -! &,' roi=',roi(l,n),' n=',n -! endif - - ENDDO - ENDDO ! Tracer loop NTRC - endif - endif ! amb > zero - -! if (lprnt) write(0,*)' toio=',toi -! if (lprnt) write(0,*)' qoio=',qoi - - RETURN - END - - SUBROUTINE DDRFT( & - & K, KP1, KD & - &, TLA, ALFIND, wcbase & - &, 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, wvlu, 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(KP1) 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, KP1, KD, KBL - real(kind=kind_phys) ALFIND(K), wcbase - - real(kind=kind_phys), dimension(kd:k) :: HOL, QOL, HST, QST & - &, TOL, QRB, QRT, RNN & - &, RNS, ETAI - real(kind=kind_phys), dimension(kd:kp1) :: 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:KP1) :: QRP, WVL, WVLU, ETD & - &, HOD, QOD, ROR, GMS - - real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1 & - &, QQQ, 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, AL2 & - &, TRAIN, GMF, ONPG, CTLA, VTRM & - &, RPART, QRMIN, AA1, BB1, CC1, DD1 & -! &, WC2MIN, WCMIN, WCBASE, F2, F3, F5 & - &, WC2MIN, WCMIN, F2, F3, F5 & - &, GMF1, GMF5, QRAF, QRBF, del_tla & - &, TLA, STLA, CTL2, CTL3 & -! &, 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 & - &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & - &, IDW, IDH, IDN(K), idnm -! - integer, parameter :: NUMTLA=2 -! integer, parameter :: NUMTLA=4 - parameter (ERRMIN=0.0001d0, ERRMI2=0.1d0*ERRMIN) -! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) -! - real (kind=kind_phys), parameter :: PIINV=one/PI -! real (kind=kind_phys), parameter :: PIINV=one/PI, pio2=half*pi -! - parameter (ONPG=one+half, GMF=one/ONPG, RPART=zero) -! 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.0d0, BB1=1.0d0, CC1=1.0d0, DD1=1.0d0, & - & F3=CC1, F5=1.0d0) - parameter (QRMIN=1.0d-6, WC2MIN=0.01d0, GMF1=GMF/AA1, GMF5=GMF/F5) -! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) - parameter (WCMIN=sqrt(wc2min)) -! parameter (sialf=0.5) -! - INTEGER ITR, ITRMU, ITRMD, KTPD, ITRMIN, ITRMND -! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=7) - PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=15, ITRMND=12) -! 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:KP1), QW(KD:K,KD:K) & - &, VT(2), VRW(2), TRW(2), QA(3), WA(3) - - LOGICAL SKPUP, cnvflg, DDFT, UPDRET, DDLGK, lprnt - -!*********************************************************************** - -! if(lprnt) write(0,*)' K=',K,' KD=',KD,' In Downdrft' - - KD1 = KD + 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 = PIO2 * ONEBG -! -! Compute Rain Water Budget of the Updraft (Cheng and Arakawa, 1997) -! - CLDFRD = zero - RNTP = zero - DOF = zero - ERRQ = 10.0d0 - RNB = zero - RNT = zero - TX2 = PRL(KBL) -! - TX1 = (PRL(KD) + PRL(KD1)) * half - ROR(KD) = CMPOR*TX1 / (TOL(KD)*(one+NU*QOL(KD))) -! GMS(KD) = VTP * ROR(KD) ** VTPEXP - GMS(KD) = VTP * VTPF(ROR(KD)) -! - QRP(KD) = QRMIN -! - TEM = TOL(K) * (one + NU * QOL(K)) - ROR(KP1) = half * CMPOR * (PRL(KP1)+PRL(K)) / TEM - GMS(KP1) = VTP * VTPF(ROR(KP1)) - QRP(KP1) = QRMIN -! - kk = kbl - DO L=KD1,K - TEM = half * (TOL(L)+TOL(L-1)) & - & * (one + (half*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) <= zero .and. kk == KBL) then - kk = l - endif - ENDDO - if (kk /= kbl) then - do l=kk,kbl - buy(l) = 0.9d0 * buy(l-1) - enddo - endif -! - do l=kd,k - qrpi(l) = buy(l) - enddo - do l=kd1,kb1 - buy(l) = 0.25d0 * (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.0d0 + tx1 - prl(kp1) -! CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) - CALL ANGRAD(TX1, ALM, AL2, TLA) -! -! Following Ucla approach for rain profile -! - F2 = (BB1+BB1)*ONEBG/(PI*0.2d0) -! WCMIN = SQRT(WC2MIN) -! WCBASE = WCMIN -! -! del_tla = TLA * 0.2 -! del_tla = TLA * 0.25 - del_tla = TLA * 0.3d0 - TLA = TLA - DEL_TLA -! - DO L=KD,K - RNF(L) = zero - RNS(L) = zero - STLT(L) = zero - GQW(L) = zero - QRP(L) = QRMIN - DO N=KD,K - QW(N,L) = zero - ENDDO - ENDDO -! DO L=KD,KP1 -! WVL(L) = zero -! 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) = one - GHD(KK) = one -! - 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 = half * (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 = half * (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) = zero -! - do ntla=1,numtla ! numtla is the the maximimu number of tilting angle tries - ! ------ -! if (errq < 1.0 .or. tla > 45.0) cycle - if (errq < 0.1d0 .or. tla > 45.0d0) cycle -! - tla = tla + del_tla - STLA = SIN(TLA*deg2rad) ! sine of tilting angle - CTL2 = one - STLA * STLA ! cosine square of tilting angle -! -! if (lprnt) write(0,*)' tla=',tla,' al2=',al2,' ptop=' -! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla -! if (lprnt) write(0,*)' buy=',(buy(l),l=kd,kbl) -! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364d0 * CTL2 -! - DO L=KD,K - RNF(L) = zero - STLT(L) = zero - QRP(L) = QRMIN - ENDDO - DO L=KD,KP1 - WVL(L) = zero - ENDDO - WVL(KBL) = WCBASE - STLT(KBL) = one / WCBASE -! - DO L=KD,KP1 - DO N=KD,K - AA(N,L) = zero - ENDDO - ENDDO -! - SKPUP = .FALSE. -! - DO ITR=1,ITRMU ! Rain Profile Iteration starts! - IF (.NOT. SKPUP) THEN -! wvlu = wvl -! -!-----CALCULATING THE VERTICAL VELOCITY -! - TX1 = zero - QRPI(KBL) = one / 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 - if (st1 > zero) then -! if (lprnt) write(0,*)' l=',l,' st1=',st1,' wvl=',wvl(l) - WVL(L) = max(ddunc1*SQRT(ST1) + ddunc2*WVL(L), wcmin) -! WVL(L) = SQRT(ST1) -! WVL(L) = max(half * (SQRT(ST1) + WVL(L)), wcmin) -! qrp(l) = half*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l)& -! & + qrp(l)) - else - -! if (lprnt) write(0,*)' l=',l,' st1=',st1,' wcb=',wcb(l),' qw=' -! &,qw(l,l),' qrp=',qrp(l),' tx1=',tx1,' gsd=',gsd(l),' itr=',itr -! &,' wvl=',wvl(l) - -! wvl(l) = 0.5*(wcmin+wvl(l)) -! wvl(l) = max(half*(wvl(l) + wvl(l+1)), wcmin) - wvl(l) = max(wvl(l),wcmin) - qrp(l) = (wvl(l)*wvl(l) - wcb(l) - tx1*gsd(l))/qw(l,l) -! qrp(l) = half*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l)& -! & + qrp(l)) - endif - qrp(l) = max(qrp(l), qrmin) - - STLT(L) = one / WVL(L) - QRPI(L) = one / QRP(L) - ENDDO -! -! if (lprnt) then -! write(0,*) ' ITR=',ITR,' ITRMU=',ITRMU,' kd=',kd,' kbl=',kbl -! write(0,*) ' WVL=',(WVL(L),L=KD,KBL) -! write(0,*) ' qrp=',(qrp(L),L=KD,KBL) -! write(0,*) ' qrpi=',(qrpi(L),L=KD,KBL) -! write(0,*) ' 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) * half - RNF(KD) = BUD(KD) - DOF = 1.1364d0 * BUD(KD) * QRPI(KD) - DOFW = -BUD(KD) * STLT(KD) -! - RNT = TRW(1) * VRW(1) - TX2 = zero - TX4 = zero - RNB = RNT - TX1 = half - TX8 = zero -! - IF (RNT >= zero) THEN - TX3 = (RNT-CTL3*TX6) * QRPI(KD) - TX5 = CTL2 * TX6 * STLT(KD) - ELSE - TX3 = zero - TX5 = zero - RNT = zero - RNB = zero - 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.1364d0 * 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 = pt25 * TEM3 * TEM4 - TEM4 = TEM4 * CTL3 -! -!-----BY QR ABOVE -! -! TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*TX7 - TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = pt25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) -!-----BY QR BELOW - TEM2 = pt25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = pt25*(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) = zero - IF (WVL(LL) == WCMIN) WA(2) = zero - IF (WVL(L) == WCMIN) WA(3) = zero - 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) ) * half - 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)) * half & - & - RNB + TX6 - BUD(LL) - AA(LL,KBL+1) = BUD(LL) - RNB = TX6 - TX1 = one - 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.1364d0 * 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 = pt25 * TEM3 * TEM4 - TEM4 = TEM4 * CTL3 -! -!-----BY QR ABOVE -! - TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = pt25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) -!-----BY QR BELOW - TEM2 = pt25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = pt25*(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) = zero - IF (WVL(LL) == WCMIN) WA(2) = zero - IF (WVL(L) == WCMIN) WA(3) = zero -! - 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) ) * half - - 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)) * half - RNB + TX6 - BUD(LL) -! - AA(LL,L+1) = BUD(LL) -! - RNB = TRW(2) * VRW(2) -! -! For the top of the boundary layer -! - IF (RNB < zero) THEN - KK = KBL - TEM = VT(2) * TRW(2) - QA(2) = (RNB - CTL3*TEM) * QRPI(KK) - WA(2) = CTL2 * TEM * STLT(KK) - ELSE - RNB = zero - QA(2) = zero - WA(2) = zero - ENDIF -! - QA(1) = TX2 - QA(2) = DOF + TX3 - QA(2) - QA(3) = zero -! - WA(1) = TX4 - WA(2) = DOFW + TX5 - WA(2) - WA(3) = zero -! - KK = KBL - IF (WVL(KK-1) == WCMIN) WA(1) = zero - IF (WVL(KK) == WCMIN) WA(2) = zero -! - 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)) * half - ENDDO - FAC = half - 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) = half*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) write(0,*) ' tx2a=',tx2,' aa1=',aa(kk,kk1) -! &,' qrpi=',qrpi(kk) -! - KK = KBL + 1 - DO L=KB1,KD,-1 - LP1 = L + 1 - TX1 = zero - 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) write(0,*)' tx2b=',tx2,' aa1=',aa(l,kk) -! &,' qrpi=',qrpi(l),' L=',L - - ENDDO -! -! tem = 0.5 - if (tx2 > one .and. abs(errq-tx2) > 0.1d0) then - tem = half -!! elseif (tx2 < 0.1) then -!! tem = 1.2 - else - tem = one - 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) write(0,*)' 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 = zero ! Rain profile exists! -! if (lprnt) write(0,*)' 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.5d0) THEN -! IF (TEM < ZERO .and. & -! & (ntla < numtla .or. ERRQ > 0.5)) THEN -! if (lprnt) write(0,*)' tx2=',tx2,' errq=',errq,' tem=',tem - SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0d0 ! No rain profile! -!!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN - ELSEIF (TX2 < ERRMIN) THEN - SKPUP = .TRUE. ! Converges ! - ERRQ = zero ! Rain profile exists! -! if (lprnt) write(0,*)' here2' - elseif (tem < zero .and. errq < 0.1d0) then - skpup = .true. -! if (ntla == numtla .or. tem > -0.003) then - errq = zero -! else -! errq = 10.0 -! endif - ELSE - ERRQ = TX2 ! Further iteration ! -! if (lprnt) write(0,*)' itr=',itr,' errq=',errq -! if (itr == itrmu .and. ERRQ > ERRMIN*10 & -! & .and. ntla == 1) ERRQ = 10.0 - ENDIF - ENDIF -! -! if (lprnt) write(0,*)' ERRQ=',ERRQ - - ENDIF ! SKPUP ENDIF! -! - ENDDO ! End of the ITR Loop!! -! -! if(lprnt) then -! write(0,*)' QRP=',(QRP(L),L=KD,KBL) -! write(0,*)'RNF=',(RNF(L),L=KD,KBL),' RNT=',RNT,' RNB=',RNB -! &,' errq=',errq -! endif -! - IF (ERRQ < 0.1d0) THEN - DDFT = .TRUE. - RNB = - RNB -! do l=kd1,kb1-1 -! if (wvl(l)-wcbase < 1.0E-9) ddft = .false. -! enddo - ELSE - DDFT = .FALSE. - ENDIF - - enddo ! End of ntla loop -! -! Caution !! Below is an adjustment to rain flux to maintain -! conservation of precip! -! - IF (DDFT) THEN - TX1 = zero - DO L=KD,KB1 - TX1 = TX1 + RNF(L) - ENDDO -! if (lprnt) write(0,*)' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train - TX1 = TRAIN / (TX1+RNT+RNB) -! if (lprnt) write(0,*)' tx1= ', tx1 - IF (ABS(TX1-one) < 0.2d0) THEN - RNT = MAX(RNT*TX1,ZERO) - RNB = RNB * TX1 - DO L=KD,KB1 - RNF(L) = RNF(L) * TX1 - ENDDO -! rain flux adjustment is over - -! if (lprnt) write(0,*)' TRAIN=',TRAIN -! if (lprnt) write(0,*)' RNF=',RNF - - ELSE - DDFT = .FALSE. - ERRQ = 10.0d0 - ENDIF - ENDIF -! - DOF = zero - IF (.NOT. DDFT) then - wvlu(kd:kp1) = zero - RETURN ! Rain profile did not converge! - ! No down draft for this case - rerurn - ! ------------------------------------ -! - else ! rain profile converged - do downdraft calculation - ! ------------------------------------------------ - - wvlu(kd:kp1) = wvl(kd:kp1) ! save updraft vertical velocity for output - -! if (lprnt) write(0,*)' in ddrft kd=',kd,'wvlu=',wvlu(kd:kp1) -! -! Downdraft calculation begins -! ---------------------------- -! - DO L=KD,K - WCB(L) = zero - ENDDO -! - ERRQ = 10.0d0 -! At this point stlt contains inverse of updraft vertical velocity 1/Wu. - - KK = MAX(KB1,KD1) - DO L=KK,K - STLT(L) = STLT(L-1) - ENDDO - TEM = stla / BB1 ! this is 2/(pi*radius*grav) -! - DO L=KD,K - IF (L <= KBL) THEN - STLT(L) = ETA(L) * STLT(L) * TEM / ROR(L) - ELSE - STLT(L) = zero - ENDIF - ENDDO -! if (lprnt) write(0,*)' STLT=',stlt - - rsum1 = zero - rsum2 = zero -! - IDN(:) = idnmax - DO L=KD,KP1 - ETD(L) = zero - WVL(L) = zero -! QRP(L) = zero - ENDDO - DO L=KD,K - EVP(L) = zero - BUY(L) = zero - QRP(L+1) = zero - ENDDO - HOD(KD) = HOL(KD) - QOD(KD) = QOL(KD) - TX1 = zero -!!! 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 = zero - TX5 = TX1 - QA(1) = zero -! if(lprnt) write(0,*)' 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 > zero) THEN - if (TX1 > zero) THEN - QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (one/1.1364d0) - else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364d0) - endif - RNTP = (one - RPART) * RNT - BUY(KD) = - ROR(KD) * TX1 * QRP(KD) - ELSE - QRP(KD) = zero - ENDIF -! -! L-loop for the downdraft iteration from KD1 to KP1 (bottom surface) -! -! BUD(KD) = ROR(KD) - idnm = 1 - DO L=KD1,KP1 - - QA(1) = zero - ddlgk = idn(idnm) == idnmax - if (.not. ddlgk) cycle - IF (L <= K) THEN - ST1 = one - 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 = two - IF (L == KD1) FAC = one - - FACG = FAC * half * GMF5 ! 12/17/97 -! -! DDLGK = IDN(idnm) == 99 - - BUD(KD) = ROR(L) - - 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) write(0,*)' 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) = one / TRW(1) -! - VRW(1) = half * (GAM(L-1) + GAM(L)) - VRW(2) = one / (VRW(1) + VRW(1)) -! - TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.0d0*EKNOB) -! - DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! -! - ETD(L) = ETD(L-1) - HOD(L) = HOD(L-1) - QOD(L) = QOD(L-1) -! - ERRQ = 10.0d0 - -! - IF (L <= KBL) THEN - TX3 = STLT(L-1) * QRT(L-1) * (half*FAC) - TX8 = STLT(L) * QRB(L-1) * (half*FAC) - TX9 = TX8 + TX3 - ELSE - TX3 = zero - TX8 = zero - TX9 = zero - ENDIF -! - TEM = WVL(L-1) + VT(1) - IF (TEM > zero) THEN - TEM1 = one / (TEM*ROR(L-1)) - TX3 = VT(1) * TEM1 * ROR(L-1) * TX3 - TX6 = TX1 * TEM1 - ELSE - TX6 = one - ENDIF -! - IF (L == KD1) THEN - IF (RNT > zero) THEN - TEM = MAX(QRP(L-1),QRP(L)) - WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0d0) - ENDIF - WVL(L) = MAX(ONE_M2, WVL(L)) - TRW(1) = TRW(1) * half - 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) = zero - HOD(L) = WA(1) - QOD(L) = WA(2) - EVP(L-1) = zero - WVL(L) = zero - QRP(L) = zero - BUY(L) = zero - TX5 = TX9 - ERRQ = zero - RNTP = RNTP + RNT * TX1 - RNT = zero - WCB(L-1) = zero - -! ENDIF -! BUD(KD) = ROR(L) -! -! Iteration loop for a given level L begins -! -! if (lprnt) write(0,*)' tx8=',tx8,' tx9=',tx9,' tx5=',tx5 -! &, ' tx1=',tx1 - else - 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 > zero) THEN - ST1 = ROR(L) * TEM * QRP(L) + RNT - IF (ST1 /= zero) ST1 = two * EVP(L-1) / ST1 - TEM1 = one / (TEM*ROR(L)) - TEM2 = VT(1) * TEM1 * ROR(L) * TX8 - ELSE - TEM1 = zero - TEM2 = TX8 - ST1 = zero - ENDIF -! if (lprnt) write(0,*)' 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 > zero) then - TX5 = (TX1 - ST1 + TEM2 + TX3)/(one+tem*tem1) - else - TX5 = TX1 - tem*tx6 - ST1 + TEM2 + TX3 - endif - TX5 = MAX(TX5,ZERO) - tx5 = half * (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) write(0,*)' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' -! if(tx5 <= 0.0 .and. l > kd+2) -! & write(0,*)' 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) write(0,*)' 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) > zero) etd(l) = half * (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 = (half + ASIN(TEM2)*PIINV)*DEL_ETA + TEM1*PIINV - - DDZ = EDZ - DEL_ETA - WCB(L-1) = ETD(L) + DDZ -! - TEM1 = HOD(L) - IF (DEL_ETA > zero) THEN - QQQ = one / (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) > zero) then - QQQ = one / (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) write(0,*)' 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) + half * (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.6d0 + 124.9d0 * QRAF) * QRBF * TX4 -! - CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) -! - TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (one + 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.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) -! CEE = CE * (ETD(L)+DDZ) -! - - - TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (one + 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) - QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) -! -! if(lprnt) write(0,*)' etd=',etd(l),' tx5=',tx5,' rnt=',rnt -! *,' rnf=',rnf(l-1),' evp=',evp(l-1),' itr=',itr,' L=',L -! - if (qa(1) > zero) then - IF (ETD(L) > zero) THEN - TEM = QA(1) / (ETD(L)+ROR(L)*TX5*VT(1)) - QRP(L) = MAX(TEM,ZERO) - ELSEIF (TX5 > zero) THEN - QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & - & ** (one/1.1364d0) - ELSE - QRP(L) = zero - ENDIF - else - qrp(l) = half * qrp(l) - endif -! Compute Buoyancy - TEM1 = WA(3) + (HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & - & * onebcp -! if (lprnt) write(0,*)' 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 * (one + NU*QOD(L)) - ROR(L) = CMPOR * PRL(L) / TEM1 - TEM1 = TEM1 * DOFW -!!! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW - - BUY(L) = (TEM1 - one - 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) write(0,*)' 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) < zero) 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.0d-10 - else - WVL(L) = half*(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) write(0,*)' errw=',errw,' wvl=',wvl(l) -! if(lprnt .or. tx5 == 0.0) then -! if(tx5 == 0.0 .and. l > kbl) then -! write(0,*)' 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) write(0,*)' itr=',itr,' itrmnd=',itrmnd,' itrmd=',itrmd -! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN - IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN -! if(lprnt) write(0,*)' itr=',itr,' etd1=',etd(l-1),' errq=',errq - IF (ETD(L-1) == zero .AND. ERRQ > 0.2d0) THEN -! if(lprnt) write(0,*)' bud=',bud(kd),' wa=',wa(1),wa(2) - ROR(L) = BUD(KD) - ETD(L) = zero - WVL(L) = zero - ERRQ = zero - HOD(L) = WA(1) - QOD(L) = WA(2) -! TX5 = TX1 + TX9 - if (L <= KBL) then - TX5 = TX9 - else - TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5d0*FAC) - endif - -! if(lprnt) write(0,*)' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) -! *,' evp=',evp(l-1),' l=',l - - EVP(L-1) = zero - TEM = MAX(TX1*RNT+RNF(L-1),ZERO) - QA(1) = TEM - EVP(L-1) -! IF (QA(1) > 0.0) THEN - -! if(lprnt) write(0,*)' 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) -! * write(0,*)' 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))) & - & ** (one/1.1364d0) -! endif - BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = zero - ENDIF -! - DEL_ETA = ETD(L) - ETD(L-1) - IF(DEL_ETA < zero .AND. ERRQ > 0.1d0) THEN - ROR(L) = BUD(KD) - ETD(L) = zero - WVL(L) = zero -!!!!! TX5 = TX1 + TX9 - CLDFRD(L-1) = TX5 -! - DEL_ETA = - ETD(L-1) - EDZ = zero - 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) + half * (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.6d0 + 124.9d0 * QRAF) * QRBF * TX4 -! - CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) -! - - TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (one + 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.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) -! CEE = CE * (ETD(L)+DDZ) -! - - - TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (one + 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) = zero - -! -! if (tx5 == 0.0 .or. gms(l) == 0.0) -! if (lprnt) -! * write(0,*)' 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) = zero - ENDIF - tx5 = tx9 - ERRQ = zero - QRP(L) = zero - BUY(L) = zero -! - ENDIF - ENDIF - ENDIF -! - ENDDO ! End of the iteration loop for a given L! - IF (L <= K) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.1d0 .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) = zero -! 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 -! write(0,*)' 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))) & - & ** (one/1.1364d0) -! ENDIF - ETD(L) = zero - WVL(L) = zero - ST1 = one - ALFIND(L) - - ERRQ = zero - BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = zero - ENDIF - ENDIF -! - LL = MIN(IDN(idnm), KP1) - IF (ERRQ < one .AND. L <= LL) THEN - IF (ETD(L-1) > zero .AND. ETD(L) == zero) THEN - IDN(idnm) = L - wvl(l) = zero - if (L < KBL .or. tx5 > zero) idnm = idnm + 1 - errq = zero - ENDIF - if (etd(l) == zero .and. l > kbl) then - idn(idnm) = l - if (tx5 > zero) idnm = idnm + 1 - endif - ENDIF - -! if (lprnt) then -! write(0,*)' ERRQ=',ERRQ,' IDN=',IDN(idnm),' idnm=',idnm -! write(0,*)' 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.1d0 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. -! - DOF = zero - IF (.NOT. DDFT) RETURN -! -! if (ddlgk .or. l .le. idn(idnm)) then -! rsum2 = rsum2 + evp(l-1) -! write(0,*)' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' qa=',qa(1)& -! &, ' evp=',evp(l-1) -! else -! rsum1 = rsum1 + rnf(l-1) -! write(0,*)' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' rnf=', & -! & rnf(l-1) -! endif - - endif ! if (l < idh) - ENDDO ! End of the L Loop of downdraft ! - - TX1 = zero - - DOF = QA(1) -! -! write(0,*)' dof=',dof,' rntp=',rntp,' rnb=',rnb -! write(0,*)' total=',(rsum1+dof+rntp+rnb) -! - dof = max(dof, zero) - RNN(KD) = RNTP - TX1 = EVP(KD) - TX2 = RNTP + RNB + DOF - -! if (lprnt) write(0,*)' tx2=',tx2 - II = IDH - IF (II >= KD1+1) THEN - RNN(KD) = RNN(KD) + RNF(KD) - TX2 = TX2 + RNF(KD) - RNN(II-1) = zero - TX1 = EVP(II-1) - ENDIF -! if (lprnt) write(0,*)' 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) = zero - HOD(L+1) = zero - QOD(L+1) = zero - EVP(L) = zero - RNN(L) = RNF(L) + RNS(L) - TX2 = TX2 + RNN(L) - ENDIF -! if (lprnt) write(0,*)' 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) write(0,*)' train=',train,' tx2=',tx2,' tx1=',tx1 - - IF (TX1 > zero) THEN - TX1 = (TRAIN - TX2) / TX1 - ELSE - TX1 = zero - ENDIF - - DO L=KD,K - EVP(L) = EVP(L) * TX1 - ENDDO - - ENDIF ! if (.not. DDFT) loop endif -! -!*********************************************************************** -!*********************************************************************** - - 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), parameter :: ZERO=0.0d0, ONE=1.0d0 & - &, ONE_M10=1.0d-10 & - &, rvi=one/rv, facw=CVAP-CLIQ & - &, faci=CVAP-CSOL, hsub=HVAP+HFUS & - &, tmix=TTP-20.0d0 & - &, DEN=one/(TTP-TMIX) -! logical lprnt -! - real(kind=kind_phys) es, d, hlorv, W -! -! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = min(p, 0.01d0 * fpvs(tt)) ! fpvs is in Pascals! -! D = one / max(p+epsm1*es,ONE_M10) - D = one / (p+epsm1*es) -! - q = MIN(eps*es*D, ONE) -! - W = max(ZERO, min(ONE, (TT - TMIX)*DEN)) - hlorv = ( W * (HVAP + FACW * (tt-ttp)) & - & + (one-W) * (HSUB + FACI * (tt-ttp)) ) * RVI - dqdt = p * q * hlorv * D / (tt*tt) -! - return - end - - SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) - 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 -! - integer i -! - IF (TLA < 0.0d0) 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.0d-4 / tem - al2 = min(4.0d0*tem, max(alm, tem)) -! - RETURN - END - SUBROUTINE SETQRP - USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB,one - implicit none - - real(kind=kind_phys) tem2,tem1,x,xinc,xmax,xmin - integer jx -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! XMIN = 1.0E-6 - XMIN = 0.0d0 - XMAX = 5.0d0 - XINC = (XMAX-XMIN)/(NQRP-1) - C2XQRP = one / XINC - C1XQRP = one - XMIN*C2XQRP - TEM1 = 0.001d0 ** 0.2046d0 - TEM2 = 0.001d0 ** 0.525d0 - DO JX=1,NQRP - X = XMIN + (JX-1)*XINC - TBQRP(JX) = X ** 0.1364d0 - TBQRA(JX) = TEM1 * X ** 0.2046d0 - TBQRB(JX) = TEM2 * X ** 0.525d0 - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - FUNCTION QRPF(QRP) -! - USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB, one - implicit none - - real(kind=kind_phys) QRP, QRPF, XJ, REAL_NQRP - 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, one - implicit none -! - real(kind=kind_phys) QRP, QRAF, QRBF, XJ, REAL_NQRP - 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, VTPEXP,one - implicit none - - real(kind=kind_phys) xinc,x,xmax,xmin - integer jx -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05d0 - XMAX = 1.5d0 - XINC = (XMAX-XMIN)/(NVTP-1) - C2XVTP = one / XINC - C1XVTP = one - 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, one - implicit none - real(kind=kind_phys) ROR, VTPF, XJ, REAL_NVTP - 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.30d0, ccf2=0.09d0 & - &, ccf3=0.04d0, ccf4=0.01d0 & - &, pr1=1.0d0, pr2=5.0d0 & - &, pr3=20.0d0 -! - 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/gfsphysics/physics/rayleigh_damp.f b/gfsphysics/physics/rayleigh_damp.f deleted file mode 100644 index 8149fa02f..000000000 --- a/gfsphysics/physics/rayleigh_damp.f +++ /dev/null @@ -1,90 +0,0 @@ - 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/gfsphysics/physics/rayleigh_damp_mesopause.f b/gfsphysics/physics/rayleigh_damp_mesopause.f deleted file mode 100644 index 9338f92b4..000000000 --- a/gfsphysics/physics/rayleigh_damp_mesopause.f +++ /dev/null @@ -1,105 +0,0 @@ - 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/gfsphysics/physics/samfaerosols.f b/gfsphysics/physics/samfaerosols.f deleted file mode 100644 index aaafa9743..000000000 --- a/gfsphysics/physics/samfaerosols.f +++ /dev/null @@ -1,802 +0,0 @@ - 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/gfsphysics/physics/samfdeepcnv.f b/gfsphysics/physics/samfdeepcnv.f deleted file mode 100644 index 25a17d5f4..000000000 --- a/gfsphysics/physics/samfdeepcnv.f +++ /dev/null @@ -1,2865 +0,0 @@ -!> \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 (1−sigma) 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, - & 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, - & do_ca,ca_closure,ca_entr,ca_trigger,nthresh,ca_deep, - & rainevap) -! - 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) - 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 -! for CA stochastic physics: - logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger - real(kind=kind_phys), intent(in) :: nthresh - real(kind=kind_phys), intent(in) :: ca_deep(im) - real(kind=kind_phys), intent(out) :: rainevap(im) -! -!------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=150.,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)) - rainevap(i)=0. - 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 -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif -!! - 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 -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif - - 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 -! - if(do_ca .and. ca_entr)then - do i=1,im - if(cnvflg(i)) then - if(ca_deep(i) > nthresh)then - clamt(i) = clam - clamd - else - clamt(i) = clam - endif - endif - enddo - else - do i=1,im - if(cnvflg(i))then - clamt(i) = clam - endif - enddo - endif -! - 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 -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif -!! - 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 -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif - -!! - 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 -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif - -!! - 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 / (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 -c -c - if (do_ca .and. ca_closure)then - do i = 1, im - if(cnvflg(i)) then - if (ca_deep(i) > nthresh) then - xmb(i) = xmb(i)*1.25 - endif - endif - enddo - endif - -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 - -!LB: - if(do_ca)then - do i = 1,im - rainevap(i)=delqev(i) - enddo - endif -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/gfsphysics/physics/samfshalcnv.f b/gfsphysics/physics/samfshalcnv.f deleted file mode 100644 index 5384385d6..000000000 --- a/gfsphysics/physics/samfshalcnv.f +++ /dev/null @@ -1,1809 +0,0 @@ -!> \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/gfsphysics/physics/sascnv.f b/gfsphysics/physics/sascnv.f deleted file mode 100644 index 93ac11a9a..000000000 --- a/gfsphysics/physics/sascnv.f +++ /dev/null @@ -1,1811 +0,0 @@ - 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, - & 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) -! 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,rgas => con_rd - 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) -! - 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 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. - if(mp_phys == 10) then - QLCN(i,k) = 0.0 - QICN(i,k) = 0.0 - w_upi(i,k) = 0.0 - cf_upi(i,k) = 0.0 - CNV_MFD(i,k) = 0.0 -! CNV_PRC3(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 - end if - 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 - - if(mp_phys == 10) then - do k=1,km - do i=1,im - QLCN(i,k) = ql(i,k,2) - QICN(i,k) = ql(i,k,1) - cf_upi(i,k) = cnvc(i,k) - w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rgas / - & (dt2*max(cf_upi(i,k),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/gfsphysics/physics/sascnvn.f b/gfsphysics/physics/sascnvn.f deleted file mode 100644 index 208c423aa..000000000 --- a/gfsphysics/physics/sascnvn.f +++ /dev/null @@ -1,2081 +0,0 @@ -!> \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, & - & 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,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,rgas => con_rd - 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 - 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 i, indx, jmn, k, kk, km1, mp_phys - 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. - if(mp_phys == 10) then - QLCN(i,k) = 0.0 - QICN(i,k) = 0.0 - w_upi(i,k) = 0.0 - cf_upi(i,k) = 0.0 - CNV_MFD(i,k) = 0.0 -! CNV_PRC3(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 - end if - 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 - - if(mp_phys == 10) then - do k=1,km - do i=1,im - QLCN(i,k) = ql(i,k,2) - QICN(i,k) = ql(i,k,1) - cf_upi(i,k) = cnvc(i,k) - w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rgas / - & (dt2*max(cf_upi(i,k),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 -! \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/gfsphysics/physics/satmedmfvdif.f b/gfsphysics/physics/satmedmfvdif.f deleted file mode 100644 index f96ef20f1..000000000 --- a/gfsphysics/physics/satmedmfvdif.f +++ /dev/null @@ -1,1419 +0,0 @@ -!!!!! ================================================================== !!!!! -! 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. -! -!---------------------------------------------------------------------- - subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,ntke, - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea, - & 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_m,xkzm_h,xkzm_s) -! - 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 - integer 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), - & 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) -! - logical dspheat -! flag for tke dissipative heating -! -!---------------------------------------------------------------------- -!*** -!*** 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.,xkgdx=25000.) - 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.) -! -!************************************************************************ - dt2 = delt - rdt = 1. / dt2 -! -! the code is written assuming ntke=ntrac -! if ntrac > ntke, the code needs to be modified -! - 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(i,k,ntke), tkmin) - enddo - enddo - do k=1,km1 - do i=1,im - tkeh(i,k) = 0.5 * (tke(i,k) + tke(i,k+1)) - 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 -! -! 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) - 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 - 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(i,k,ntcw),qlmin) - tem1 = max(q1(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(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(tem1 > 1.e-5) then - xkzo(i,k) = min(xkzo(i,k),xkzinv) - xkzmo(i,k) = min(xkzmo(i,k),xkzinv) - 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 -! - call mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,dt2, - & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, - & gdx,hpbl,kpbl,vpert,buou,xmf, - & tcko,qcko,ucko,vcko,xlamue) -! - call mfscu(im,ix,km,kmscu,ntcw,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 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! 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)) - 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 - qcko(i,k,ntke) = tke(i,k) - endif - if(scuflg(i)) then - qcdo(i,k,ntke) = 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 - qcko(i,k,ntke)=((1.-tem)*qcko(i,k-1,ntke)+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 - qcdo(i,k,ntke)=((1.-tem)*qcdo(i,k+1,ntke)+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) - ptem = qcko(i,k,ntke) + qcko(i,k+1,ntke) - 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) - ptem = qcdo(i,k,ntke) + qcdo(i,k+1,ntke) - 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 -! f1(i,k) = max(f1(i,k), tkmin) - qtend = (f1(i,k)-q1(i,k,ntke))*rdt - rtg(i,k,ntke) = rtg(i,k,ntke)+qtend - enddo - enddo -c -c compute tridiagonal matrix elements for heat and moisture -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) - 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) - 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 -! -! 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 satmedmfvdif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - 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/gfsphysics/physics/satmedmfvdifq.f b/gfsphysics/physics/satmedmfvdifq.f deleted file mode 100644 index 77ac36b97..000000000 --- a/gfsphysics/physics/satmedmfvdifq.f +++ /dev/null @@ -1,1391 +0,0 @@ -!!!!! ================================================================== !!!!! -! subroutine 'satmedmfvdifq.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 (mfpbltq.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. -! -! Updated version of satmedmfvdif.f (May 2019) to have better low level -! inversion, to reduce the cold bias in lower troposphere, -! and to reduce the negative wind speed bias in upper troposphere -! -!---------------------------------------------------------------------- - subroutine satmedmfvdifq(ix,im,km,ntrac,ntcw,ntiw,ntke, -!wz & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea, - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,islimsk,snwdph, - & 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_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr) -! - 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 - integer kpbl(im), kinver(im) -! -!wz - integer islimsk(im) - real(kind=kind_phys), dimension(im,3), intent(in) :: snwdph -! - real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s, dspfac, - & bl_upfr, bl_dnfr - 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) -! - logical dspheat -! flag for tke dissipative heating -! -!---------------------------------------------------------------------- -!*** -!*** 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-1),xkzmo(im,km-1), - & xkzm_hx(im), xkzm_mx(im), 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, ri, - & 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, xkzinv, xkgdx, - & zlup, zldn, bsum, - & tem, tem1, tem2, - & ptem, ptem0, ptem1, ptem2 -!wz - real(kind=kind_phys) xkzm_mp, xkzm_hp -! - 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=3.0) - 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.,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) - parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) - parameter(ce0=0.4) - parameter(rchck=1.5,ndt=20) -! -!************************************************************************ - dt2 = delt - rdt = 1. / dt2 -! -! the code is written assuming ntke=ntrac -! if ntrac > ntke, the code needs to be modified -! - 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(i,k,ntke), tkmin) - enddo - enddo - do k=1,km1 - do i=1,im - tkeh(i,k) = 0.5 * (tke(i,k) + tke(i,k+1)) - 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.) -! -!wz - do i=1,im - xkzm_mp = xkzm_m - xkzm_hp = xkzm_h -! - if( islimsk(i) == 1 .and. snwdph(i,1) > 10.0 ) then ! over land - if (rbsoil(i) > 0. .and. rbsoil(i) <= 0.25) then - xkzm_mp = xkzm_m * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - xkzm_hp = xkzm_h * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - else if (rbsoil(i) > 0.25) then - xkzm_mp = 0.1 - xkzm_hp = 0.1 - endif - endif -!# - kx1(i) = 1 - tx1(i) = 1.0 / prsi(i,1) - tx2(i) = tx1(i) - if(gdx(i) >= xkgdx) then -!wz xkzm_hx(i) = xkzm_h -!wz xkzm_mx(i) = xkzm_m - xkzm_hx(i) = xkzm_hp - xkzm_mx(i) = xkzm_mp - else - tem = 1. / (xkgdx - 5.) -!wz tem1 = (xkzm_h - 0.01) * tem -!wz tem2 = (xkzm_m - 0.01) * tem - tem1 = (xkzm_hp - 0.01) * tem - tem2 = (xkzm_mp - 0.01) * tem - ptem = gdx(i) - 5. - xkzm_hx(i) = 0.01 + tem1 * ptem - xkzm_mx(i) = 0.01 + tem2 * ptem - 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 -! minimum turbulent mixing length - 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 - 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 -! 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(i,k,ntcw),qlmin) - tem1 = max(q1(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(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 - 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.) - vpert(i) = min(cfac*vpert(i),gamcrt) - 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 -! - call mfpbltq(im,ix,km,kmpbl,ntcw,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) -! - call mfscuq(im,ix,km,kmscu,ntcw,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 -! -! background diffusivity decreasing with increasing surface layer stability -! -! do i = 1, im -! if(.not.sfcflg(i)) then -! tem = (1. + 5. * rbsoil(i))**2. -!! tem = (1. + 5. * zol(i))**2. -! frik(i) = 0.1 + 0.9 / tem -! endif -! enddo -! -! do k = 1,km1 -! do i=1,im -! xkzo(i,k) = frik(i) * xkzo(i,k) -! xkzmo(i,k)= frik(i) * xkzmo(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(tem1 > 1.e-5) then - tem1 = tvx(i,k+1)-tvx(i,k) - if(tem1 > 0. .and. islimsk(i) /= 1 ) then - 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 - 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, 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 - tem = 0.5 * (elm(i,k) + elm(i,k+1)) - tem = tem * sqrt(tkeh(i,k)) - ri = max(bf(i,k)/shr2(i,k),rimin) - 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 < 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 < 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 -! -! 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 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! 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)) -! 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 - qcko(i,k,ntke) = tke(i,k) - endif - if(scuflg(i)) then - qcdo(i,k,ntke) = 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 - qcko(i,k,ntke)=((1.-tem)*qcko(i,k-1,ntke)+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 - qcdo(i,k,ntke)=((1.-tem)*qcdo(i,k+1,ntke)+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) - ptem = qcko(i,k,ntke) + qcko(i,k+1,ntke) - 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) - ptem = qcdo(i,k,ntke) + qcdo(i,k+1,ntke) - 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 -! f1(i,k) = max(f1(i,k), tkmin) - qtend = (f1(i,k)-q1(i,k,ntke))*rdt - rtg(i,k,ntke) = rtg(i,k,ntke)+qtend - enddo - enddo -c -c compute tridiagonal matrix elements for heat and moisture -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) - 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) - 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 -! -! 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/gfsphysics/physics/set_soilveg.f b/gfsphysics/physics/set_soilveg.f deleted file mode 100644 index b4ef66493..000000000 --- a/gfsphysics/physics/set_soilveg.f +++ /dev/null @@ -1,409 +0,0 @@ - subroutine set_soilveg(me,isot,ivet,nlunit) - use namelist_soilveg - implicit none - - integer, intent(in) :: isot,ivet,nlunit - integer me -!my begin locals -!for 20 igbp veg type and 19 stasgo soil type - integer i - 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/ 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, 1, 3, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/) -! & 3, 0, 3, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/) ! Moorthi -! ---------------------------------------------------------------------- -! 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(nlunit) -!PT READ(nlunit, 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) - - 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 - - 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) = LOG10(SATPSI(I)) + BB(I)*LOG10(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) - return - end diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f deleted file mode 100644 index 64a2565cb..000000000 --- a/gfsphysics/physics/sfc_cice.f +++ /dev/null @@ -1,143 +0,0 @@ -!> \file sfc_cice.f -!! This file contains the sfc_sice for coupling to CICE -!> \defgroup sfc_sice for coupling to CICE -!! @{ -!! \section diagram Calling Hierarchy Diagram -!! \section intraphysics Intraphysics Communication -!! -!> \brief Brief description of the subroutine -!! -!! \section arg_table_cice_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 -!! @{ -! - module module_sfc_cice - use machine , only : kind_phys - use physcons, only : hvap => con_hvap, cp => con_cp, & - & rvrdm1 => con_fvirt, rd => con_rd - implicit none - contains -! -!----------------------------------- - subroutine sfc_cice & -!................................... -! --- inputs: - & ( im, t1, q1, cm, ch, prsl1, & - & wind, flag_cice, flag_iter, dqsfc, dtsfc, & - & dusfc, dvsfc, snowd, & -! --- input/output: -! --- outputs: - & qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) - -! ===================================================================== ! -! description: ! -! Sep 2015 -- Xingren Wu created from sfc_sice for coupling to CICE ! -! ! -! usage: ! -! ! -! call sfc_cice ! -! inputs: ! -! ( im, t1, q1, cm, ch, prsl1, ! -! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! -! dusfc, dvsfc, snowd, ! -! outputs: ! -! qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! -! ! -! ==================== 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 -! islimsk - integer, sea/land/ice mask -! wind - real, wind speed (m/s) -! flag_iter- logical -! dqsfc - real, latent heat flux -! dtsfc - real, sensible heat flux -! dusfc - real, zonal momentum stress -! dvsfc - real, meridional momentum stress -! dvsfc - real, sensible heat flux -! snowd - real, snow depth from cice -! outputs: -! qsurf - real, specific humidity at sfc -! cmm - real, ? -! chh - real, ? -! evap - real, evaperation from latent heat -! hflx - real, sensible heat -! stress - real, surface stress -! weasd - real, water equivalent accumulated snow depth (mm) -! snwdph - real, water equivalent snow depth (mm) -! ep - real, potential evaporation - -! ==================== end of description ===================== ! -! -! -! --- constant parameters: - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - real(kind=kind_phys), parameter :: cpinv = one/cp - real(kind=kind_phys), parameter :: hvapi = one/hvap - real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys - -! --- inputs: - integer, intent(in) :: im - -! real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & - real (kind=kind_phys), dimension(im), intent(in) :: & - & t1, q1, cm, ch, prsl1, wind, dqsfc, dtsfc, dusfc, dvsfc, & - & snowd - - logical, intent(in) :: flag_cice(im), flag_iter(im) - -! --- outputs: - real (kind=kind_phys), dimension(im), intent(inout) :: qsurf, & - & cmm, chh, evap, hflx, stress, & - & weasd, snwdph, ep - -! --- locals: - - real (kind=kind_phys) :: rho, tem - integer :: i -! - do i = 1, im - if (flag_cice(i) .and. flag_iter(i)) then - - rho = prsl1(i) & - & / (rd * t1(i) * (one + rvrdm1*max(q1(i), 1.0d-8))) - - cmm(i) = wind(i) * cm(i) - chh(i) = wind(i) * ch(i) * rho - - qsurf(i) = q1(i) + dqsfc(i) / (hvap*chh(i)) - tem = one / rho - hflx(i) = dtsfc(i) * tem * cpinv - evap(i) = dqsfc(i) * tem * hvapi - stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem - - snwdph(i) = snowd(i) * 1000.0_kind_phys - weasd(i) = snwdph(i) * 0.33_kind_phys - -! weasd(i) = snowd(i) * 1000.0_kind_phys -! snwdph(i) = weasd(i) * dsi ! snow depth in mm - - ep(i) = evap(i) - endif - enddo - - return -!----------------------------------- - end subroutine sfc_cice -!----------------------------------- - -!----------------------------------- - end module module_sfc_cice -!----------------------------------- -!> @} diff --git a/gfsphysics/physics/sfc_diag.f b/gfsphysics/physics/sfc_diag.f deleted file mode 100644 index afb996e75..000000000 --- a/gfsphysics/physics/sfc_diag.f +++ /dev/null @@ -1,66 +0,0 @@ - module module_sfc_diag - contains - subroutine sfc_diag(im,ps,u1,v1,t1,q1,prslki, - & evap,fm,fh,fm10,fh2,tskin,qsurf, - & f10m,u10m,v10m,t2m,q2m) -! - 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, intent(IN) :: im - real, dimension(im), intent(IN) :: - & ps, u1, v1, t1, q1, tskin, qsurf, - & fm, fm10, fh, fh2, prslki, evap - real, dimension(im), intent(OUT) :: - & f10m, u10m, v10m, t2m, q2m -! -! locals -! - real (kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 - &, qmin=1.0d-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 = one - fhi - - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - - if(evap(i) >= zero) 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 subroutine sfc_diag - end module module_sfc_diag diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f deleted file mode 100644 index 9b56cdd33..000000000 --- a/gfsphysics/physics/sfc_diff.f +++ /dev/null @@ -1,678 +0,0 @@ - module module_sfc_diff - - use machine , only : kind_phys - use physcons, grav => con_g - real (kind=kind_phys), parameter :: ca=0.4d0 ! ca - von karman constant - - contains - subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) - & prsl1,prslki, !intent(in) - & sigmaf,vegtype,shdmax,ivegsrc, !intent(in) - & z0pert,ztpert, ! mg, sfc-perts !intent(in) - & flag_iter,redrag, !intent(in) - & u10m,v10m,sfc_z0_type, !hafs,z0 type !intent(in) - & wet,dry,icy, !intent(in) - & tskin, tsurf, snwdph, z0rl, z0rlw, ustar -! - &, cm, ch, rb, stress, fm, fh, fm10, fh2) -! - use physcons, rvrdm1 => con_fvirt - implicit none -! -! 1 - land, 2 - ice, 3 - water -! -------- -------- --------- - integer, intent(in) :: im, ivegsrc - integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - integer, dimension(im), intent(in) :: vegtype - - logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) - logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy - - real(kind=kind_phys), dimension(im), intent(in) :: u10m,v10m - real(kind=kind_phys), dimension(im), intent(in) :: - & ps,t1,q1,z1,prsl1,prslki,wind, - & sigmaf,shdmax, - & z0pert,ztpert ! mg, sfc-perts - real(kind=kind_phys), dimension(im,3), intent(in) :: - & tskin, tsurf, snwdph - - real(kind=kind_phys), dimension(im), intent(in) :: z0rlw - real(kind=kind_phys), dimension(im,3), intent(inout) :: - & z0rl, ustar - -! 1 - land, 2 - ice, 3 - water -! -------- -------- --------- - real(kind=kind_phys), dimension(im,3), intent(out) :: - & cm, ch, rb, stress, fm, fh, fm10, fh2 -! -! locals -! - integer i -! - real(kind=kind_phys) :: rat, thv1, restar, wind10m, - & czilc, tem1, tem2, virtfac - - real(kind=kind_phys) :: tvs, z0, z0max, ztmax -! - real(kind=kind_phys), parameter :: - & one=1.0d0, zero=0.0d0, half=0.5d0, qmin=1.0d-8 - &, charnock=.014d0, z0s_max=.317d-2 ! a limiting value at high winds over sea - &, zmin=1.0d-6 - &, vis=1.4d-5, rnu=1.51d-5, visi=one/vis - &, log01=log(0.01), log05=log(0.05), log07=log(0.07) - -! 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 -! - -! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - - do i=1,im - if(flag_iter(i)) then - virtfac = one + rvrdm1 * max(q1(i),qmin) - thv1 = t1(i) * prslki(i) * virtfac - -! compute stability dependent exchange coefficients -! this portion of the code is presently suppressed -! - if (dry(i)) then ! Some land - tvs = half * (tsurf(i,1)+tskin(i,1)) * virtfac - z0max = max(zmin, min(0.01d0 * z0rl(i,1), z1(i))) -!** xubin's new z0 over land - tem1 = one - shdmax(i) - tem2 = tem1 * tem1 - tem1 = one - 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.01d0 - elseif (vegtype(i) == 16) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01d0 - 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.01d0 - elseif (vegtype(i) == 11) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01d0 - else - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif - - endif -! mg, sfc-perts: add surface perturbations to z0max over land - if (z0pert(i) /= zero ) then - z0max = z0max * (10.0d0**z0pert(i)) - endif - - z0max = max(z0max, zmin) - -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8d0 - - tem1 = 1.0d0 - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar(i,1)*(0.01/1.5e-05))) - -! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land - if (ztpert(i) /= zero) then - ztmax = ztmax * (10.0d0**ztpert(i)) - endif - ztmax = max(ztmax, zmin) -! - call stability -! --- inputs: - & (z1(i), snwdph(i,1), thv1, wind(i), z0max, ztmax, tvs, -! --- outputs: - & rb(i,1), fm(i,1), fh(i,1), fm10(i,1), fh2(i,1), - & cm(i,1), ch(i,1), stress(i,1), ustar(i,1)) - endif ! Dry points - - if (icy(i)) then ! Some ice - tvs = half * (tsurf(i,2)+tskin(i,2)) * virtfac - z0max = max(zmin, min(0.01d0 * z0rl(i,2), z1(i))) -!** xubin's new z0 over land and sea ice - tem1 = one - shdmax(i) - tem2 = tem1 * tem1 - tem1 = one - tem2 - - if( ivegsrc == 1 ) then - - z0max = exp( tem2*log01 + tem1*log(z0max) ) - elseif (ivegsrc == 2 ) then - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif - - z0max = max(z0max, zmin) - -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height -! dependance of czil - - czilc = 0.8d0 - - tem1 = 1.0d0 - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar(i,2)*(0.01/1.5e-05))) - ztmax = max(ztmax, 1.0e-6) -! - call stability -! --- inputs: - & (z1(i), snwdph(i,2), thv1, wind(i), z0max, ztmax, tvs, -! --- outputs: - & rb(i,2), fm(i,2), fh(i,2), fm10(i,2), fh2(i,2), - & cm(i,2), ch(i,2), stress(i,2), ustar(i,2)) - endif ! Icy points - -! BWG: Everything from here to end of subroutine was after -! the stuff now put into "stability" - - if (wet(i)) then ! Some open ocean - tvs = half * (tsurf(i,3)+tskin(i,3)) * virtfac - z0 = 0.01d0 * z0rl(i,3) - z0max = max(zmin, min(z0,z1(i))) - ustar(i,3) = sqrt(grav * z0 / charnock) - wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) - -!** test xubin's new z0 - -! ztmax = z0max - - restar = max(ustar(i,3)*z0max*visi, 0.000001d0) - -! 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.0d0, 2.67d0 * sqrt(sqrt(restar)) - 2.57d0) - ztmax = max(z0max * exp(-rat), zmin) -! - if (sfc_z0_type == 6) then - call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type == 7) then - call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type > 0) then - write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop - endif -! - call stability -! --- inputs: - & (z1(i), snwdph(i,3), thv1, wind(i), z0max, ztmax, tvs, -! --- outputs: - & rb(i,3), fm(i,3), fh(i,3), fm10(i,3), fh2(i,3), - & cm(i,3), ch(i,3), stress(i,3), ustar(i,3)) -! -! update z0 over ocean -! - if (sfc_z0_type >= 0) then - if (sfc_z0_type == 0) then - z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) - -! 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) - - if (redrag) then - z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) - else - z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) - endif - - elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0d0 * z0 ! cm - elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0d0 * z0 ! cm - else - z0rl(i,3) = 1.0d-4 - endif - - elseif (z0rlw(i) < 1.0d-7) then - z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) - - if (redrag) then - z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) - else - z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) - endif - - endif - - endif ! end of if(open ocean) -! - endif ! end of if(flagiter) loop - enddo - - return - end subroutine sfc_diff - - -!---------------------------------------- - subroutine stability -!........................................ -! --- inputs: - & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, & -! --- outputs: - & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) -!----- - -! --- 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.0d0, a0=-3.975d0 & - &, a1=12.32d0, alpha4=4.0d0*alpha & - &, b1=-7.755d0, b2=6.041d0, alpha2=alpha+alpha & - &, beta=1.0d0 & - &, a0p=-7.941d0, a1p=24.75d0, b1p=-8.705d0, b2p=7.899d0& - &, ztmin1=-999.0d0, zero=0.0d0, one=1.0d0 - - 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 = one / z1 - - tem1 = z0max/z1 - if (abs(one-tem1) > 1.0d-6) then - ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) - else - ztmax1 = 99.0d0 - endif - if( z0max < 0.05d0 .and. snwdph < 10.0d0 ) ztmax1 = 99.0d0 - -! compute stability indices (rb and hlinf) - - dtv = thv1 - tvs - adtv = max(abs(dtv),0.001d0) - dtv = sign(1.,dtv) * adtv - rb = max(-5000.0d0, (grav+grav) * dtv * z1 - & / ((thv1 + tvs) * wind * wind)) - tem1 = one / z0max - tem2 = one / ztmax - fm = log((z0max+z1) * tem1) - fh = log((ztmax+z1) * tem2) - fm10 = log((z0max+10.0d0) * tem1) - fh2 = log((ztmax+2.0d0) * tem2) - hlinf = rb * fm * fm / fh - hlinf = min(max(hlinf,ztmin1),ztmax1) -! -! stable case -! - if (dtv >= zero) then - hl1 = hlinf - if(hlinf > 0.25d0) then - tem1 = hlinf * z1i - hl0inf = z0max * tem1 - hltinf = ztmax * tem1 - aa = sqrt(one + alpha4 * hlinf) - aa0 = sqrt(one + alpha4 * hl0inf) - bb = aa - bb0 = sqrt(one + alpha4 * hltinf) - pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) - ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) - 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(one + alpha4 * hl1) - aa0 = sqrt(one + alpha4 * hl0) - bb = aa - bb0 = sqrt(one + alpha4 * hlt) - pm = aa0 - aa + log( (one+aa)/(one+aa0) ) - ph = bb0 - bb + log( (one+bb)/(one+bb0) ) - hl110 = hl1 * 10.0d0 * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - aa = sqrt(one + alpha4 * hl110) - pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12,ztmin1),ztmax1) -! aa = sqrt(one + alpha4 * hl12) - bb = sqrt(one + alpha4 * hl12) - ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) -! -! unstable case - check for unphysical obukhov length -! - else ! dtv < 0 case - olinf = z1 / hlinf - tem1 = 50.0d0 * z0max - if(abs(olinf) <= tem1) then - hlinf = -z1 / tem1 - hlinf = min(max(hlinf,ztmin1),ztmax1) - endif -! -! get pm and ph -! - if (hlinf >= -0.5d0) then - hl1 = hlinf - pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) - ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) - hl110 = hl1 * 10.0d0 * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) - else ! hlinf < 0.05 - hl1 = -hlinf - tem1 = one / sqrt(hl1) - pm = log(hl1) + 2.0d0 * sqrt(tem1) - .8776d0 - ph = log(hl1) + 0.5d0 * tem1 + 1.386d0 -! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 -! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 - hl110 = hl1 * 10.0d0 * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = log(hl110) + 2.0d0 / sqrt(sqrt(hl110)) - 0.8776d0 -! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = log(hl12) + 0.5d0 / sqrt(hl12) + 1.386d0 -! 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.00001d0 / z1 - cm = max(cm, tem1) - ch = max(ch, tem1) - stress = cm * wind * wind - ustar = sqrt(stress) - - return -!................................. - end subroutine stability -!--------------------------------- - - -!! add fitted z0,zt curves for hurricane application (used in HWRF/HMON) -!! Weiguo Wang, 2019-0425 - - SUBROUTINE znot_m_v6(uref, znotm) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate areodynamical roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) -! For high winds, try to fit available observational data -! -! Bin Liu, NOAA/NCEP/EMC 2017 -! -! uref(m/s) : wind speed at 10-m height -! znotm(meter): areodynamical roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - 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 (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp(p10 + uref * (p11 + uref * (p12 + uref*p13))) - elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35))))) - elseif ( uref > 53.0) then - znotm = p40 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_m_v6 - - SUBROUTINE znot_t_v6(uref, znott) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate scalar roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm -! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF -! -! Bin Liu, NOAA/NCEP/EMC 2017 -! -! uref(m/s) : wind speed at 10-m height -! znott(meter): scalar roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - 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 (uref >= 0.0 .and. uref < 5.9 ) then - znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 - & + uref * (p14 + uref * p15)))) - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 21.6 .and. uref <= 42.2) then - znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35)))) - elseif ( uref > 42.2 .and. uref <= 53.3) then - znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 - & + uref * (p44 + uref * p45)))) - elseif ( uref > 53.3 .and. uref <= 80.0) then - znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 - & + uref * (p54 + uref * (p55 + uref * p56))))) - elseif ( uref > 80.0) then - znott = p60 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_t_v6 - - - SUBROUTINE znot_m_v7(uref, znotm) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate areodynamical roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) -! For high winds, try to fit available observational data -! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed -! -! Bin Liu, NOAA/NCEP/EMC 2018 -! -! uref(m/s) : wind speed at 10-m height -! znotm(meter): areodynamical roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - - 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.897534489606422e-07, p34 = -3.019495980684978e-05, - & p33 = 1.931392924987349e-03, p32 = -6.797293095862357e-02, - & p31 = 1.346757797103756e+00, p30 = -1.707846930193362e+01, - - & p40 = 3.371427455376717e-04 - - if (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp( p10 + uref * (p11 + uref * (p12 + uref * p13))) - elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35))))) - elseif ( uref > 53.0) then - znotm = p40 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_m_v7 - SUBROUTINE znot_t_v7(uref, znott) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate scalar roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm -! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF -! To be compatible with the slightly decreased Cd for higher wind speed -! -! Bin Liu, NOAA/NCEP/EMC 2018 -! -! uref(m/s) : wind speed at 10-m height -! znott(meter): scalar roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - - real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, - - & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08, - & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05, - & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04, - - & p25 = -9.402722450219142e-12, p24 = 1.325396583616614e-09, - & p23 = -7.299148051141852e-08, p22 = 1.982901461144764e-06, - & p21 = -2.680293455916390e-05, p20 = 1.484341646128200e-04, - - & p35 = 7.921446674311864e-12, p34 = -1.019028029546602e-09, - & p33 = 5.251986927351103e-08, p32 = -1.337841892062716e-06, - & p31 = 1.659454106237737e-05, p30 = -7.558911792344770e-05, - - & p45 = -2.694370426850801e-10, p44 = 5.817362913967911e-08, - & p43 = -5.000813324746342e-06, p42 = 2.143803523428029e-04, - & p41 = -4.588070983722060e-03, p40 = 3.924356617245624e-02, - - & p56 = -1.663918773476178e-13, p55 = 6.724854483077447e-11, - & p54 = -1.127030176632823e-08, p53 = 1.003683177025925e-06, - & p52 = -5.012618091180904e-05, p51 = 1.329762020689302e-03, - & p50 = -1.450062148367566e-02, p60 = 6.840803042788488e-05 - - if (uref >= 0.0 .and. uref < 5.9 ) then - znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 - & + uref * (p14 + uref * p15)))) - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 21.6 .and. uref <= 42.6) then - znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35)))) - elseif ( uref > 42.6 .and. uref <= 53.0) then - znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 - & + uref * (p44 + uref * p45)))) - elseif ( uref > 53.0 .and. uref <= 80.0) then - znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 - & + uref * (p54 + uref * (p55 + uref * p56))))) - elseif ( uref > 80.0) then - znott = p60 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_t_v7 - - -!--------------------------------- - end module module_sfc_diff diff --git a/gfsphysics/physics/sfc_drv.f b/gfsphysics/physics/sfc_drv.f deleted file mode 100644 index 80e081909..000000000 --- a/gfsphysics/physics/sfc_drv.f +++ /dev/null @@ -1,604 +0,0 @@ - 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 :: one = 1.0d0, zero = 0.0d0 - real(kind=kind_phys), parameter :: cpinv = one/cp - real(kind=kind_phys), parameter :: hvapi = one/hvap - real(kind=kind_phys), parameter :: elocp = hvap/cp - real(kind=kind_phys), parameter :: rhoh2o = 1000.0d0 - real(kind=kind_phys), parameter :: a2 = 17.2693882d0 - real(kind=kind_phys), parameter :: a3 = 273.16d0 - real(kind=kind_phys), parameter :: a4 = 35.86d0 - real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) - real(kind=kind_phys), parameter :: qmin = 1.0d-8 - - real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1d0, -0.4d0, -1.0d0, -2.0d0 / - -! --- input: - integer, intent(in) :: im, km, isot, ivegsrc - real (kind=kind_phys), 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) = zero - evap (i) = zero - hflx (i) = zero - gflux(i) = zero - drain(i) = zero - canopy(i) = max(canopy(i), zero) - - evbs (i) = zero - evcw (i) = zero - trans(i) = zero - sbsno(i) = zero - snowc(i) = zero - snohf(i) = zero - endif ! flag_iter & land - enddo - -! --- ... initialize variables - - do i = 1, im - if (flag_iter(i) .and. land(i)) then - q0(i) = max(q1(i), qmin) ! 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)*(one+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)), qmin) - 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 > zero) then - ! compute beta distribution parameters for vegetation fraction - mv = shdfac - sv = pertvegf*mv*(one-mv) - alphav = mv*mv*(one-mv)/(sv*sv)-mv - betav = alphav*(one-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 = zero - 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.001d0 ! 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.001d0 ! convert from mm to m - sneqv = weasd(i) * 0.001d0 ! convert from mm to m - if (sneqv /= zero .and. snowh == zero) then - snowh = 10.0d0 * 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) * 0.01d0 -! ---- 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.0d0 ! 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.0d0 - drain (i) = runoff2 * 1000.0d0 - -! --- ... unit conversion (from m to mm) - canopy(i) = cmc * 1000.0d0 - snwdph(i) = snowh * 1000.0d0 - weasd(i) = sneqv * 1000.0d0 - sncovr1(i) = sncovr -! ---- ... outside sflx, roughness uses cm as unit (update after snow's -! effect) - zorl(i) = z0*100.0d0 - -! --- ... 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 = one / 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/gfsphysics/physics/sfc_noahmp_drv.f b/gfsphysics/physics/sfc_noahmp_drv.f deleted file mode 100644 index 70c1eb052..000000000 --- a/gfsphysics/physics/sfc_noahmp_drv.f +++ /dev/null @@ -1,1138 +0,0 @@ -! ! -!----------------------------------- - 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/gfsphysics/physics/sfc_nst.f b/gfsphysics/physics/sfc_nst.f deleted file mode 100644 index 51694d6cc..000000000 --- a/gfsphysics/physics/sfc_nst.f +++ /dev/null @@ -1,593 +0,0 @@ -!> \file sfc_nst.f -!! This file contains the GFS NSST model. - -!> \defgroup GFS_NSST GFS Near Sea Surface Temperature -!! @{ -!! \brief Brief description of the parameterization -!! \section diagram Calling Hierarchy Diagram -!! \section intraphysics Intraphysics Communication - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_NSST_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 -!! @{ - module module_sfc_nst - contains - subroutine sfc_nst & -!................................... -! --- inputs: - & ( im, ps, u1, v1, t1, q1, tref, cm, ch, & - & prsl1, prslki, wet, xlon, sinlat, stress, & -! & prsl1, prslki, wet, icy, xlon, sinlat, stress, & - & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & - & wind, 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, ps, u1, v1, t1, q1, tref, cm, ch, ! -! prsl1, prslki, wet, icy, xlon, sinlat, stress, ! -! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! -! wind, 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 ! -! 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 ! -! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! icy - logical, =T if any ice 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 ! -! wind - real, wind speed (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, 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, wind - real (kind=kind_phys), intent(in) :: timestep - real (kind=kind_phys), intent(in) :: solhr - - logical, dimension(im), intent(in) :: flag_iter, flag_guess, wet -! &, icy - logical, intent(in) :: 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, 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) = wet(i) .and. .not.icy(i) .and. flag_iter(i) - flag(i) = wet(i) .and. flag_iter(i) - enddo -! -! save nst-related prognostic fields for guess run -! - do i=1, im -! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then - if(wet(i) .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)) - - 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 (wet(i) .and. .not.icy(i)) then - if (wet(i)) 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(wet(i) .and. .not.icy(i)) 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 subroutine sfc_nst - end module module_sfc_nst diff --git a/gfsphysics/physics/sfc_ocean.f b/gfsphysics/physics/sfc_ocean.f deleted file mode 100644 index ad18899fc..000000000 --- a/gfsphysics/physics/sfc_ocean.f +++ /dev/null @@ -1,134 +0,0 @@ - module module_sfc_ocean - - contains -!----------------------------------- - subroutine sfc_ocean & -!................................... -! --- inputs: - & ( im, ps, t1, q1, tskin, cm, ch, & - & prsl1, prslki, wet, wind, flag_iter, & -! --- outputs: - & qsurf, cmm, chh, gflux, evap, hflx, ep & - & ) - -! ===================================================================== ! -! description: ! -! ! -! usage: ! -! ! -! call sfc_ocean ! -! inputs: ! -! ( im, ps, t1, q1, tskin, cm, ch, ! -!! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! -! prsl1, prslki, wet, wind, 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 ! -! 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 ! -! wet - logical, =T if any ocean/lak, =F otherwise im ! -! wind - real, wind speed (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 : rd => con_rd, eps => con_eps, & - & epsm1 => con_epsm1, rvrdm1 => con_fvirt -! - implicit none -! -! --- constant parameters: - real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & - &, qmin = 1.0d-8 - -! --- inputs: - integer, intent(in) :: im -! real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & - real (kind=kind_phys), dimension(im), intent(in) :: ps, & - & t1, q1, tskin, cm, ch, prsl1, prslki, wind - - logical, dimension(im), intent(in) :: flag_iter, wet - -! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & - & cmm, chh, gflux, evap, hflx, ep - -! --- locals: - - real (kind=kind_phys) :: q0, qss, rho, tem - integer :: i -! -!===> ... begin here -! - do i = 1, im - -! --- ... 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 (wet(i) .and. flag_iter(i)) then - - q0 = max(q1(i), qmin) - rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) - - qss = fpvs( tskin(i) ) - qss = eps*qss / (ps(i) + epsm1*qss) - -! --- ... rcp = rho cp ch v - - tem = ch(i) * wind(i) - cmm(i) = cm(i) * wind(i) - chh(i) = rho * tem - -! --- ... sensible and latent heat flux over open water - - hflx(i) = tem * (tskin(i) - t1(i) * prslki(i)) - - evap(i) = tem * (qss - q0) - - ep(i) = evap(i) - qsurf(i) = qss - gflux(i) = zero - endif - enddo -! - return -!................................... - end subroutine sfc_ocean -!----------------------------------- - end module module_sfc_ocean diff --git a/gfsphysics/physics/sfc_sice.f b/gfsphysics/physics/sfc_sice.f deleted file mode 100644 index c3680aa93..000000000 --- a/gfsphysics/physics/sfc_sice.f +++ /dev/null @@ -1,648 +0,0 @@ -!> \file sfc_sice.f -!! This file contains the GFS thermodynamics surface ice model. - -!> \defgroup GFS_Ice GFS Thermodynamics Surface Ice -!! @{ -!! \brief Brief description of the parameterization -!! \section diagram Calling Hierarchy Diagram -!! \section intraphysics Intraphysics Communication - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_sice_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 -!! @{ - module module_sfc_sice - 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, & - & rvrdm1 => con_fvirt, t0c => con_t0c, & - & rd => con_rd - implicit none - contains -!----------------------------------- - subroutine sfc_sice & -!................................... -! --- inputs: - & ( im, km, ps, t1, q1, delt, & -! & ( im, km, ps, u1, v1, t1, q1, delt, & - & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & - & cm, ch, prsl1, prslki, islimsk, wind, & - & flag_iter, lprnt, ipr, cimin, & -! --- 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, t1, q1, delt, ! -!! ( im, km, ps, u1, v1, t1, q1, delt, ! -! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! -! cm, ch, prsl1, prslki, islimsk, wind, ! -! flag_iter, ! -! 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. cpldice) ! -! (not used anymore) ! -! 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 ! -! 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 fraction 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 ! -! wind - real, im ! -! flag_iter- logical, im ! -! ! -! 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, surface exchange coeff for momentum(m/s) im ! -! chh - real, surface exchange coeff heat&moisture (m/s) im ! -! evap - real, evaperation from latent heat flux im ! -! hflx - real, sensible heat flux im ! -! ! -! ===================================================================== ! -! -! -! --- constant parameters: - integer, parameter :: kmi = 2 ! 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - real(kind=kind_phys), parameter :: cpinv = one/cp - real(kind=kind_phys), parameter :: hvapi = one/hvap - real(kind=kind_phys), parameter :: elocp = hvap/cp - real(kind=kind_phys), parameter :: himax = 8.0_kind_phys ! maximum ice thickness allowed - real(kind=kind_phys), parameter :: himin = 0.1_kind_phys ! minimum ice thickness required - real(kind=kind_phys), parameter :: hsmax = 2.0_kind_phys ! maximum snow depth allowed - real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice - real(kind=kind_phys), parameter :: albfw = 0.06_kind_phys ! albedo for lead - real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys - -! --- inputs: - integer, intent(in) :: im, km, ipr - logical, intent(in) :: lprnt - - real (kind=kind_phys), dimension(im), intent(in) :: ps, & - & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, wind - - integer, dimension(im), intent(in) :: islimsk - real (kind=kind_phys), intent(in) :: delt, cimin - - logical, intent(in) :: flag_iter(im) - -! --- 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(inout) :: 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, rch, rho, & - & snowd, theta1 - - real (kind=kind_phys) :: t12, t14, tem, stsice(im,kmi) - &, hflxi, hflxw, q0, qs1, qssi, qssw - - - 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) = zero - fice(i) = zero - endif - enddo -! - do i = 1, im - if (flag(i)) then - if (srflag(i) > zero) then - ep(i) = ep(i)*(one-srflag(i)) - weasd(i) = weasd(i) + 1.0d3*tprcp(i)*srflag(i) - tprcp(i) = tprcp(i)*(one-srflag(i)) - endif - 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 - -! --- ... 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) - - q0 = max(q1(i), qmin) -! tsurf(i) = tskin(i) - theta1(i) = t1(i) * prslki(i) - rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) - qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) - q0 = min(qs1, q0) - - if (fice(i) < cimin) then - print *,'warning: ice fraction is low:', fice(i) - fice(i) = cimin - tice(i) = tgice - tskin(i)= tgice - print *,'fix ice fraction: reset it to:', fice(i) - endif - ffw(i) = one - fice(i) - - 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 - - snowd(i) = weasd(i) * 0.001_kind_phys -! 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(i) - chh(i) = rho(i) * ch(i) * wind(i) - 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) - - snetw(i) = sfcdsw(i) * (one - albfw) - snetw(i) = min(3.0_kind_phys*sfcnsw(i) & - & / (one+2.0_kind_phys*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_kind_phys*sfcemis(i)*sbc*tice(i)*t12 & - & + (one + 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_kind_phys ! heat flux from ocean - should be from ocn model - snof(i) = zero ! 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_kind_phys*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 - - call ice3lay -! --- inputs: ! - & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, ! - & lprnt, ipr, -! --- outputs: ! - & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! - - 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_kind_phys - snwdph(i) = weasd(i) * dsi ! snow depth in mm - - tem = one / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - endif - enddo -! - return - end subroutine sfc_sice - - -!----------------------------------- -!> \brief Brief description of the subroutine -!! -!----------------------------------- - subroutine ice3lay -!................................... -! --- inputs: - & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, & - & lprnt, ipr, -! --- 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_kind_phys ! snow (ov sea ice) density (kg/m^3) - real (kind=kind_phys), parameter :: dw =1000.0_kind_phys ! 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 :: ks = 0.31_kind_phys ! conductivity of snow (w/mk) - real (kind=kind_phys), parameter :: i0 = 0.3_kind_phys ! ice surface penetrating solar fraction - real (kind=kind_phys), parameter :: ki = 2.03_kind_phys ! conductivity of ice (w/mk) - real (kind=kind_phys), parameter :: di = 917.0_kind_phys ! 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_kind_phys ! heat capacity of fresh ice (j/kg/k) - real (kind=kind_phys), parameter :: li = 3.34e5_kind_phys ! latent heat of fusion (j/kg-ice) - real (kind=kind_phys), parameter :: si = 1.0_kind_phys ! salinity of sea ice - real (kind=kind_phys), parameter :: mu = 0.054_kind_phys ! 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_kind_phys ! tfw - seawater freezing temp (c) - real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001_kind_phys - 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_kind_phys - - real (kind=kind_phys), parameter :: zero = 0.0_kind_phys - real (kind=kind_phys), parameter :: half = 0.5_kind_phys - real (kind=kind_phys), parameter :: one = 1.0_kind_phys - real (kind=kind_phys), parameter :: four = 4.0_kind_phys - -! --- inputs: - integer, intent(in) :: im, kmi, ipr - logical :: lprnt - - 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 = delt + delt - dt4 = dt2 + dt2 - dt6 = dt2 + dt4 - dt2i = one / 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) > zero) then - tsf = zero - ip = zero - 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 = one / (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 - four*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 - four*a1*c1) + b1)/(a1+a1) - tice(i) = tsf - tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt - else - tmelt = zero - 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 = half * hice(i) - h2 = half * 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) = zero - endif - -! --- ... and bottom - - if (bmelt < zero) 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) > zero) then - if (h1 > half*hice(i)) then - f1 = one - (h2+h2) / hice(i) - stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& - & + (one - 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)))& - & + (one - f1)*stsice(i,2) - stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & - & - four*tfi*li/ci)) * half - 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*(one - tfi/stsice(i,1))) & - & + h2*(ci*(stsice(i,2) - tfi) - li)) / li - - hice(i) = max(zero, snowd(i)*dsdi) - snowd(i) = zero - stsice(i,1) = tfw - stsice(i,2) = tfw - gflux(i) = zero - 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 module module_sfc_sice -!> @} diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F deleted file mode 100644 index d3e94943b..000000000 --- a/gfsphysics/physics/sfcsub.F +++ /dev/null @@ -1,8700 +0,0 @@ - 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 - &, 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,kpdabs_1=159, - & kpdsnd=66 ) -! - 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 -! - 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,snofcs,zorfcs,albfcs,tg3fcs & - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & - &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nlunit & - &, sz_nml,input_nml_file & - &, lake, min_lakeice, min_seaice & - &, 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, intent(in) :: use_ufo, nst_anl - logical, intent(in) :: lake(len) - real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice - - 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,sicjmx=1.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 - 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) -! -! 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, 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, - & 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 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, -!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 == 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 == 0) 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 >= 99999.) ctsfl = 1. - if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) -! - ctsfs=0. !... tsfc over sea - if (ftsfs >= 99999.) ctsfs=1. - if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) -! - do k=1,lsoil - csmcl(k) = 0. !... soilm over land - if (fsmcl(k) >= 99999.) csmcl(k) = 1. - if (fsmcl(k) > 0. .and. fsmcl(k) < 99999) - & csmcl(k) = exp(-deltf/fsmcl(k)) - csmcs(k)=0. !... soilm over sea - if (fsmcs(k) >= 99999.) csmcs(k) = 1. - if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) - & csmcs(k) = exp(-deltf/fsmcs(k)) - enddo -! - calbl = 0. !... albedo over land - if (falbl >= 99999.) calbl = 1. - if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) -! - calfl=0. !... fraction field for albedo over land - if (falfl >= 99999.) calfl = 1. - if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) -! - calbs=0. !... albedo over sea - if (falbs >= 99999.) calbs = 1. - if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) -! - calfs = 0. !... fraction field for albedo over sea - if (falfs >= 99999.) calfs = 1. - if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) -! - caisl = 0. !... sea ice over land - if (faisl >= 99999.) caisl = 1. - if (faisl > 0. .and. faisl < 99999) caisl = 1. -! - caiss = 0. !... sea ice over sea - if (faiss >= 99999.) caiss = 1. - if (faiss > 0. .and. faiss < 99999) caiss = 1. -! - csnol = 0. !... snow over land - if (fsnol >= 99999.) csnol = 1. - if (fsnol > 0. .and. fsnol < 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 < 0.) csnol = fsnol -! - csnos = 0. !... snow over sea - if (fsnos >= 99999.) csnos = 1. - if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) -! - czorl = 0. !... roughness length over land - if (fzorl >= 99999.) czorl = 1. - if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) -! - czors = 0. !... roughness length over sea - if (fzors >= 99999.) czors = 1. - if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) -! -! cplrl = 0. !... plant resistance over land -! if (fplrl >= 99999.) cplrl = 1. -! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) -! -! cplrs = 0. !... plant resistance over sea -! if (fplrs >= 99999.) cplrs = 1. -! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) -! - do k=1,lsoil - cstcl(k) = 0. !... soilt over land - if (fstcl(k) >= 99999.) cstcl(k) = 1. - if (fstcl(k) > 0. .and. fstcl(k) < 99999) & - & cstcl(k) = exp(-deltf/fstcl(k)) - cstcs(k) = 0. !... soilt over sea - if (fstcs(k) >= 99999.) cstcs(k) = 1. - if (fstcs(k) > 0. .and. fstcs(k) < 99999) & - & cstcs(k) = exp(-deltf/fstcs(k)) - enddo -! - cvegl = 0. !... vegetation fraction over land - if (fvegl >= 99999.) cvegl = 1. - if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) -! - cvegs = 0. !... vegetation fraction over sea - if (fvegs >= 99999.) cvegs = 1. - if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) -! - cvetl = 0. !... vegetation type over land - if (fvetl >= 99999.) cvetl = 1. - if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) -! - cvets = 0. !... vegetation type over sea - if (fvets >= 99999.) cvets = 1. - if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) -! - csotl = 0. !... soil type over land - if (fsotl >= 99999.) csotl = 1. - if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) -! - csots = 0. !... soil type over sea - if (fsots >= 99999.) csots = 1. - if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) - -!cwu [+16l]--------------------------------------------------------------- -! - csihl = 0. !... sea ice thickness over land - if (fsihl >= 99999.) csihl = 1. - if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) -! - csihs = 0. !... sea ice thickness over sea - if (fsihs >= 99999.) csihs = 1. - if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) -! - csicl = 0. !... sea ice concentration over land - if (fsicl >= 99999.) csicl = 1. - if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) -! - csics = 0. !... sea ice concentration over sea - if (fsics >= 99999.) csics = 1. - if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) - -!clu [+32l]--------------------------------------------------------------- -! - cvmnl = 0. !... min veg cover over land - if (fvmnl >= 99999.) cvmnl = 1. - if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) -! - cvmns = 0. !... min veg cover over sea - if (fvmns >= 99999.) cvmns = 1. - if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) -! - cvmxl = 0. !... max veg cover over land - if (fvmxl >= 99999.) cvmxl = 1. - if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) -! - cvmxs = 0. !... max veg cover over sea - if (fvmxs >= 99999.) cvmxs = 1. - if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) -! - cslpl = 0. !... slope type over land - if (fslpl >= 99999.) cslpl = 1. - if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) -! - cslps = 0. !... slope type over sea - if (fslps >= 99999.) cslps = 1. - if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) -! - cabsl = 0. !... snow albedo over land - if (fabsl >= 99999.) cabsl = 1. - if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) -! - cabss = 0. !... snow albedo over sea - if (fabss >= 99999.) cabss = 1. - if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) -!clu ---------------------------------------------------------------------- -! -!> - Call hmskrd() to 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 == 0) 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, - & 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, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & 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) /= ' ') then -!cwu [+5l/-1l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*aisclm(i) - sicclm(i) = aisclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i) /= 1.0) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 -! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) - - elseif(fnacnc(1:8) /= ' ') then -!cwu [+4l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*acnclm(i) - sicclm(i) = acnclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) - 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) > 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 > 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) == ' ') 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 > 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 == 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 == 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, lanom) -! 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 > 0.0 .and. fntsfa(1:8) /= ' ' .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) /= ' ') then -!cwu [+5l/-1l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*aisanl(i) - sicanl(i) = aisanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! crit=aislim -!* crit=0.5 -! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) - elseif(fnacna(1:8) /= ' ') then -!cwu [+17l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*acnanl(i) - sicanl(i) = acnanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! crit=aislim - do i=1,len - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then - slianl(i) = 2. -! print *,'cycle - new ice form: fice=',sicanl(i) - elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then - slianl(i) = 0. -! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) 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) - call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) - 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) /= ' ') 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) > 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) /= ' ' .or. fnweta(1:8) /= ' ' ) 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) == ' ' .and. fnsmcc(1:8) == ' ') 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 > 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) == ' ') 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 > 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 == 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 == 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 == 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) /= 0.) then - call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, - & tsfimx) - do i=1,len - icefl2(i) = sicfcs(i) > 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) /= 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo - enddo -!clu ----------------------------------------------------------------------- -! - if (lqcbgs .and. irtacn == 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) /= ' ' .or. fnweta(1:8) /= ' ' ) - & 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 > 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 > 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 == 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 > 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 == 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) > 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) /= ' ' .or. fnweta(1:8) /= ' ' ) 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) - 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 stcanl(3:4) - if (lsoil > 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) - 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 == 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 == 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 > 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 == 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 > 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) > 0.0_kind_io8) 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 (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (slifcs(i) >= 1.99_kind_io8) then - if (sicfcs(i) > crit) then - tem1 = 1.0_kind_io8 / sicfcs(i) - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem1 - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 - sicfcs(i) = sicanl(i) - else - tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice -! sihfcs(i) = sihnew - sihfcs(i) = 0.0_kind_io8 - sicfcs(i) = 0.0_kind_io8 - slifcs(i) = 0.0_kind_io8 - endif - endif - if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then - print *,'warning: check, slifcs and sicfcs', & - & slifcs(i),sicfcs(i) - endif - enddo - -! do i=1,len -! if (slifcs(i) < 1.5_kind_io8) then -! sihfcs(i) = 0.0_kind_io8 -! sicfcs(i) = 0.0_kind_io8 -! sitfcs(i) = tsffcs(i) -! else -! if (lake(i)) then -! crit = min_lakeice -! else -! crit = min_seaice -! endif -! if (sicfcs(i) < crit) then -! print *,'warning: check, slifcs and sicfcs', & -! & slifcs(i),sicfcs(i) -! endif -! endif -! enddo - -! -! ensure the consistency between slc and smc -! - do k=1, lsoil - fixratio(k) = .false. - if (fsmcl(k) < 99999.) fixratio(k) = .true. - enddo - - if(me == 0) 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) == -999.) then - slcfcs(i,k) = smcfcs(i,k) - else - slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) - endif - if (slifcs(i) /= 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) == 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 < 99999.) then - if(me == 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i) == 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) /= 1) swdfcs(i) = 3.*snofcs(i) - enddo - - do i = 1, len - if(slifcs(i) == 1.) then - if(snofcs(i) /= 0. .and. swdfcs(i) == 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) == 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 - 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) 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 - 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), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) -! - logical*1, allocatable :: lbms(:) -! - integer kpds(200),kgds(200) - integer jpds(200),jgds(200), kpds0(200) -! - allocate(data8(1:idim*jdim)) - allocate(lbms(1:mdata)) - kpds = 0 - kgds = 0 - jpds = 0 - jgds = 0 - kpds0 = 0 -! -! if(me .eq. 0) 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) write(6,*) ' 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) 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(1:idim*jdim)) - call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - 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) 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 -! - deallocate(data8) - deallocate(lbms) - return - end - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - use machine , only : kind_io8,kind_io4 - 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) 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) 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) 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 - 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) 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 == 0) 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, & - & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & - & aisclm, & - & tg3clm,cvclm ,cvbclm,cvtclm, & - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & - & vetclm,sotclm,alfclm, & - & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic - & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs - & 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) & - &, sihanl(len),sicanl(len) & - &, 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) & - &, sihclm(len),sicclm(len) & - &, 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, & - & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & - & tg3anl,cvanl ,cvbanl,cvtanl, & - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & - & vetanl,sotanl,alfanl,tsfan0, & - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kprvet,kpdsot,kpdalf, & - & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & - & irtvet,irtsot,irtalf & - &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs - &, imsk, jmsk, slmskh, outlat, outlon & - &, gaus, blno, blto, me, lanom) - use machine , only : kind_io8,kind_io4 - implicit none - logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & - &, 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 - &, 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) & - &, 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 == 1) then - write(6,*) 't surface analysis read error' - call abort - elseif(iret == -1) then - if (me == 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 == 0) print *,'t surface analysis provided.' - endif - else - if (me == 0) then -! print *,'************************************************' - print *,'no tsf analysis available. climatology used' - endif - endif -! -! tsf0 -! - if(fntsfa(1:8).ne.' ' .and. lanom) 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 == 1) then - write(6,*) 't surface at ft=0 analysis read error' - call abort - elseif(iret == -1) then - if (me == 0) then - write(6,*) 'could not find t surface analysis at ft=0' - endif - 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 == 1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret == -1) then - if (me == 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 == 0 .and. kk == 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me == 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 == 1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret == -1) then - if (me == 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 == 0 .and. kk == 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me == 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, & - & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic - & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs - & tsfanl,wetanl,snoanl,zoranl,albanl, & - & tg3anl,cvanl ,cvbanl,cvtanl, & - & cnpanl,smcanl,stcanl,slianl,aisanl, & - & veganl, vetanl, sotanl, alfanl, & - & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs - & 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) & - &, sihfcs(len),sicfcs(len) & - &, 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) & - &, sihanl(len),sicanl(len) & - &, 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 == 'ge') then - do i=1,len - if(aisfld(i) >= crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'gt') then - do i=1,len - if(aisfld(i) > crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'le') then - do i=1,len - if(aisfld(i) <= crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'lt') then - do i=1,len - if(aisfld(i) < 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 rof01_len(aisfld, len, op, lake, critl, crits) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - logical :: lake(len) - real (kind=kind_io8) aisfld(len), critl, crits, crit(len) - character*2 op -! - do i=1,len - if (lake(i)) then - crit(i) = critl - else - crit(i) = crits - endif - enddo - if(op == 'ge') then - do i=1,len - if(aisfld(i) >= crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'gt') then - do i=1,len - if(aisfld(i) > crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'le') then - do i=1,len - if(aisfld(i) <= crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'lt') then - do i=1,len - if(aisfld(i) < crit(i)) 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 - 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) 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 - 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) 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) 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, & - & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add 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 - 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) 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) 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 - 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) 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 == 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) == aicice .and. slmask(i) == 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 - implicit none - integer, intent(in) :: len, mode, me - real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, & - & fldlmx,fldlmn,fldomx,fldjmn, & - & fldsmx,fldsmn,epsfld,percrit & - integer, parameter :: mmprt=2 -! - character*8 ttl - logical iceflg(len) - real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo - logical lgchek -! - logical first - integer num_threads - real (kind=kind_io8) permax, per - data first /.true./ - save num_threads, first -! - integer :: len_thread_m, i1_t, i2_t, it, num_parthds, & - & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & - & ij,nprt,kmaxs,kmins,i - integer :: islimsk(len), iwk(len) -! - if (first) then - num_threads = num_parthds() - first = .false. - endif - do it=1,len - islimsk(it) = nint(slimsk(it)) - enddo -! -! check against land-sea mask and ice cover mask -! - if(me == 0) then - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' - endif -! - len_thread_m = (len+num_threads-1) / num_threads - - kmaxl = 0 ; kminl = 0 ; kmaxo = 0 ; kmino = 0 - kmaxi = 0 ; kmini = 0 ; kmaxj = 0 ; kminj = 0 - kmaxs = 0 ; kmins = 0 - -!$omp parallel do private(i1_t,i2_t,it,i) -!$omp+private(nprt,ij,iwk) -!$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) -!$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) -!$omp+shared(mode,epsfld) -!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) -!$omp+shared(fld,islimsk,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) -! -! -! -! lower bound check over bare land -! - if (fldlmn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kminl - fld(iwk(i)) = fldlmn - enddo - endif - endif -! -! upper bound check over bare land -! - if (fldlmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) > 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 == 1) then - do i=1,kmaxl - fld(iwk(i)) = fldlmx - enddo - endif - endif -! -! lower bound check over snow covered land -! - if (fldsmn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kmins - fld(iwk(i)) = fldsmn - enddo - endif - endif -! -! upper bound check over snow covered land -! - if (fldsmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) > 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,i & - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode == 1) then - do i=1,kmaxs - fld(iwk(i)) = fldsmx - enddo - endif - endif -! -! lower bound check over open ocean -! - if (fldomn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 0.0 .and. fld(i) < 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 == 1) then - do i=1,kmino - fld(iwk(i)) = fldomn - enddo - endif - endif -! -! upper bound check over open ocean -! - if (fldomx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) ==.0 .and. fld(i) > 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 == 1) then - do i=1,kmaxo - fld(iwk(i)) = fldomx - enddo - endif - endif -! -! lower bound check over sea ice without snow -! - if (fldimn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kmini - fld(iwk(i)) = fldimn - enddo - endif - endif -! -! upper bound check over sea ice without snow -! - if (fldimx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & - & fld(i) > 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 == 1) then - do i=1,kmaxi - fld(iwk(i)) = fldimx - enddo - endif - endif -! -! lower bound check over sea ice with snow -! - if (fldjmn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & - & fld(i) < 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 == 1) then - do i=1,kminj - fld(iwk(i)) = fldjmn - enddo - endif - endif -! -! upper bound check over sea ice with snow -! - if (fldjmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & - & fld(i)> 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 == 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 == 0) then - permax = 0.0 - if(kminl > 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 > permax) permax = per - endif - if(kmaxl > 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 > 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 > 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 >.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 > 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 > 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 > 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 > permax) permax=per - endif - if(kminj > 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 > 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 > 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), smcclm(len,lsoil) -! - if (me == 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. -! TG3 MODS BEGIN - if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116 - & .and. kpds4 == 128) then -! print*,'turn off setrmsk for tg3' - lmask = .false. - - elseif(kpds5 == kpdtsf) then -! TG3 MODS END -! -! surface temperature -! - 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. -! -! 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 == 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, & - & 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, & - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kpdvet,kpdsot,kpdalf,tsfcl0, & - & kpdvmn,kpdvmx,kpdslp,kpdabs, & - & 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 - 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,landice_cat - integer kpdalb(4), kpdalf(2) -! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & - & fnvetc,fnsotc,fnalbc2 & - &, 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) - 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(:), absm(:) -! - 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, absm, - & 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 - 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), absm(len), - & veg(len,2), stc(len,lsoil,2)) -! -! get tsf climatology for the begining of the forecast -! - if (fh > 0.0) then -!cbosu - if (me == 0) print*,'bosu fh gt 0' - - iy4 = iy - if (iy < 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 == 0) 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 < dayhf(1)) rjday = rjday + 365. -! - if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 0) 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 == 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 < 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 < dayhf(1)) rjday = rjday + 365. - - if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! for seasonal mean climatology -! - monend = 4 - is = im/3 + 1 - if (is == 5) is = 1 - do mm=1,monend - mmm = mm*3 - 2 - mmp = (mm+1)*3 - 2 - if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1s -! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) - if (sea2 == 13) sea2 = 1 - if (me == 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 == 3) is = 1 - do mm=1,monend - mmm = mm*6 - 5 - mmp = (mm+1)*6 - 5 - if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1y -! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) - if (hyr2 == 13) hyr2 = 1 - if (me == 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) 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 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, - & absm,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index, - & kpdabs, absm, 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 -! -! 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 == 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 == 5) isx = 1 - if (isx == 1) kpd9 = 12 - if (isx == 2) kpd9 = 3 - if (isx == 3) kpd9 = 6 - if (isx == 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 -! -! 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) = absm(i) - 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 - 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), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) - real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) -! - logical lmask, yr2kc, gaus, ijordr - logical*1, allocatable :: lbms(:) -! - integer, intent(in) :: kpds7 - integer kpds(1000),kgds(1000) - integer jpds(1000),jgds(1000), kpds0(1000) - real (kind=kind_io8) outlat(len), outlon(len) -! - allocate(data8(1:mdata)) - allocate(lbms(mdata)) -! -! 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) 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) write(6,*) ' 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) 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(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) 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) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax - else - write(6,*) ' error in getgb - jret=', jret - call abort - endif -! -! if (me == 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 == 0) 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) 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) -! - deallocate(data8) - deallocate(lbms) - return - end subroutine fixrdc - - 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 - 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), allocatable :: data8(:) - 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) -! - allocate(data8(1:mdata)) - 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) write(6,*) ' 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) 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(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) 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 == 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 == 0) 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,*) ' ' - deallocate(data8) - return -! - 100 continue - iret=1 - do i=1,len - gdata(i) = -999. - enddo -! - call baclose(lugb,iret2) -! - deallocate(data8) - 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/gfsphysics/physics/sflx.f b/gfsphysics/physics/sflx.f deleted file mode 100644 index bb816e9b2..000000000 --- a/gfsphysics/physics/sflx.f +++ /dev/null @@ -1,5571 +0,0 @@ -!----------------------------------- - 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/gfsphysics/physics/shalcnv.f b/gfsphysics/physics/shalcnv.f deleted file mode 100644 index 46ecf63b3..000000000 --- a/gfsphysics/physics/shalcnv.f +++ /dev/null @@ -1,1281 +0,0 @@ -!> \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/gfsphysics/physics/shalcv.f b/gfsphysics/physics/shalcv.f deleted file mode 100644 index 0756628a7..000000000 --- a/gfsphysics/physics/shalcv.f +++ /dev/null @@ -1,205 +0,0 @@ - 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/gfsphysics/physics/shalcv_1lyr.f b/gfsphysics/physics/shalcv_1lyr.f deleted file mode 100644 index 7ef2443fe..000000000 --- a/gfsphysics/physics/shalcv_1lyr.f +++ /dev/null @@ -1,188 +0,0 @@ - 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/gfsphysics/physics/shalcv_fixdp.f b/gfsphysics/physics/shalcv_fixdp.f deleted file mode 100644 index adbccc43f..000000000 --- a/gfsphysics/physics/shalcv_fixdp.f +++ /dev/null @@ -1,194 +0,0 @@ - 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/gfsphysics/physics/shalcv_opr.f b/gfsphysics/physics/shalcv_opr.f deleted file mode 100644 index 327a155f8..000000000 --- a/gfsphysics/physics/shalcv_opr.f +++ /dev/null @@ -1,164 +0,0 @@ - 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/gfsphysics/physics/surface_perturbation.F90 b/gfsphysics/physics/surface_perturbation.F90 deleted file mode 100644 index 0c6535718..000000000 --- a/gfsphysics/physics/surface_perturbation.F90 +++ /dev/null @@ -1,419 +0,0 @@ -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/gfsphysics/physics/tracer_const_h.f b/gfsphysics/physics/tracer_const_h.f deleted file mode 100644 index d51a12c6a..000000000 --- a/gfsphysics/physics/tracer_const_h.f +++ /dev/null @@ -1,62 +0,0 @@ - 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/gfsphysics/physics/tridi2t3.f b/gfsphysics/physics/tridi2t3.f deleted file mode 100644 index d99609dd1..000000000 --- a/gfsphysics/physics/tridi2t3.f +++ /dev/null @@ -1,41 +0,0 @@ - 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/gfsphysics/physics/ugwp_driver_v0.f b/gfsphysics/physics/ugwp_driver_v0.f deleted file mode 100644 index 872e5225b..000000000 --- a/gfsphysics/physics/ugwp_driver_v0.f +++ /dev/null @@ -1,2088 +0,0 @@ -!!23456 - module sso_coorde -! -! specific to COORDE-2019 project OGW switches/sensitivity -! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) -! pgd4=4 (4 timse taub, control pgwd=1) -! - use machine, only: kind_phys - real(kind=kind_phys),parameter :: pgwd = 1._kind_phys - real(kind=kind_phys),parameter :: pgwd4 = 1._kind_phys - logical,parameter :: debugprint = .false. - end module sso_coorde -! -! - subroutine cires_ugwp_driver_v0(me, master, - & im, levs, nmtvr, dtp, kdt, imx, do_ugwp, do_tofd, - & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, - & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, - & phii, phil, del, hprime, oc, oa4, clx, theta, - & gamm, sigma, elvmax, sgh30, kpbl, - & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, - & tau_tofd, tau_mtb, tau_ogw, tau_ngw, - & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, - & rain, ntke, tke, lprnt, ipr) -!----------------------------------------------------------- -! Part 1 "old-revised" gfs-gwdps_v0 or "old" gwdps (if do_ugwp=.false.) -! Part 2 non-stationary multi-wave GWs FV3GFS-v0 -! Part 3 Dissipative version of UGWP-tendency application -! (similar to WAM-2017) -!----------------------------------------------------------- - use machine, only : kind_phys - use physcons, only : con_cp, con_g, con_rd, con_rv - - use ugwp_wmsdis_init, only : tamp_mpa, ilaunch - use sso_coorde, only : pgwd, pgwd4, debugprint - implicit none -!input - - integer, intent(in) :: me, master - integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr - - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) - logical :: do_ugwp, do_tofd, lprnt - integer, intent(in) :: kpbl(im) - real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd - &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area - &, rain - - real(kind=kind_phys), intent(in), dimension(im,levs) :: ugrs - &, vgrs, tgrs, qgrs, prsl, prslk, phil, del - real(kind=kind_phys), intent(in), dimension(im,levs+1) :: prsi - &, phii - -! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) - real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc - &, theta, gamm, sigma, elvmax - real(kind=kind_phys), intent(in), dimension(im,4) :: oa4, clx - real(kind=kind_phys), intent(in) :: tke(im,levs) -!out - real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt - &, gw_dTdt, gw_kdis - -!-----locals + diagnostics output - - real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt - &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt - - real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg - - real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, - & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw, turb_fac - real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw - &, du3dt_tms - real(kind=kind_phys), dimension(im) :: tem - -! locals - real(kind=kind_phys) :: rfac, tx1 - integer :: i, j, k, ix -! -! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax -! -! real(kind=kind_phys), dimension(im) :: hprime, -! & oc, theta, sigma, gamm, elvmax -! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 -! -! switches that activate impact of OGWs and NGWs along with eddy diffusion -! - real(kind=kind_phys), parameter :: pogw=1.0, pngw=1.0, pked=1.0 - &, ompked=1.0-pked -! -! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) -! - if (me == master .and. kdt < 2 .and. debugprint ) then - print * - write(6,*) 'FV3GFS execute ugwp_driver_v0 ' -! write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr - write(6,*) ' COORDE EXPER pogw = ' , pogw - write(6,*) ' COORDE EXPER pgwd = ' , pgwd - write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 - print * - endif - - do i=1,im - zlwb(i) = 0. - enddo -! -! 1) ORO stationary GWs -! ------------------ - - if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag - CALL GWDPS_V0(IM, levs, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, - & ugrs , vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, - & prslk, phii, phil, DTP,KDT, - & sgh30, HPRIME, OC, OA4, CLX, THETA, - & SIGMA, GAMM, ELVMAX, - & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, - & cdmbgwd(1:2), me, master, rdxzb, - & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, - & du3dt_mtb, du3dt_ogw, du3dt_tms) -! - if (me == master .and. kdt < 2 .and. debugprint) then - print * - write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' - print * - endif - else ! calling old GFS gravity wave drag as is - do k=1,levs - do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 - enddo - enddo - if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then - call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & - &, ugrs, vgrs, tgrs, qgrs & - &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& - &, hprime, oc, oa4, clx, theta, sigma, gamm & - &, elvmax, dusfcg, dvsfcg & - &, con_g, con_cp, con_rd, con_rv, imx & - &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) - endif - - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 - endif -! - if (cdmbgwd(3) > 0.0) then -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing -! ---------------------------------------------- -!-------- -! GMAO GEOS-5/MERRA GW-forcing lat-dep -!-------- - call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) - -! call slat_geos5(im, xlatd, tau_ngw) -! - if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then - if (cdmbgwd(4) > 0.0) then - do i=1,im - turb_fac(i) = 0.0 - tem(i) = 0.0 - enddo - if (ntke > 0) then - do k=1,(levs+levs)/3 - do i=1,im - turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) - tem(i) = tem(i) + del(i,k) - enddo - enddo - do i=1,im - turb_fac(i) = turb_fac(i) / tem(i) - enddo - endif - rfac = 86400000 / dtp - do i=1,im - tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) - enddo - endif - do i=1,im - tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) - enddo - endif -! - call fv3_ugwp_solv2_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, prsl, prsi, - & phil, xlatd, sinlat, coslat, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & tau_ngw, me, master, kdt) - - if (me == master .and. kdt < 2 .and. debugprint ) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * - endif - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) - enddo - enddo - else - do k=1,levs - do i=1,im - gw_dtdt(i,k) = Pdtdt(i,k) - gw_dudt(i,k) = Pdudt(i,k) - gw_dvdt(i,k) = Pdvdt(i,k) - gw_kdis(i,k) = Pkdis(i,k) - enddo - enddo - endif - - if (pogw == 0.0) then -! zmtb = 0.; zogw =0. - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 - endif - - return - -!============================================================================= -! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving -! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" -!============================================================================= -! -! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies -!------------------------------------------------------------------------------ - do k=1,levs - do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 - enddo - enddo - - call edmix_ugwp_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, del, - & prsl, prsi, phil, prslk, - & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) - - do k=1,levs - do i=1,im - gw_dtdt(i,k) = gw_dtdt(i,k)*ompked + ed_dtdt(i,k)*pked - gw_dvdt(i,k) = gw_dvdt(i,k)*ompked + ed_dvdt(i,k)*pked - gw_dudt(i,k) = gw_dudt(i,k)*ompked + ed_dudt(i,k)*pked - enddo - enddo - - end subroutine cires_ugwp_driver_v0 -! -!===================================================================== -! -!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 -! -!===================================================================== - SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, U1,V1,T1,Q1,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, - & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, - & DUSFC, DVSFC, xlatd, sinlat, coslat, sparea, - $ cdmbgwd, me, master, rdxzb, - & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, - & dudt_mtb, dudt_ogw, dudt_tms) -!---------------------------------------- -! ugwp_v0 -! -! modified/revised version of gwdps.f (with bug fixes, tofd, appropriate -! computation of kref for OGW + COORDE diagnostics -! all constants/parameters inside cires_ugwp_initialize.F90 -!---------------------------------------- - - USE MACHINE , ONLY : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpd, rcpd2 - &, pi, rad_to_deg, deg_to_rad, pi2 - &, rdi, gor, grcp, gocp, fv, gr2 - &, bnv2min, dw2min, velmin, arad - - use ugwp_oro_init, only : rimin, ric, efmin, efmax - &, hpmax, hpmin, sigfaci => sigfac - &, dpmin, minwnd, hminmt, hncrit - &, RLOLEV, GMAX, VELEPS, FACTOP - &, FRC, CE, CEOFRC, frmax, CG - &, FDIR, MDIR, NWDIR - &, cdmb, cleff, fcrit_gfs, fcrit_mtb - &, n_tofd, ze_tofd, ztop_tofd - - use cires_ugwp_module, only : kxw, max_kdis, max_axyz - use sso_coorde, only : pgwd, pgwd4, debugprint -!---------------------------------------- - implicit none - character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' - integer, intent(in) :: im, km, imx, kdt - integer, intent(in) :: me, master - logical, intent(in) :: do_tofd - real(kind=kind_phys), parameter :: sigfac = 3, sigfacS = 0.5 - real(kind=kind_phys) :: ztopH,zlowH,ph_blk, dz_blk - integer, intent(in) :: KPBL(IM) ! Index for the PBL top layer! - real(kind=kind_phys), intent(in) :: dtp ! time step - real(kind=kind_phys), intent(in) :: cdmbgwd(2) - - real(kind=kind_phys), intent(in), dimension(im,km) :: - & u1, v1, t1, q1, - & del, prsl, prslk, phil - real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, phii - real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), - & coslat(im) - real(kind=kind_phys), intent(in) :: sparea(im) - - real(kind=kind_phys), intent(in) :: OC(IM), OA4(im,4), CLX4(im,4) - real(kind=kind_phys), intent(in) :: HPRIME(IM), sgh30(IM) - real(kind=kind_phys), intent(in) :: ELVMAXD(IM), THETA(IM) - real(kind=kind_phys), intent(in) :: vSIGMA(IM), vGAMMA(IM) - real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) - -!output -phys-tend - real(kind=kind_phys),dimension(im,km),intent(out) :: - & Pdvdt, Pdudt, Pkdis, Pdtdt -! output - diag-coorde - &, dudt_mtb, dudt_ogw, dudt_tms -! - real(kind=kind_phys),dimension(im) :: RDXZB, zmtb, zogw - &, tau_ogw, tau_mtb, tau_tofd - &, dusfc, dvsfc -! -!--------------------------------------------------------------------- -! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 -! 4.*gamma*b_ell*b_ell >= shilmin -! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min -! gamma_min = 1/4*shilmin/sso_min/sso_min -!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 -! 192: cdmbgwd = 0.5, 2.5 -! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km -! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective -!--------------------------------------------------------------------- - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. - logical, parameter :: do_adjoro = .true. -! - real(kind=kind_phys) :: shilmin, sgrmax, sgrmin - real(kind=kind_phys) :: belpmin, dsmin, dsmax -! real(kind=kind_phys) :: arhills(im) ! not used why do we need? - real(kind=kind_phys) :: xlingfs - -! -! locals -! mean flow - real(kind=kind_phys), dimension(im,km) :: RI_N, BNV2, RO - &, VTK, VTJ, VELCO -!mtb - real(kind=kind_phys), dimension(im) :: OA, CLX , elvmax, wk - &, PE, EK, UP - - real(kind=kind_phys), dimension(im,km) :: DB, ANG, UDS - - real(kind=kind_phys) :: ZLEN, DBTMP, R, PHIANG, DBIM, ZR - real(kind=kind_phys) :: ENG0, ENG1, COSANG2, SINANG2 - real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem -! -! TOFD -! Some constants now in "use ugwp_oro_init" + "use ugwp_common" -! -!================== - real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf - real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 - &, epstofd1, krf_tofd1 - &, up1, vp1, zpm - real(kind=kind_phys),dimension(im, km) :: axtms, aytms -! -! OGW -! - LOGICAL ICRILV(IM) -! - real(kind=kind_phys), dimension(im) :: XN, YN, UBAR, VBAR, ULOW, - & ROLL, bnv2bar, SCOR, DTFAC, XLINV, DELKS, DELKS1 -! - real(kind=kind_phys) :: TAUP(IM,km+1), TAUD(IM,km) - real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis - - integer, dimension(im) :: kref, idxzb, ipt, kreflm, - & iwklm, iwk, izlow -! -!check what we need -! - real(kind=kind_phys) :: bnv, fr, ri_gw - &, brvf, tem, tem1, tem2, temc, temv - &, ti, rdz, dw2, shr2, bvf2 - &, rdelks, efact, coefm, gfobnv - &, scork, rscor, hd, fro, sira - &, dtaux, dtauy, pkp1log, pklog - &, grav2, rcpdt, windik, wdir - &, sigmin, dxres,sigres,hdxres - &, cdmb4, mtbridge - &, kxridge, inv_b2eff, zw1, zw2 - &, belps, aelps, nhills, selps - - integer :: kmm1, kmm2, lcap, lcapp1 - &, npt, kbps, kbpsp1,kbpsm1 - &, kmps, idir, nwd, klcap, kp1, kmpbl, kmll - &, k_mtb, k_zlow, ktrial, klevm1, i, j, k -! - rcpdt = 1.0 / (cpd*dtp) - grav2 = grav + grav -! -! mtb-blocking sigma_min and dxres => cires_initialize -! - sgrmax = maxval(sparea) ; sgrmin = minval(sparea) - dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) - - dxres = pi2*arad/float(IMX) - hdxres = 0.5*dxres -! shilmin = sgrmin/nhilmax ! not used - Moorthi - -! gammin = min(sso_min/dsmax, 1.) ! Moorthi - with this results are not reproducible - gammin = min(sso_min/dxres, 1.) ! Moorthi - -! sigmin = 2.*hpmin/dsmax !dxres ! Moorthi - this will not reproduce - sigmin = 2.*hpmin/dxres !dxres - -! if (kdt == 1) then -! print *, sgrmax, sgrmin , ' min-max sparea ' -! print *, 'sigmin-hpmin-dsmax', sigmin, hpmin, dsmax -! print *, 'dxres/dsmax ', dxres, dsmax -! print *, ' shilmin gammin ', shilmin, gammin -! endif - - kxridge = float(IMX)/arad * cdmbgwd(2) - - if (me == master .and. kdt == 1 .and. debugprint) then - print *, ' gwdps_v0 kxridge ', kxridge - print *, ' gwdps_v0 scale2 ', cdmbgwd(2) - print *, ' gwdps_v0 IMX ', imx - print *, ' gwdps_v0 GAM_MIN ', gammin - print *, ' gwdps_v0 SSO_MIN ', sso_min - endif - - do i=1,im - idxzb(i) = 0 - zmtb(i) = 0.0 - zogw(i) = 0.0 - rdxzb(i) = 0.0 - tau_ogw(i) = 0.0 - tau_mtb(i) = 0.0 - dusfc(i) = 0.0 - dvsfc(i) = 0.0 - tau_tofd(i) = 0.0 -! - ipt(i) = 0 - sigma(i) = max(vsigma(i), sigmin) - gamma(i) = max(vgamma(i), gammin) - enddo - - do k=1,km - do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 - dudt_mtb(i,k) = 0.0 - dudt_ogw(i,k) = 0.0 - dudt_tms(i,k) = 0.0 - enddo - enddo - -! ---- for lm and gwd calculation points - - npt = 0 - do i = 1,im - if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then - - npt = npt + 1 - ipt(npt) = i -! arhills(i) = 1.0 -! - sigres = max(sigmin, sigma(i)) -! if (sigma(i) < sigmin) sigma(i)= sigmin - dxres = sqrt(sparea(i)) - if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres - aelps = min(2.*hprime(i)/sigres, 0.5*dxres) - if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) -! -! small-scale "turbulent" oro-scales < sso_min -! - if( aelps < sso_min .and. do_adjoro) then - -! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm -! - aelps = sso_min - if (belps < sso_min ) then - gamma(i) = 1.0 - belps = aelps*gamma(i) - else - gamma(i) = min(aelps/belps, 1.0) - endif - sigma(i) = 2.*hprime(i)/aelps - gamma(i) = min(aelps/belps, 1.0) - endif - - selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill - nhills = min(nhilmax, sparea(i)/selps) -! arhills(i) = max(nhills, 1.0) - -!333 format( ' nhil: ', I6, 4(2x, F9.3), 2(2x, E9.3)) -! if (kdt==1 ) -! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, -! & belps*1.e-3, sigma(i),gamma(i) - - endif - enddo - - IF (npt == 0 .and. debugprint) then -! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin - RETURN ! No gwd/mb calculation done - endif - - - do i=1,npt - iwklm(i) = 2 - IDXZB(i) = 0 - kreflm(i) = 0 - enddo - - do k=1,km - do i=1,im - db(i,k) = 0.0 - ang(i,k) = 0.0 - uds(i,k) = 0.0 - enddo - enddo - - KMM1 = km - 1 ; KMM2 = km - 2 ; KMLL = kmm1 - LCAP = km ; LCAPP1 = LCAP + 1 - - DO I = 1, npt - j = ipt(i) - ELVMAX(J) = min (ELVMAXd(J)*0. + sigfac * hprime(j), hncrit) - izlow(i) = 1 ! surface-level - ENDDO -! - DO K = 1, kmm1 - DO I = 1, npt - j = ipt(i) - ztopH = sigfac * hprime(j) - zlowH = sigfacs* hprime(j) - pkp1log = phil(j,k+1) * rgrav - pklog = phil(j,k) * rgrav -! if (( ELVMAX(j) <= pkp1log) .and. (ELVMAX(j).ge.pklog) ) -! & iwklm(I) = MAX(iwklm(I), k+1 ) - if (( ztopH <= pkp1log) .and. (zTOPH >= pklog) ) - & iwklm(I) = MAX(iwklm(I), k+1 ) -! - if (zlowH <= pkp1log .and. zlowH >= pklog) - & izlow(I) = MAX(izlow(I),k) - ENDDO - ENDDO -! - 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 mid-levels - TAUP(I,K) = 0.0 - ENDDO - ENDDO -! -! check RI_N or RI_MF computation -! - DO K = 1,kmm1 - DO I =1,npt - J = ipt(i) - RDZ = grav / (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 -! TI = 2.0 / (T1(J,K)+T1(J,K+1)) -! BVF2 = Grav*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K)))* TI -! RI_N(I,K) = MAX(BVF2/SHR2,RIMIN) ! Richardson number -! - BVF2 = grav2 * RDZ * (VTK(I,K+1)-VTK(I,K)) - & / (VTK(I,K+1)+VTK(I,K)) - bnv2(i,k+1) = max( BVF2, bnv2min ) - RI_N(I,K+1) = Bnv2(i,k)/SHR2 ! Richardson number consistent with BNV2 -! -! add here computation for Ktur and OGW-dissipation fro VE-GFS -! - ENDDO - ENDDO - K = 1 - DO I = 1, npt - bnv2(i,k) = bnv2(i,k+1) - ENDDO -! -! level iwklm =>phil(j,k)/g < sigfac * hprime(j) < phil(j,k+1)/g -! - DO I = 1, npt - J = ipt(i) - k_zlow = izlow(I) - if (k_zlow == iwklm(i)) k_zlow = 1 - DELKS(I) = 1.0 / (PRSI(J,k_zlow) - PRSI(J,iwklm(i))) -! DELKS1(I) = 1.0 /(PRSL(J,k_zlow) - 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) = 0.0 - ENDDO -! - DO I = 1, npt - k_zlow = izlow(I) - if (k_zlow == iwklm(i)) k_zlow = 1 - DO K = k_zlow, iwklm(I)-1 ! Kreflm(I)= iwklm(I)-1 - J = ipt(i) ! laye-aver Rho, U, V - 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 -! - BNV2bar(I) = BNV2bar(I) + .5*(BNV2(I,K)+BNV2(I,K+1))* RDELKS - ENDDO - ENDDO -! - DO I = 1, npt - J = ipt(i) -! -! integrate from Ztoph = sigfac*hprime down to Zblk if exists -! find ph_blk, dz_blk like in LM-97 and IFS -! - ph_blk = 0. - 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) > 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. - ANG(I,K) = ANG(I,K) * DEG_TO_RAD - UDS(I,K) = - & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), velmin) -! - IF (IDXZB(I) == 0 ) then - dz_blk = ( PHII(J,K+1) - PHII(J,K) ) *rgrav - PE(I) = PE(I) + BNV2(I,K) * - & ( ELVMAX(J) - phil(J,K)*rgrav ) * dz_blk - - UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) - EK(I) = 0.5 * UP(I) * UP(I) - - ph_blk = ph_blk + dz_blk*sqrt(BNV2(I,K))/UP(I) - -! --- Dividing Stream lime is found when PE =exceeds EK. oper-l GFS -! IF ( PE(I) >= EK(I) ) THEN - IF ( ph_blk >= fcrit_gfs ) THEN - IDXZB(I) = K - zmtb (J) = PHIL(J, K)*rgrav - RDXZB(J) = real(k, kind=kind_phys) - ENDIF - - ENDIF - ENDDO -! -! Alternative expression: ZMTB = max(Heff*(1. -Fcrit_gfs/Fr), 0) -! fcrit_gfs/fr -! - goto 788 - - BNV = SQRT( BNV2bar(I) ) - heff = 2.*min(HPRIME(J),hpmax) - zw2 = UBAR(I)*UBAR(I)+VBAR(I)*VBAR(I) - Ulow(i) = sqrt(max(zw2,dw2min)) - Fr = heff*bnv/Ulow(i) - ZW1 = max(Heff*(1. -fcrit_gfs/fr), 0.0) - zw2 = phil(j,2)*rgrav - if (Fr > fcrit_gfs .and. zw1 > zw2 ) then - do k=2, kmm1 - pkp1log = phil(j,k+1) * rgrav - pklog = phil(j,k) * rgrav - if (zw1 <= pkp1log .and. zw1 >= pklog) exit - enddo - IDXZB(I) = K - zmtb (J) = PHIL(J, K)*rgrav - else - zmtb (J) = 0. - IDXZB(I) = 0 - endif -788 continue - ENDDO - -! -! --- The drag for mtn blocked flow -! - cdmb4 = 0.25*cdmb - DO I = 1, npt - J = ipt(i) -! - IF ( IDXZB(I) > 0 ) then -! (4.16)-IFS - gam2 = gamma(j)*gamma(j) - BGAM = 1.0 - 0.18*gamma(j) - 0.04*gam2 - CGAM = 0.48*gamma(j) + 0.30*gam2 - DO K = IDXZB(I)-1, 1, -1 - - ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / - & ( PHIL(J,K ) + Grav * hprime(J) ) ) - - tem = cos(ANG(I,K)) - COSANG2 = tem * tem - SINANG2 = 1.0 - COSANG2 -! -! cos =1 sin =0 => 1/R= gam ZR = 2.- gam -! cos =0 sin =1 => 1/R= 1/gam ZR = 2.- 1/gam -! - rdem = COSANG2 + GAM2 * SINANG2 - rnom = COSANG2*GAM2 + SINANG2 -! -! metOffice Dec 2010 -! correction of H. Wells & A. Zadra for the -! aspect ratio of the hill seen by MF -! (1/R , R-inverse below: 2-R) - - rdem = max(rdem, 1.e-6) - R = sqrt(rnom/rdem) - ZR = MAX( 2. - R, 0. ) - - sigres = max(sigmin, sigma(J)) - if (hprime(J)/sigres > dxres) sigres = hprime(J)/dxres - mtbridge = ZR * sigres*ZLEN / hprime(J) -! (4.15)-IFS -! DBTMP = CDmb4 * mtbridge * -! & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) -! (4.16)-IFS - DBTMP = CDmb4*mtbridge*(bgam* COSANG2 +cgam* SINANG2) - DB(I,K)= DBTMP * UDS(I,K) - ENDDO -! - endif - ENDDO -! -!............................. -!............................. -! end mtn blocking section -!............................. -!............................. -! -!--- Orographic Gravity Wave Drag Section -! -! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 -! inside "cires_ugwp_initialize.F90" now -! - KMPBL = km / 2 - iwk(1:npt) = 2 -! -! METO-scheme: -! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! - DO K=3,KMPBL - DO I=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem < dpmin) iwk(i) = k ! dpmin=50 mb - -!=============================================================== -! lev=111 t=311.749 hkm=0.430522 Ps-P(iwk)=52.8958 -! below "Hprime" - source of OGWs and below Zblk !!! -! 27 2 kpbl ~ 1-2 km < Hprime -!=============================================================== - enddo - enddo -! -! iwk - adhoc GFS-parameter to select OGW-launch level between -! LEVEL ~0.4-0.5 KM from surface or/and PBL-top -! in UGWP-V1: options to modify as Htop ~ (2-3)*Hprime > Zmtb -! in UGWP-V0 we ensured that : Zogw > Zmtb -! - - KBPS = 1 - KMPS = km - K_mtb = 1 - DO I=1,npt - J = ipt(i) - K_mtb = max(1, idxzb(i)) - - kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level PBL or smt-else ???? - kref(I) = MAX(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime - - if (kref(i) <= idxzb(i)) kref(i) = idxzb(i) + 1 ! layer above zmtb - KBPS = MAX(KBPS, kref(I)) - KMPS = MIN(KMPS, kref(I)) -! - DELKS(I) = 1.0 / (PRSI(J,k_mtb) - PRSI(J,kref(I))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - BNV2bar(I)= 0.0 - ENDDO -! - KBPSP1 = KBPS + 1 - KBPSM1 = KBPS - 1 - K_mtb = 1 -! - DO I = 1,npt - K_mtb = max(1, idxzb(i)) - DO K = k_mtb,KBPS !KBPS = MAX(kref) ;KMPS= MIN(kref) - IF (K < 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 - BNV2bar(I) = BNV2bar(I) + .5*(BNV2(I,K)+BNV2(I,K+1))* RDELKS - ENDIF - ENDDO - ENDDO -! -! orographic asymmetry parameter (OA), and (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 -! - DO I = 1,npt - DTFAC(I) = 1.0 - ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR - ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I)+VBAR(I)*VBAR(I)),velmin) - XN(I) = UBAR(I) / ULOW(I) - YN(I) = VBAR(I) / 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))*XN(I) - & + (V1(J,K)+V1(J,K+1))*YN(I)) - ENDDO - ENDDO -! -!------------------ -! v0: incorporates latest modifications for kxridge and heff/hsat -! and taulin for Fr <=fcrit_gfs -! and concept of "clipped" hill if zmtb > 0. to make -! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data -! it is still used the "single-OGWave"-approach along ULOW-upwind -! -! in contrast to the 2-orthogonal wave (2OTW) schemes of IFS/METO/E-CANADA -! 2OTW scheme requires "aver angle" and wind projections on 2 axes of ellipse a-b -! with 2-stresses: taub_a & taub_b from AS of Phillips et al. (1984) -!------------------ - taub(:) = 0. ; taulin(:)= 0. - DO I = 1,npt - J = ipt(i) - BNV = SQRT( BNV2bar(I) ) - heff = min(HPRIME(J),hpmax) - - if( zmtb(j) > 0.) heff = max(sigfac*heff-zmtb(j), 0.)/sigfac - if (heff <= 0) cycle - - hsat = fcrit_gfs*ULOW(I)/bnv - heff = min(heff, hsat) - - FR = min(BNV * heff /ULOW(I), FRMAX) -! - EFACT = (OA(I) + 2.) ** (CEOFRC*FR) - EFACT = MIN( MAX(EFACT,EFMIN), EFMAX ) -! - COEFM = (1. + CLX(I)) ** (OA(I)+1.) -! - XLINV(I) = COEFM * CLEFF ! effective kxw for Lin-wave - XLINGFS = COEFM * CLEFF -! - TEM = FR * FR * OC(J) - GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) -! -!new specification of XLINV(I) & taulin(i) - - sigres = max(sigmin, sigma(J)) - if (heff/sigres > hdxres) sigres = heff/hdxres - inv_b2eff = 0.5*sigres/heff - kxridge = 1.0 / sqrt(sparea(J)) - XLINV(I) = XLINGFS !or max(kxridge, inv_b2eff) ! 6.28/Lx ..0.5*sigma(j)/heff = 1./Lridge - taulin(i) = 0.5*ROLL(I)*XLINV(I)*BNV*ULOW(I)* - & heff*heff*pgwd4 - - if ( FR > fcrit_gfs ) then - TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 ! nonlinear FLUX Tau0...XLINV(I) -! - else -! - TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) - & * ULOW(I) * GFOBNV * EFACT *pgwd4 -! -! TAUB(I) = taulin(i) ! linear flux for FR <= fcrit_gfs -! - endif -! -! - K = MAX(1, kref(I)-1) - TEM = MAX(VELCO(I,K)*VELCO(I,K), dw2min) - SCOR(I) = BNV2(I,K) / TEM ! Scorer parameter below ref level -! -! diagnostics for zogw > zmtb -! - zogw(J) = PHII(j, kref(I)) *rgrav - ENDDO -! -!----SET UP BOTTOM VALUES OF STRESS -! - DO K = 1, KBPS - DO I = 1,npt - IF (K <= kref(I)) TAUP(I,K) = TAUB(I) - ENDDO - ENDDO - - if (strsolver == 'PSS-1986') then - -!====================================================== -! V0-GFS OROGW-solver of Palmer et al 1986 -"PSS-1986" -! in V1-OROGW LINSATDIS of "WAM-2017" -! with LLWB-mechanism for -! rotational/non-hydrostat OGWs important for -! HighRES-FV3GFS with dx < 10 km -!====================================================== - - DO K = KMPS, KMM1 ! Vertical Level Loop - KP1 = K + 1 - DO I = 1, npt -! - IF (K >= kref(I)) THEN - ICRILV(I) = ICRILV(I) .OR. ( RI_N(I,K) < RIC) - & .OR. (VELCO(I,K) <= 0.0) - ENDIF - ENDDO -! - DO I = 1,npt - IF (K >= kref(I)) THEN - IF (.NOT.ICRILV(I) .AND. TAUP(I,K) > 0.0 ) THEN - TEMV = 1.0 / max(VELCO(I,K), velmin) -! - IF (OA(I) > 0. .AND. kp1 < kref(i)) THEN - SCORK = BNV2(I,K) * TEMV * TEMV - RSCOR = MIN(1.0, SCORK / SCOR(I)) - SCOR(I) = SCORK - ELSE - RSCOR = 1. - ENDIF -! - BRVF = SQRT(BNV2(I,K)) ! Brent-Vaisala Frequency interface -! 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), velmin) - HD = SQRT(TAUP(I,K) / TEM1) - FRO = BRVF * HD * TEMV -! -! RIM is the "WAVE"-RICHARDSON NUMBER BY PALMER,Shutts, Swinbank 1986 -! - - TEM2 = SQRT(ri_n(I,K)) - TEM = 1. + TEM2 * FRO - RI_GW = ri_n(I,K) * (1.0-FRO) / (TEM * TEM) -! -! CHECK STABILITY TO EMPLOY THE 'dynamical SATURATION HYPOTHESIS' -! OF PALMER,Shutts, Swinbank 1986 -! ---------------------- - IF (RI_GW <= RIC .AND. - & (OA(I) <= 0. .OR. kp1 >= kref(i) )) THEN - TEMC = 2.0 + 1.0 / TEM2 - HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF - TAUP(I,KP1) = TEM1 * HD * HD - ELSE - TAUP(I,KP1) = TAUP(I,K) * RSCOR - ENDIF - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - ENDIF - ENDIF - ENDDO - ENDDO -! -! zero momentum deposition at the top model layer -! - taup(1:npt,km+1) = taup(1:npt,km) -! -! Calculate wave acc-n: - (grav)*d(tau)/d(p) = taud -! - DO K = 1,KM - DO I = 1,npt - TAUD(I,K) = GRAV*(TAUP(I,K+1) - TAUP(I,K))/DEL(ipt(I),K) - ENDDO - ENDDO -! -!------scale MOMENTUM DEPOSITION AT TOP TO 1/2 VALUE -! it is zero now -! DO I = 1,npt -! TAUD(I, km) = TAUD(I,km) * FACTOP -! ENDDO - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!------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. -! Empirical implementation of the LLWB-mechanism: Lower Level Wave Breaking -! by limiting "Ax = Dtfac*Ax" due to possible LLWB around Kref and 500 mb -! critical line [V - Ax*dtp = 0.] is smt like "LLWB" for stationary OGWs -!2019: this option limits sensitivity of taux/tauy to increase/decreaseof TAUB -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO K = 1,KMM1 - DO I = 1,npt - IF (K >= kref(I) .and. PRSI(ipt(i),K) >= RLOLEV) THEN - - IF(TAUD(I,K) /= 0.) THEN - TEM = DTP * TAUD(I,K) - DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) -! DTFAC(I) = 1.0 - ENDIF - ENDIF - ENDDO - ENDDO -! -!--------------------------- OROGW-solver of GFS PSS-1986 -! - else -! -!--------------------------- OROGW-solver of WAM2017 -! -! sigres = max(sigmin, sigma(J)) -! if (heff/sigres.gt.dxres) sigres=heff/dxres -! inv_b2eff = 0.5*sigres/heff -! XLINV(I) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./Lridge - dtfac(:) = 1.0 - - call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, - & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, - & del, sigma, hprime, gamma, theta, - & sinlat, xlatd, taup, taud, pkdis) - - endif ! oro_wam_2017 - LINSATDIS-solver of WAM-2017 -! -!--------------------------- OROGW-solver of WAM2017 -! -! TOFD as in BELJAARS-2004 -! -! --------------------------- - IF( do_tofd ) then - axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - if ( kdt == 1 .and. me == 0 .and. debugprint) then - print *, 'VAY do_tofd from surface to ', ztop_tofd - endif - DO I = 1,npt - J = ipt(i) - zpbl =rgrav*phil( j, kpbl(j) ) - - sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of LS-SSO - - zsurf = phii(j,1)*rgrav - do k=1,km - zpm(k) = phiL(j,k)*rgrav - up1(k) = u1(j,k) - vp1(k) = v1(j,k) - enddo - - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, - & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - - do k=1,km - axtms(j,k) = utofd1(k) - aytms(j,k) = vtofd1(k) -! -! add TOFD to GW-tendencies -! - pdvdt(J,k) = pdvdt(J,k) + aytms(j,k) - pdudt(J,k) = pdudt(J,k) + axtms(j,k) - enddo -!2018-diag - tau_tofd(J) = sum( utofd1(1:km)* del(j,1:km)) - enddo - ENDIF ! do_tofd - -!--------------------------- -! combine oro-drag effects -!--------------------------- -! + diag-3d - - dudt_tms = axtms - tau_ogw = 0. - tau_mtb = 0. - - DO K = 1,KM - DO I = 1,npt - J = ipt(i) -! - ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) -! - if ( K < IDXZB(I) .AND. IDXZB(I) /= 0 ) then -! -! if blocking layers -- no OGWs -! - DBIM = DB(I,K) / (1.+DB(I,K)*DTP) - Pdvdt(j,k) = - DBIM * V1(J,K) +Pdvdt(j,k) - Pdudt(j,k) = - DBIM * U1(J,K) +Pdudt(j,k) - ENG1 = ENG0*(1.0-DBIM*DTP)*(1.-DBIM*DTP) - - DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) - DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) -!2018-diag - dudt_mtb(j,k) = -DBIM * U1(J,K) - tau_mtb(j) = tau_mtb(j) + dudt_mtb(j,k)* DEL(J,K) - - else -! -! OGW-s above blocking height -! - TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) * pgwd - DTAUY = TAUD(I,K) * YN(I) * pgwd - - Pdvdt(j,k) = DTAUY +Pdvdt(j,k) - Pdudt(j,k) = DTAUX +Pdudt(j,k) - - unew = U1(J,K) + DTAUX*dtp ! Pdudt(J,K)*DTP - vnew = V1(J,K) + DTAUY*dtp ! Pdvdt(J,K)*DTP - ENG1 = 0.5*(unew*unew + vnew*vnew) -! - DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) - DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) -!2018-diag - dudt_ogw(j,k) = DTAUX - tau_ogw(j) = tau_ogw(j) +DTAUX*DEL(j,k) - endif -! -! local energy deposition SSO-heat -! - Pdtdt(j,k) = max(ENG0-ENG1,0.)*rcpdt - ENDDO - ENDDO -! dusfc w/o tofd sign as in the ERA-I, MERRA and CFSR - DO I = 1,npt - J = ipt(i) - DUSFC(J) = -rgrav * DUSFC(J) - DVSFC(J) = -rgrav * DVSFC(J) - tau_mtb(j) = -rgrav * tau_mtb(j) - tau_ogw(j) = -rgrav * tau_ogw(j) - tau_tofd(J) = -rgrav * tau_tofd(j) - ENDDO - - RETURN - - -!============ debug ------------------------------------------------ - if (kdt <= 2 .and. me == 0 .and. debugprint) then - print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw_axoro' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw_ayoro' -! print *, maxval(kdis), minval(kdis), 'vgw_kdispro m2/sec' - print *, maxval(pdTdt)*86400., minval(pdTdt)*86400,'vgw_epsoro' - print *, maxval(zmtb), ' z_mtb ', maxval(tau_mtb), ' tau_mtb ' - print *, maxval(zogw), ' z_ogw ', maxval(tau_ogw), ' tau_ogw ' -! print *, maxval(tau_tofd), ' tau_tofd ' -! print *, maxval(axtms)*86400., minval(axtms)*86400, 'vgw_axtms' -! print *,maxval(dudt_mtb)*86400.,minval(dudt_mtb)*86400,'vgw_axmtb' - if (maxval(abs(pdudt))*86400. > 100.) then - - print *, maxval(u1), minval(u1), ' u1 gwdps-v0 ' - print *, maxval(v1), minval(v1), ' v1 gwdps-v0 ' - print *, maxval(t1), minval(t1), ' t1 gwdps-v0 ' - print *, maxval(q1), minval(q1), ' q1 gwdps-v0 ' - print *, maxval(del), minval(del), ' del gwdps-v0 ' - print *, maxval(phil)*rgrav,minval(phil)*rgrav, 'zmet' - print *, maxval(phii)*rgrav,minval(phii)*rgrav, 'zmeti' - print *, maxval(prsi), minval(prsi), ' prsi ' - print *, maxval(prsL), minval(prsL), ' prsL ' - print *, maxval(RO), minval(RO), ' RO-dens ' - print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' BNV2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' - print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' - print * - do i =1, npt - j= ipt(i) - print *,zogw(J)/hprime(j), zmtb(j)/hprime(j), - & phil(j,1)/9.81, nint(hprime(j)/sigma(j)) -! -!.................................................................... -! -! zogw/hp=5.9 zblk/hp=10.7 zm=11.1m ridge/2=2,489m/9,000m -! from 5 to 20 km , we need to count for "ridges" > dx/4 ~ 15 km -! we must exclude blocking by small ridges -! VAY-kref < iblk zogw-lev 15 block-level: 39 -! -! velmin => 1.0, 0.01, 0.1 etc.....unification of wind limiters -! MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) -! MAX(DW2,DW2MIN) * RDZ * RDZ -! ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) -! TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.1) -! TEMV = 1.0 / max(VELCO(I,K), 0.01) -! & * max(VELCO(I,K),0.01) -!.................................................................... - enddo - print * - stop - endif - endif - -! - RETURN -!--------------------------------------------------------------- -! review of OLD-GFS code 2017/18 most substantial changes -! a) kref > idxzb if idxzb > KPBL "OK" clipped-hill for OGW -! b) tofd -sgh30 "OK" -! -! c) FR < Frc linear theory for taub-specification -! -! d) solver of Palmer et al. (1987) => Linsat of McFarlane -! -!--------------------------------------------------------------- - end subroutine gwdps_v0 - - - -!=============================================================================== -! use fv3gfs-v0 -! first beta version of ugwp for fv3gfs-128 -! cires/swpc - jan 2018 -! non-tested wam ugwp-solvers in fv3gfs: "lsatdis", "dspdis", "ado99dis" -! they reqiure extra-work to put them in with intializtion and namelists -! next will be lsatdis for both fv3wam & fv3gfs-128l implementations -! with (a) stochastic-deterministic propagation solvers for wave packets/spectra -! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) -! (c) guidance from high-res runs for GW sources and res-aware tune-ups -!23456 -! -! call gwdrag_wam(1, im, ix, km, ksrc, dtp, -! & xlat, gw_dudt, gw_dvdt, taux, tauy) -! call fv3_ugwp_wms17(kid1, im, ix, km, ksrc_ifs, dtp, -! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, -! & taux,tauy,grav, amol_i, me, lstep_first ) -! -! -!23456============================================================================== - - - subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, - & tm1 , um1, vm1, qm1, - & prsl, prsi, philg, xlatd, sinlat, coslat, - & pdudt, pdvdt, pdtdt, dked, tau_ngw, - & mpi_id, master, kdt) -! - - -!======================================================= -! -! nov 2015 alternative gw-solver for nggps-wam -! nov 2017 nh/rotational gw-modes for nh-fv3gfs -! --------------------------------------------------------------------------------- -! - - use ugwp_common , only : rgrav, grav, cpd, rd, rv - &, omega2, rcpd2, pi, pi2, fv - &, rad_to_deg, deg_to_rad - &, rdi, gor, grcp, gocp - &, bnv2min, dw2min, velmin, gr2 -! - use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec - &, v_kxw, v_kxw2, tamp_mpa, zfluxglob - &, maxdudt, gw_eff, dked_min - &, nslope, ilaunch, zmsi - &, zci, zdci, zci4, zci3, zci2 - &, zaz_fct, zcosang, zsinang - &, nwav, nazd, zcimin, zcimax - - use sso_coorde, only : debugprint -! - implicit none -!23456 - - integer, intent(in) :: klev ! vertical level - integer, intent(in) :: klon ! horiz tiles - - real, intent(in) :: dtime ! model time step - real, intent(in) :: vm1(klon,klev) ! meridional wind - real, intent(in) :: um1(klon,klev) ! zonal wind - real, intent(in) :: qm1(klon,klev) ! spec. humidity - real, intent(in) :: tm1(klon,klev) ! kin temperature - - real, intent(in) :: prsl(klon,klev) ! mid-layer pressure - real, intent(in) :: philg(klon,klev) ! m2/s2-phil => meters !!!!! phil =philg/grav - real, intent(in) :: prsi(klon,klev+1)! prsi interface pressure - real, intent(in) :: xlatd(klon) ! lat was in radians, now with xlat_d in degrees - real, intent(in) :: sinlat(klon) - real, intent(in) :: coslat(klon) - real, intent(in) :: tau_ngw(klon) - - integer, intent(in) :: mpi_id, master, kdt -! -! -! out-gw effects -! - real, intent(out) :: pdudt(klon,klev) ! zonal momentum tendency - real, intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency - real, intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp - real, intent(out) :: dked(klon,klev) ! gw-eddy diffusion - real, parameter :: minvel = 0.5 ! - real, parameter :: epsln = 1.0d-12 ! - -!vay-2018 - - real :: taux(klon,klev+1) ! EW component of vertical momentum flux (pa) - real :: tauy(klon,klev+1) ! NS component of vertical momentum flux (pa) - real :: phil(klon,klev) ! gphil/grav -! -! local =============================================================================================== -! - -! real :: zthm1(klon,klev) ! temperature interface levels - real :: zthm1 ! 1.0 / temperature interface levels - real :: zbvfhm1(klon,ilaunch:klev) ! interface BV-frequency - real :: zbn2(klon,ilaunch:klev) ! interface BV-frequency - real :: zrhohm1(klon,ilaunch:klev) ! interface density - real :: zuhm1(klon,ilaunch:klev) ! interface zonal wind - real :: zvhm1(klon,ilaunch:klev) ! meridional wind - real :: v_zmet(klon,ilaunch:klev) - real :: vueff(klon,ilaunch:klev) - real :: zbvfl(klon) ! BV at launch level - real :: c2f2(klon) - -!23456 - real :: zul(klon,nazd) ! velocity in azimuthal direction at launch level - real :: zci_min(klon,nazd) -! real :: zcrt(klon,klev,nazd) ! not used - do we need it? Moorthi - real :: zact(klon, nwav, nazd) ! if =1 then critical level encountered => c-u -! real :: zacc(klon, nwav, nazd) ! not used! -! - real :: zpu(klon,klev, nazd) ! momentum flux -! real :: zdfl(klon,klev, nazd) - real :: zfct(klon,klev) - real :: zfnorm(klon) ! normalisation factor - - real :: zfluxlaun(klon) - real :: zui(klon, klev,nazd) -! - real :: zdfdz_v(klon,klev, nazd) ! axj = -df*rho/dz directional momentum depositiom - real :: zflux(klon, nwav, nazd) ! momentum flux at each level stored as ( ix, mode, iazdim) - - real :: zflux_z (klon, nwav,klev) !momentum flux at each azimuth stored as ( ix, mode, klev) -! - real :: vm_zflx_mode, vc_zflx_mode - real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2 - -! real :: zang, znorm, zang1, ztx - real :: zu, zcin, zcpeak, zcin4, zbvfl4 - real :: zcin2, zbvfl2, zcin3, zbvfl3, zcinc - real :: zatmp, zfluxs, zdep, zfluxsq, zulm, zdft, ze1, ze2 - -! - real :: zdelp,zrgpts - real :: zthstd,zrhostd,zbvfstd - real :: tvc1, tvm1, tem1, tem2, tem3 - real :: zhook_handle - real :: delpi(klon,ilaunch:klev) - - -! real :: rcpd, grav2cpd - real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g - &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp - &, cpdi = 1.0d0/cpd - - real :: expdis, fdis -! real :: fmode, expdis, fdis - real :: v_kzi, v_kzw, v_cdp, v_wdp, sc, tx1 - - integer :: j, k, inc, jk, jl, iazi -! -!-------------------------------------------------------------------------- -! - do k=1,klev - do j=1,klon - pdvdt(j,k) = 0.0 - pdudt(j,k) = 0.0 - pdtdt(j,k) = 0.0 - dked(j,k) = 0.0 - phil(j,k) = philg(j,k) * rgrav - enddo - enddo -!----------------------------------------------------------- -! also other options to alter tropical values -! tamp = 100.e-3*1.e3 = 100 mpa -! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 -!----------------------------------------------------------- -! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) - - -! phil = philg*rgrav - -! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] -! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp - - if (kdt ==1 .and. mpi_id == master .and. debugprint) then - print *, maxval(tm1), minval(tm1), 'vgw: temp-res ' - print *, 'ugwp-v0: zcimin=' , zcimin - print *, 'ugwp-v0: zcimax=' , zcimax - print * - endif -! -!================================================= - do iazi=1, nazd - do jk=1,klev - do jl=1,klon - zpu(jl,jk,iazi) = 0.0 -! zcrt(jl,jk,iazi) = 0.0 -! zdfl(jl,jk,iazi) = 0.0 - enddo - enddo - enddo - -! -! set initial min Cxi for critical level absorption - do iazi=1,nazd - do jl=1,klon - zci_min(jl,iazi) = zcimin - enddo - enddo -! define half model level winds and temperature -! --------------------------------------------- - do jk=max(ilaunch,2),klev - do jl=1,klon - tvc1 = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) - tvm1 = tm1(jl,jk-1) * (1. +fv*qm1(jl,jk-1)) -! zthm1(jl,jk) = 0.5 *(tvc1+tvm1) - zthm1 = 2.0 / (tvc1+tvm1) - zuhm1(jl,jk) = 0.5 *(um1(jl,jk-1)+um1(jl,jk)) - zvhm1(jl,jk) = 0.5 *(vm1(jl,jk-1)+vm1(jl,jk)) -! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) - zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) - zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters - v_zmet(jl,jk) = zdelp + zdelp - delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) - vueff(jl,jk) = - & 2.e-5*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min -! -! zbn2(jl,jk) = grav2cpd/zthm1(jl,jk) - zbn2(jl,jk) = grav2cpd*zthm1 - & * (1.0+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) - zbn2(jl,jk) = max(min(zbn2(jl,jk), gssec), bv2min) - zbvfhm1(jl,jk) = sqrt(zbn2(jl,jk)) ! bn = sqrt(bn2) - enddo - enddo - - if (ilaunch == 1) then - jk = 1 - do jl=1,klon -! zthm1(jl,jk) = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) ! not used - zuhm1(jl,jk) = um1(jl,jk) - zvhm1(jl,jk) = vm1(jl,jk) - ZBVFHM1(JL,1) = ZBVFHM1(JL,2) - V_ZMET(JL,1) = V_ZMET(JL,2) - VUEFF(JL,1) = DKED_MIN - ZBN2(JL,1) = ZBN2(JL,2) - enddo - endif - do jl=1,klon - tx1 = OMEGA2 * SINLAT(JL) / V_KXW - C2F2(JL) = tx1 * tx1 - zbvfl(jl) = zbvfhm1(jl,ilaunch) - enddo -! -! define intrinsic velocity (relative to launch level velocity) u(z)-u(zo), and coefficinets -! ------------------------------------------------------------------------------------------ - do iazi=1, nazd - do jl=1,klon - zul(jl,iazi) = zcosang(iazi) * zuhm1(jl,ilaunch) - & + zsinang(iazi) * zvhm1(jl,ilaunch) - enddo - enddo -! - do jk=ilaunch, klev-1 ! from z-launch up model level from which gw spectrum is launched - do iazi=1, nazd - do jl=1,klon - zu = zcosang(iazi)*zuhm1(jl,jk) - & + zsinang(iazi)*zvhm1(jl,jk) - zui(jl,jk,iazi) = zu - zul(jl,iazi) - enddo - enddo - - enddo -! define rho(zo)/n(zo) -! ------------------- - do jk=ilaunch, klev-1 - do jl=1,klon - zfct(jl,jk) = zrhohm1(jl,jk) / zbvfhm1(jl,jk) - enddo - enddo - -! ----------------------------------------- -! set launch momentum flux spectral density -! ----------------------------------------- - - if(nslope == 1) then ! s=1 case - ! -------- - do inc=1,nwav - zcin = zci(inc) - zcin4 = zci4(inc) - do jl=1,klon -!n4 - zbvfl4 = zbvfl(jl) * zbvfl(jl) - zbvfl4 = zbvfl4 * zbvfl4 - zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl4*zcin - & / (zbvfl4+zcin4) - enddo - enddo - elseif(nslope == 2) then ! s=2 case - ! -------- - do inc=1, nwav - zcin = zci(inc) - zcin4 = zci4(inc) - do jl=1,klon - zbvfl4 = zbvfl(jl) * zbvfl(jl) - zbvfl4 = zbvfl4 * zbvfl4 - zcpeak = zbvfl(jl) * zmsi - zflux(jl,inc,1) = zfct(jl,ilaunch)* - & zbvfl4*zcin*zcpeak/(zbvfl4*zcpeak+zcin4*zcin) - enddo - enddo - elseif(nslope == -1) then ! s=-1 case - ! -------- - do inc=1,nwav - zcin = zci(inc) - zcin2 = zci2(inc) - do jl=1,klon - zbvfl2 = zbvfl(jl)*zbvfl(jl) - zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl2*zcin - & / (zbvfl2+zcin2) - enddo - enddo - elseif(nslope == 0) then ! s=0 case - ! -------- - - do inc=1, nwav - zcin = zci(inc) - zcin3 = zci3(inc) - do jl=1,klon - zbvfl3 = zbvfl(jl)**3 - zflux(jl,inc,1) = zfct(jl,ilaunch)*zbvfl3*zcin - & / (zbvfl3+zcin3) - enddo - enddo - - endif ! for slopes -! -! normalize momentum flux at the src-level -! ------------------------------ -! integrate (zflux x dx) - do inc=1, nwav - zcinc = zdci(inc) - do jl=1,klon - zpu(jl,ilaunch,1) = zpu(jl,ilaunch,1) + zflux(jl,inc,1)*zcinc - enddo - enddo -! -! normalize and include lat-dep (precip or merra-2) -! ----------------------------------------------------------- -! also other options to alter tropical values -! - do jl=1,klon - zfluxlaun(jl) = tau_ngw(jl) !*(.5+.75*coslat(JL)) !zfluxglob/2 on poles - zfnorm(jl) = zfluxlaun(jl) / zpu(jl,ilaunch,1) - enddo -! - do iazi=1,nazd - do jl=1,klon - zpu(jl,ilaunch,iazi) = zfluxlaun(jl) - enddo - enddo - -! adjust constant zfct - - do jk=ilaunch, klev-1 - do jl=1,klon - zfct(jl,jk) = zfnorm(jl)*zfct(jl,jk) - enddo - enddo -! renormalize each spectral mode - - do inc=1, nwav - do jl=1,klon - zflux(jl,inc,1) = zfnorm(jl)*zflux(jl,inc,1) - enddo - enddo - -! copy zflux into all other azimuths -! -------------------------------- -! zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 - zact(:,:,:) = 1.0 - do iazi=2, nazd - do inc=1,nwav - do jl=1,klon - zflux(jl,inc,iazi) = zflux(jl,inc,1) - enddo - enddo - enddo - -! ------------------------------------------------------------- -! azimuth do-loop -! -------------------- - do iazi=1, nazd - -! write(0,*)' iazi=',iazi,' ilaunch=',ilaunch -! vertical do-loop -! ---------------- - do jk=ilaunch, klev-1 -! first check for critical levels -! ------------------------ - do jl=1,klon - zci_min(jl,iazi) = max(zci_min(jl,iazi),zui(jl,jk,iazi)) - enddo -! set zact to zero if critical level encountered -! ---------------------------------------------- - do inc=1, nwav -! zcin = zci(inc) - do jl=1,klon -! zatmp = minvel + sign(minvel,zcin-zci_min(jl,iazi)) -! zacc(jl,inc,iazi) = zact(jl,inc,iazi)-zatmp -! zact(jl,inc,iazi) = zatmp - zact(jl,inc,iazi) = minvel - & + sign(minvel,zci(inc)-zci_min(jl,iazi)) - enddo - enddo -! -! zdfl not used! - do we need it? Moorthi -! integrate to get critical-level contribution to mom deposition -! --------------------------------------------------------------- -! do inc=1, nwav -! zcinc = zdci(inc) -! do jl=1,klon -! zdfl(jl,jk,iazi) = zdfl(jl,jk,iazi) + -! & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zcinc -! enddo -! enddo -! -------------------------------------------- -! get weighted average of phase speed in layer zcrt is not used - do we need it? Moorthi -! -------------------------------------------- -! do jl=1,klon -! write(0,*)' jk=',jk,' jl=',jl,' iazi=',iazi, zdfl(jl,jk,iazi) -! if(zdfl(jl,jk,iazi) > epsln ) then -! zatmp = zcrt(jl,jk,iazi) -! do inc=1, nwav -! zatmp = zatmp + zci(inc) * -! & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zdci(inc) -! enddo -! -! zcrt(jl,jk,iazi) = zatmp / zdfl(jl,jk,iazi) -! else -! zcrt(jl,jk,iazi) = zcrt(jl,jk-1,iazi) -! endif -! enddo - -! - do inc=1, nwav - zcin = zci(inc) - if (abs(zcin) > epsln) then - zcinc = 1.0 / zcin - else - zcinc = 1.0 - endif - do jl=1,klon -!======================================================================= -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= - v_cdp = abs(zcin-zui(jL,jk,iazi)) - v_wdp = v_kxw*v_cdp - wdop2 = v_wdp* v_wdp - cdf2 = v_cdp*v_cdp - c2f2(jL) - if (cdf2 > 0) then - kzw2 = (zBn2(jL,jk)-wdop2)/Cdf2 - v_kxw2 - else - kzw2 = 0.0 - endif - if ( kzw2 > 0 ) then - v_kzw = sqrt(kzw2) -! -!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (zBn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NiGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) -! Kds = kxw*Cdf1*rhp2/kzw3 -! - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_kzi = abs(v_kzw*v_kzw*vueff(jl,jk)/v_wdp*v_kzw) - expdis = exp(-v_kzi*v_zmet(jl,jk)) - else - v_kzi = 0. - expdis = 1.0 - v_kzw = 0. - v_cdp = 0. ! no effects of reflected waves - endif - -! fmode = zflux(jl,inc,iazi) -! fdis = fmode*expdis - fdis = expdis * zflux(jl,inc,iazi) -! -! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 -! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] -! - zfluxs = zfct(jl,jk)*v_cdp*v_cdp*zcinc -! -! zfluxs= zfct(jl,jk)*(zcin-zui(jl,jk,iazi))**2/zcin -! flux_tot - sat.flux -! - zdep = zact(jl,inc,iazi)* (fdis-zfluxs) - if(zdep > 0.0 ) then -! subs on sat-limit - zflux(jl,inc,iazi) = zfluxs - zflux_z(jl,inc,jk) = zfluxs - else -! assign dis-ve flux - zflux(jl,inc,iazi) = fdis - zflux_z(jl,inc,jk) = fdis - endif - enddo - enddo -! -! integrate over spectral modes zpu(y, z, azimuth) zact(jl,inc,iazi)*zflux(jl,inc,iazi)*[d("zcinc")] -! - zdfdz_v(:,jk,iazi) = 0.0 - - do inc=1, nwav - zcinc = zdci(inc) ! dc-integration - do jl=1,klon - vc_zflx_mode = zact(jl,inc,iazi)*zflux(jl,inc,iazi) - zpu(jl,jk,iazi) = zpu(jl,jk,iazi) + vc_zflx_mode*zcinc - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! check monotonic decrease -! (heat deposition integration over spectral mode for each azimuth -! later sum over selected azimuths as "non-negative" scalars) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (jk > ilaunch)then -! zdelp = grav/(prsi(jl,jk-1)-prsi(jl,jk))* -! & abs(zcin-zui(jl,jk,iazi)) *zcinc - zdelp = delpi(jl,jk) * abs(zcin-zui(jl,jk,iazi)) *zcinc - vm_zflx_mode = zact(jl,inc,iazi)* zflux_z(jl,inc,jk-1) - - if (vc_zflx_mode > vm_zflx_mode) - & vc_zflx_mode = vm_zflx_mode ! no-flux increase - zdfdz_v( jl,jk,iazi) = zdfdz_v( jl,jk,iazi) + - & (vm_zflx_mode-vc_zflx_mode)*zdelp ! heating >0 -! -! - endif - enddo !jl=1,klon - enddo !waves inc=1,nwav - -! -------------- - enddo ! end jk do-loop vertical loop -! --------------- - enddo ! end nazd do-loop -! ---------------------------------------------------------------------------- -! sum contribution for total zonal and meridional flux + -! energy dissipation -! --------------------------------------------------- -! - do jk=1,klev+1 - do jl=1,klon - taux(jl,jk) = 0.0 - tauy(jl,jk) = 0.0 - enddo - enddo - - tem3 = zaz_fct*cpdi - do iazi=1,nazd - tem1 = zaz_fct*zcosang(iazi) - tem2 = zaz_fct*zsinang(iazi) - do jk=ilaunch, klev-1 - do jl=1,klon - taux(jl,jk) = taux(jl,jk) + tem1 * zpu(jl,jk,iazi) ! zaz_fct - "azimuth"-norm-n - tauy(jl,jk) = tauy(jl,jk) + tem2 * zpu(jl,jk,iazi) - pdtdt(jl,jk) = pdtdt(jl,jk) + tem3 * zdfdz_v(jl,jk,iazi) ! eps_dis =sum( +d(flux_e)/dz) > 0. - enddo - enddo - - enddo -! -! update du/dt and dv/dt tendencies ..... no contribution to heating => keddy/tracer-mom-heat -! ---------------------------- -! - - do jk=ilaunch,klev - do jl=1, klon -! zdelp = grav / (prsi(jl,jk-1)-prsi(jl,jk)) - zdelp = delpi(jl,jk) - ze1 = (taux(jl,jk)-taux(jl,jk-1))*zdelp - ze2 = (tauy(jl,jk)-tauy(jl,jk-1))*zdelp - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - pdudt(jl,jk) = -ze1 - pdvdt(jl,jk) = -ze2 -! -! Cx =0 based Cx=/= 0. above -! - pdtdt(jl,jk) = (ze1*um1(jl,jk) + ze2*vm1(jl,jk)) * cpdi -! - dked(jl,jk) = max(dked_min, pdtdt(jl,jk)/zbn2(jl,jk)) -! if (dked(jl,jk) < 0) dked(jl,jk) = dked_min - enddo - enddo -! -! add limiters/efficiency for "unbalanced ics" if it is needed -! - do jk=ilaunch,klev - do jl=1, klon - pdudt(jl,jk) = gw_eff * pdudt(jl,jk) - pdvdt(jl,jk) = gw_eff * pdvdt(jl,jk) - pdtdt(jl,jk) = gw_eff * pdtdt(jl,jk) - dked(jl,jk) = gw_eff * dked(jl,jk) - enddo - enddo -! -!--------------------------------------------------------------------------- -! - if (kdt == 1 .and. mpi_id == master .and. debugprint) then - print *, 'vgw done ' -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps' -! -! print *, ' ugwp -heating rates ' - endif - - return - end subroutine fv3_ugwp_solv2_v0 -!------------------------------------------------------------------------------- -! -! Part-3 of UGWP-V01 Dissipative (eddy) effects of UGWP it will be activated -! after tests of OGW (new revision) and NGW with MERRA-2 forcing. -! -!------------------------------------------------------------------------------- - subroutine edmix_ugwp_v0(im, levs, dtp, - & t1, u1, v1, q1, del, - & prsl, prsi, phil, prslk, - & pdudt, pdvdt, pdTdt, pkdis, - & ed_dudt, ed_dvdt, ed_dTdt, - & me, master, kdt ) -! - use machine, only : kind_phys - use ugwp_common , only : rgrav, grav, cpd, rd, rdi, fv -! &, pi, rad_to_deg, deg_to_rad, pi2 - &, bnv2min, velmin, arad - - implicit none - - integer, intent(in) :: me, master, kdt - integer, intent(in) :: im, levs - real(kind=kind_phys), intent(in) :: dtp - real(kind=kind_phys), intent(in), dimension(im,levs) :: - & u1, v1, t1, q1, del, prsl, prslk, phil -! - real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi - real(kind=kind_phys),dimension(im,levs) :: pdudt, pdvdt, pdTdt - real(kind=kind_phys),dimension(im,levs) :: pkdis -! -! out -! - real(kind=kind_phys),dimension(im,levs) :: ed_dudt, ed_dvdt - real(kind=kind_phys),dimension(im,levs) :: ed_dTdt -! -! locals -! - integer :: i, j, k -!------------------------------------------------------------------------ -! solving 1D-vertical eddy diffusion to "smooth" -! GW-related tendencies: du/dt, dv/dt, d(PT)/dt -! we need to use sum of molecular + eddy terms including turb-part -! of PBL extended to the model top, because "phys-tend" dx/dt -! should be smoothed as "entire" fields therefore one should -! first estimate and collect "effective" diffusion and applied -! it to each part of tendency or "sum of tendencies + Xdyn" -! this "diffusive-way" is tested with UGWP-tendencies -! forced by various wave sources. X' =dx/dt *dt -! d(X + X')/dt = K*diff(X + X') => -! -! wave1 dX'/dt = Kw * diff(X')... eddy part "Kwave" on wave-part -! turb2 dX/dt = Kturb * diff(X) ... resolved scale mixing "Kturb" like PBL -! we may assume "zero-GW"-tendency at the top lid and "zero" flux -! or "vertical gradient" near the surface -! -! 1-st trial w/o PBL interactions: add dU, dV dT tendencies -! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " -! ed_X = X_ed - X => final eddy tendencies -!--------------------------------------------------------------------------- -! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) -! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp -! - real(kind=kind_phys) :: Sw(levs), Sw1(levs), Fw(levs), Fw1(levs) - real(kind=kind_phys) :: Km(levs), Kpt(levs), Pt(levs), Ptmap(levs) - real(kind=kind_phys) :: rho(levs), rdp(levs), rdpm(levs-1) - real(kind=kind_phys),dimension(levs) :: ktur, vumol, up, vp, tp - real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum - real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis - real(kind=kind_phys) :: rdz , uz, vz, ptz -! ------------------------------------------------------------------------- -! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt -! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) -! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit -! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 -! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 -! - real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 - real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb - real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb - real(kind=kind_phys), parameter :: ric =0.25 - real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 - real(kind=kind_phys), parameter :: prmax = 4.0 - real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps - real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. - - - real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur - integer :: nstab - real(kind=kind_phys) :: w1, w2, w3 - rdtp = 1./dtp - nstab = 1 - stab_dt = 0.9999 - - do i =1, im - - rdp(1:levs) = grav/del(i, 1:levs) - - up(1:levs) = u1(i,1:levs) +pdudt(i,1:levs)*dtp - vp(1:levs) = v1(i,1:levs) +pdvdt(i,1:levs)*dtp - tp(1:levs) = t1(i,1:levs) +pdTdt(i,1:levs)*dtp - Ptmap(1:levs) = (1.+fv*q1(i,1:levs))/prslk(i,1:levs) - rho(1:levs) = rdi*prsl(i, 1:levs)/tp(1:levs) - Pt(1:levs) = tp(1:levs)*Ptmap(1:levs) - - do k=1, levs-1 - rdpm(k) = grav/(prsl(i,k)-prsl(i,k+1)) - rdz = .5*rdpm(k)*(rho(k)+rho(k+1)) - uz = up(k+1)-up(k) - vz = vp(k+1)-vp(k) - ptz =2.*(pt(k+1)-pt(k))/(pt(k+1)+pt(k)) - shr2(k) = rdz*rdz*(max(uz*uz+vz*vz, dw2min)) - bn2(k) = grav*rdz*ptz - zmet = phil(j,k)*rgrav - zgrow = exp(zmet*h4) - if ( bn2(k) < 0. ) then -! -! adjust PT-profile to bn2(k) = bnv2min -- neutral atmosphere -! adapt "pdtdt = (Ptadj-Ptdyn)/Ptmap" -! -! print *,' UGWP-V0 unstab PT(z) via gwdTdt ', bn2(k), k - - rineg = bn2(k)/shr2(k) - bn2(k) = max(bn2(k), bnv2min) - kamp = sqrt(shr2(k))*sc2u *zgrow - ktur(k) =kamp* (1+8.*(-rineg)/(1+1.746*sqrt(-rineg))) - endif - ritur = max(bn2(k)/shr2(k), rimin) - if (ritur > 0. ) then - kamp = sqrt(shr2(k))*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur(k)= kamp * w1 * w1 - endif - vumol(k) = 2.e-5 *exp(zmet/hps) - ksum(k) =ktur(k)+Pkdis(i,k)+vumol(k) - ksum(k) = max(ksum(k), kedmin) - ksum(k) = min(ksum(k), kedmax) - stab = 2.*ksum(k)*rdz*rdz*dtp - if ( stab >= 1.0 ) then - stab_dt = max(stab_dt, stab) - endif - enddo - nstab = max(1, nint(stab_dt)+1) - dtstab = dtp / float(nstab) - ksum(levs) = ksum(levs-1) - Fw(1:levs) = pdudt(i, 1:levs) - Fw1(1:levs) = pdvdt(i, 1:levs) - Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) - - do j=1, nstab - call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, - & rdp, rdpm, Sw, Sw1) - Fw = Sw - Fw1 = Sw1 - enddo - - ed_dudt(i,:) = Sw - ed_dvdt(i,:) = Sw1 - - Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) - Kpt = Km*iPr_pt - Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) - do j=1, nstab - call diff_1d_ptend(levs, dtstab, Fw, Kpt, rdp, rdpm, Sw) - Fw = Sw - enddo - ed_dtdt(i,1:levs) = Sw(1:levs)/Ptmap(1:levs) - - enddo - - end subroutine edmix_ugwp_v0 - - subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! S(:) = 0.0 ; S1(:) = 0.0 -! -! explicit diffusion solver -! - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. - cd - ad -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - S1(K) = F1(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) - enddo - k = levs - S(k) = F(k) - S1(k) = F1(k) - end subroutine diff_1d_wtend - - subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) - use machine, only: kind_phys - implicit none - integer :: levs - real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) - real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) - integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd -! -! explicit "eddy" smoother for tendencies -! - - k = 1 -! km1 = 0. ; ad =0. - ad =0. - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(1)*rdpm(1)*kp1*dt - bd = 1. -(cd +ad) -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S(K) = F(k) - do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - enddo - k = levs - S(k) = F(k) - end subroutine diff_1d_ptend diff --git a/gfsphysics/physics/wam_f107_kp_mod.f90 b/gfsphysics/physics/wam_f107_kp_mod.f90 deleted file mode 100644 index 23355cca2..000000000 --- a/gfsphysics/physics/wam_f107_kp_mod.f90 +++ /dev/null @@ -1,75 +0,0 @@ - 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/gfsphysics/physics/wv_saturation.F b/gfsphysics/physics/wv_saturation.F deleted file mode 100644 index 55d9c55a3..000000000 --- a/gfsphysics/physics/wv_saturation.F +++ /dev/null @@ -1,1574 +0,0 @@ -! -! 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/io/CMakeLists.txt b/io/CMakeLists.txt index 4cbaeb678..88dab6c09 100644 --- a/io/CMakeLists.txt +++ b/io/CMakeLists.txt @@ -11,9 +11,7 @@ if(NOT PARALLEL_NETCDF) list(APPEND _io_defs_private NO_PARALLEL_NETCDF) endif() -if(CCPP) - list(APPEND _io_defs_private CCPP) -endif() +list(APPEND _io_defs_private CCPP) add_library( io @@ -35,16 +33,15 @@ target_include_directories(io PUBLIC $ IPD_kind_phys + use GFS_typedefs, only: GFS_sfcprop_type, GFS_control_type, & + GFS_data_type, kind_phys + use GFS_restart, only: GFS_restart_type + use GFS_diagnostics, only: GFS_externaldiag_type + ! !----------------------------------------------------------------------- implicit none @@ -63,7 +53,7 @@ module FV3GFS_io_mod !--- public interfaces --- public FV3GFS_restart_read, FV3GFS_restart_write - public FV3GFS_IPD_checksum + public FV3GFS_GFS_checksum public fv3gfs_diag_register, fv3gfs_diag_output #ifdef use_WRTCOMP public fv_phys_bundle_setup @@ -128,59 +118,49 @@ module FV3GFS_io_mod !-------------------- ! FV3GFS_restart_read !-------------------- -#ifdef CCPP - subroutine FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, Model, fv_domain, warm_start) -#else - subroutine FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, Model, fv_domain) -#endif - type(IPD_data_type), intent(inout) :: IPD_Data(:) - type(IPD_restart_type), intent(inout) :: IPD_Restart + subroutine FV3GFS_restart_read (GFS_Data, GFS_Restart, Atm_block, Model, fv_domain, warm_start) + type(GFS_data_type), intent(inout) :: GFS_Data(:) + type(GFS_restart_type), intent(inout) :: GFS_Restart type(block_control_type), intent(in) :: Atm_block - type(IPD_control_type), intent(inout) :: Model + type(GFS_control_type), intent(inout) :: Model type(domain2d), intent(in) :: fv_domain -#ifdef CCPP logical, intent(in) :: warm_start -#endif !--- read in surface data from chgres -#ifdef CCPP - call sfc_prop_restart_read (IPD_Data%Sfcprop, Atm_block, Model, fv_domain, warm_start) -#else - call sfc_prop_restart_read (IPD_Data%Sfcprop, Atm_block, Model, fv_domain) -#endif + call sfc_prop_restart_read (GFS_Data%Sfcprop, Atm_block, Model, fv_domain, warm_start) !--- read in physics restart data - call phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) + call phys_restart_read (GFS_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 + subroutine FV3GFS_restart_write (GFS_Data, GFS_Restart, Atm_block, Model, fv_domain, timestamp) + type(GFS_data_type), intent(inout) :: GFS_Data(:) + type(GFS_restart_type), intent(inout) :: GFS_Restart type(block_control_type), intent(in) :: Atm_block - type(IPD_control_type), intent(in) :: Model + type(GFS_control_type), intent(in) :: Model type(domain2d), intent(in) :: fv_domain character(len=32), optional, intent(in) :: timestamp !--- write surface data from chgres - call sfc_prop_restart_write (IPD_Data%Sfcprop, Atm_block, Model, fv_domain, timestamp) + call sfc_prop_restart_write (GFS_Data%Sfcprop, Atm_block, Model, fv_domain, timestamp) !--- write physics restart data - call phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timestamp) + call phys_restart_write (GFS_Restart, Atm_block, Model, fv_domain, timestamp) end subroutine FV3GFS_restart_write !-------------------- -! FV3GFS_IPD_checksum +! FV3GFS_GFS_checksum !-------------------- - subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) + subroutine FV3GFS_GFS_checksum (Model, GFS_Data, Atm_block) !--- interface variables - type(IPD_control_type), intent(in) :: Model - type(IPD_data_type), intent(in) :: IPD_Data(:) + type(GFS_control_type), intent(in) :: Model + type(GFS_data_type), intent(in) :: GFS_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 @@ -196,7 +176,7 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) jec = Model%jsc+Model%ny-1 lev = Model%levs - ntr = size(IPD_Data(1)%Statein%qgrs,3) + ntr = size(GFS_Data(1)%Statein%qgrs,3) if(Model%lsm == Model%lsm_noahmp) then nsfcprop2d = 151 @@ -217,225 +197,222 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) 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) -#ifdef CCPP - if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4) then -#endif - 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) -#ifdef CCPP - elseif (Model%lsm == Model%lsm_ruc) then - temp2d(i,j,35) = IPD_Data(nb)%Sfcprop%sh2o(ix,1) - temp2d(i,j,36) = IPD_Data(nb)%Sfcprop%sh2o(ix,2) - temp2d(i,j,37) = IPD_Data(nb)%Sfcprop%sh2o(ix,3) - ! Combine levels 4 to lsoil_lsm (9 for RUC) into one - temp2d(i,j,38) = sum(IPD_Data(nb)%Sfcprop%sh2o(ix,4:Model%lsoil_lsm)) - temp2d(i,j,39) = IPD_Data(nb)%Sfcprop%smois(ix,1) - temp2d(i,j,40) = IPD_Data(nb)%Sfcprop%smois(ix,2) - temp2d(i,j,41) = IPD_Data(nb)%Sfcprop%smois(ix,3) - ! Combine levels 4 to lsoil_lsm (9 for RUC) into one - temp2d(i,j,42) = sum(IPD_Data(nb)%Sfcprop%smois(ix,4:Model%lsoil_lsm)) - temp2d(i,j,43) = IPD_Data(nb)%Sfcprop%tslb(ix,1) - temp2d(i,j,44) = IPD_Data(nb)%Sfcprop%tslb(ix,2) - temp2d(i,j,45) = IPD_Data(nb)%Sfcprop%tslb(ix,3) - ! Combine levels 4 to lsoil_lsm (9 for RUC) into one - temp2d(i,j,46) = sum(IPD_Data(nb)%Sfcprop%tslb(ix,4:Model%lsoil_lsm)) - endif ! LSM choice -#endif - 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) + temp2d(i,j, 1) = GFS_Data(nb)%Statein%pgr(ix) + temp2d(i,j, 2) = GFS_Data(nb)%Sfcprop%slmsk(ix) + temp2d(i,j, 3) = GFS_Data(nb)%Sfcprop%tsfc(ix) + temp2d(i,j, 4) = GFS_Data(nb)%Sfcprop%tisfc(ix) + temp2d(i,j, 5) = GFS_Data(nb)%Sfcprop%snowd(ix) + temp2d(i,j, 6) = GFS_Data(nb)%Sfcprop%zorl(ix) + temp2d(i,j, 7) = GFS_Data(nb)%Sfcprop%fice(ix) + temp2d(i,j, 8) = GFS_Data(nb)%Sfcprop%hprime(ix,1) + temp2d(i,j, 9) = GFS_Data(nb)%Sfcprop%sncovr(ix) + temp2d(i,j,10) = GFS_Data(nb)%Sfcprop%snoalb(ix) + temp2d(i,j,11) = GFS_Data(nb)%Sfcprop%alvsf(ix) + temp2d(i,j,12) = GFS_Data(nb)%Sfcprop%alnsf(ix) + temp2d(i,j,13) = GFS_Data(nb)%Sfcprop%alvwf(ix) + temp2d(i,j,14) = GFS_Data(nb)%Sfcprop%alnwf(ix) + temp2d(i,j,15) = GFS_Data(nb)%Sfcprop%facsf(ix) + temp2d(i,j,16) = GFS_Data(nb)%Sfcprop%facwf(ix) + temp2d(i,j,17) = GFS_Data(nb)%Sfcprop%slope(ix) + temp2d(i,j,18) = GFS_Data(nb)%Sfcprop%shdmin(ix) + temp2d(i,j,19) = GFS_Data(nb)%Sfcprop%shdmax(ix) + temp2d(i,j,20) = GFS_Data(nb)%Sfcprop%tg3(ix) + temp2d(i,j,21) = GFS_Data(nb)%Sfcprop%vfrac(ix) + temp2d(i,j,22) = GFS_Data(nb)%Sfcprop%vtype(ix) + temp2d(i,j,23) = GFS_Data(nb)%Sfcprop%stype(ix) + temp2d(i,j,24) = GFS_Data(nb)%Sfcprop%uustar(ix) + temp2d(i,j,25) = GFS_Data(nb)%Sfcprop%oro(ix) + temp2d(i,j,26) = GFS_Data(nb)%Sfcprop%oro_uf(ix) + temp2d(i,j,27) = GFS_Data(nb)%Sfcprop%hice(ix) + temp2d(i,j,28) = GFS_Data(nb)%Sfcprop%weasd(ix) + temp2d(i,j,29) = GFS_Data(nb)%Sfcprop%canopy(ix) + temp2d(i,j,30) = GFS_Data(nb)%Sfcprop%ffmm(ix) + temp2d(i,j,31) = GFS_Data(nb)%Sfcprop%ffhh(ix) + temp2d(i,j,32) = GFS_Data(nb)%Sfcprop%f10m(ix) + temp2d(i,j,33) = GFS_Data(nb)%Sfcprop%tprcp(ix) + temp2d(i,j,34) = GFS_Data(nb)%Sfcprop%srflag(ix) + if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4) then + temp2d(i,j,35) = GFS_Data(nb)%Sfcprop%slc(ix,1) + temp2d(i,j,36) = GFS_Data(nb)%Sfcprop%slc(ix,2) + temp2d(i,j,37) = GFS_Data(nb)%Sfcprop%slc(ix,3) + temp2d(i,j,38) = GFS_Data(nb)%Sfcprop%slc(ix,4) + temp2d(i,j,39) = GFS_Data(nb)%Sfcprop%smc(ix,1) + temp2d(i,j,40) = GFS_Data(nb)%Sfcprop%smc(ix,2) + temp2d(i,j,41) = GFS_Data(nb)%Sfcprop%smc(ix,3) + temp2d(i,j,42) = GFS_Data(nb)%Sfcprop%smc(ix,4) + temp2d(i,j,43) = GFS_Data(nb)%Sfcprop%stc(ix,1) + temp2d(i,j,44) = GFS_Data(nb)%Sfcprop%stc(ix,2) + temp2d(i,j,45) = GFS_Data(nb)%Sfcprop%stc(ix,3) + temp2d(i,j,46) = GFS_Data(nb)%Sfcprop%stc(ix,4) + elseif (Model%lsm == Model%lsm_ruc) then + temp2d(i,j,35) = GFS_Data(nb)%Sfcprop%sh2o(ix,1) + temp2d(i,j,36) = GFS_Data(nb)%Sfcprop%sh2o(ix,2) + temp2d(i,j,37) = GFS_Data(nb)%Sfcprop%sh2o(ix,3) + ! Combine levels 4 to lsoil_lsm (9 for RUC) into one + temp2d(i,j,38) = sum(GFS_Data(nb)%Sfcprop%sh2o(ix,4:Model%lsoil_lsm)) + temp2d(i,j,39) = GFS_Data(nb)%Sfcprop%smois(ix,1) + temp2d(i,j,40) = GFS_Data(nb)%Sfcprop%smois(ix,2) + temp2d(i,j,41) = GFS_Data(nb)%Sfcprop%smois(ix,3) + ! Combine levels 4 to lsoil_lsm (9 for RUC) into one + temp2d(i,j,42) = sum(GFS_Data(nb)%Sfcprop%smois(ix,4:Model%lsoil_lsm)) + temp2d(i,j,43) = GFS_Data(nb)%Sfcprop%tslb(ix,1) + temp2d(i,j,44) = GFS_Data(nb)%Sfcprop%tslb(ix,2) + temp2d(i,j,45) = GFS_Data(nb)%Sfcprop%tslb(ix,3) + ! Combine levels 4 to lsoil_lsm (9 for RUC) into one + temp2d(i,j,46) = sum(GFS_Data(nb)%Sfcprop%tslb(ix,4:Model%lsoil_lsm)) + endif ! LSM choice + + temp2d(i,j,47) = GFS_Data(nb)%Sfcprop%t2m(ix) + temp2d(i,j,48) = GFS_Data(nb)%Sfcprop%q2m(ix) + temp2d(i,j,49) = GFS_Data(nb)%Coupling%nirbmdi(ix) + temp2d(i,j,50) = GFS_Data(nb)%Coupling%nirdfdi(ix) + temp2d(i,j,51) = GFS_Data(nb)%Coupling%visbmdi(ix) + temp2d(i,j,52) = GFS_Data(nb)%Coupling%visdfdi(ix) + temp2d(i,j,53) = GFS_Data(nb)%Coupling%nirbmui(ix) + temp2d(i,j,54) = GFS_Data(nb)%Coupling%nirdfui(ix) + temp2d(i,j,55) = GFS_Data(nb)%Coupling%visbmui(ix) + temp2d(i,j,56) = GFS_Data(nb)%Coupling%visdfui(ix) + temp2d(i,j,57) = GFS_Data(nb)%Coupling%sfcdsw(ix) + temp2d(i,j,58) = GFS_Data(nb)%Coupling%sfcnsw(ix) + temp2d(i,j,59) = GFS_Data(nb)%Coupling%sfcdlw(ix) + temp2d(i,j,60) = GFS_Data(nb)%Grid%xlon(ix) + temp2d(i,j,61) = GFS_Data(nb)%Grid%xlat(ix) + temp2d(i,j,62) = GFS_Data(nb)%Grid%xlat_d(ix) + temp2d(i,j,63) = GFS_Data(nb)%Grid%sinlat(ix) + temp2d(i,j,64) = GFS_Data(nb)%Grid%coslat(ix) + temp2d(i,j,65) = GFS_Data(nb)%Grid%area(ix) + temp2d(i,j,66) = GFS_Data(nb)%Grid%dx(ix) if (Model%ntoz > 0) then - temp2d(i,j,67) = IPD_Data(nb)%Grid%ddy_o3(ix) + temp2d(i,j,67) = GFS_Data(nb)%Grid%ddy_o3(ix) endif if (Model%h2o_phys) then - temp2d(i,j,68) = IPD_Data(nb)%Grid%ddy_h(ix) + temp2d(i,j,68) = GFS_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 - temp2d(i,j,85) = IPD_Data(nb)%Sfcprop%tiice(ix,1) - temp2d(i,j,86) = IPD_Data(nb)%Sfcprop%tiice(ix,2) + temp2d(i,j,69) = GFS_Data(nb)%Cldprop%cv(ix) + temp2d(i,j,70) = GFS_Data(nb)%Cldprop%cvt(ix) + temp2d(i,j,71) = GFS_Data(nb)%Cldprop%cvb(ix) + temp2d(i,j,72) = GFS_Data(nb)%Radtend%sfalb(ix) + temp2d(i,j,73) = GFS_Data(nb)%Radtend%coszen(ix) + temp2d(i,j,74) = GFS_Data(nb)%Radtend%tsflw(ix) + temp2d(i,j,75) = GFS_Data(nb)%Radtend%semis(ix) + temp2d(i,j,76) = GFS_Data(nb)%Radtend%coszdg(ix) + temp2d(i,j,77) = GFS_Data(nb)%Radtend%sfcfsw(ix)%upfxc + temp2d(i,j,78) = GFS_Data(nb)%Radtend%sfcfsw(ix)%upfx0 + temp2d(i,j,79) = GFS_Data(nb)%Radtend%sfcfsw(ix)%dnfxc + temp2d(i,j,80) = GFS_Data(nb)%Radtend%sfcfsw(ix)%dnfx0 + temp2d(i,j,81) = GFS_Data(nb)%Radtend%sfcflw(ix)%upfxc + temp2d(i,j,82) = GFS_Data(nb)%Radtend%sfcflw(ix)%upfx0 + temp2d(i,j,83) = GFS_Data(nb)%Radtend%sfcflw(ix)%dnfxc + temp2d(i,j,84) = GFS_Data(nb)%Radtend%sfcflw(ix)%dnfx0 + temp2d(i,j,85) = GFS_Data(nb)%Sfcprop%tiice(ix,1) + temp2d(i,j,86) = GFS_Data(nb)%Sfcprop%tiice(ix,2) idx_opt = 87 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) = GFS_Data(nb)%Sfcprop%snowxy(ix) + temp2d(i,j,idx_opt+1) = GFS_Data(nb)%Sfcprop%tvxy(ix) + temp2d(i,j,idx_opt+2) = GFS_Data(nb)%Sfcprop%tgxy(ix) + temp2d(i,j,idx_opt+3) = GFS_Data(nb)%Sfcprop%canicexy(ix) + temp2d(i,j,idx_opt+4) = GFS_Data(nb)%Sfcprop%canliqxy(ix) + temp2d(i,j,idx_opt+5) = GFS_Data(nb)%Sfcprop%eahxy(ix) + temp2d(i,j,idx_opt+6) = GFS_Data(nb)%Sfcprop%tahxy(ix) + temp2d(i,j,idx_opt+7) = GFS_Data(nb)%Sfcprop%cmxy(ix) + temp2d(i,j,idx_opt+8) = GFS_Data(nb)%Sfcprop%chxy(ix) + temp2d(i,j,idx_opt+9) = GFS_Data(nb)%Sfcprop%fwetxy(ix) + temp2d(i,j,idx_opt+10) = GFS_Data(nb)%Sfcprop%sneqvoxy(ix) + temp2d(i,j,idx_opt+11) = GFS_Data(nb)%Sfcprop%alboldxy(ix) + temp2d(i,j,idx_opt+12) = GFS_Data(nb)%Sfcprop%qsnowxy(ix) + temp2d(i,j,idx_opt+13) = GFS_Data(nb)%Sfcprop%wslakexy(ix) + temp2d(i,j,idx_opt+14) = GFS_Data(nb)%Sfcprop%zwtxy(ix) + temp2d(i,j,idx_opt+15) = GFS_Data(nb)%Sfcprop%waxy(ix) + temp2d(i,j,idx_opt+16) = GFS_Data(nb)%Sfcprop%wtxy(ix) + temp2d(i,j,idx_opt+17) = GFS_Data(nb)%Sfcprop%lfmassxy(ix) + temp2d(i,j,idx_opt+18) = GFS_Data(nb)%Sfcprop%rtmassxy(ix) + temp2d(i,j,idx_opt+19) = GFS_Data(nb)%Sfcprop%stmassxy(ix) + temp2d(i,j,idx_opt+20) = GFS_Data(nb)%Sfcprop%woodxy(ix) + temp2d(i,j,idx_opt+21) = GFS_Data(nb)%Sfcprop%stblcpxy(ix) + temp2d(i,j,idx_opt+22) = GFS_Data(nb)%Sfcprop%fastcpxy(ix) + temp2d(i,j,idx_opt+23) = GFS_Data(nb)%Sfcprop%xsaixy(ix) + temp2d(i,j,idx_opt+24) = GFS_Data(nb)%Sfcprop%xlaixy(ix) + temp2d(i,j,idx_opt+25) = GFS_Data(nb)%Sfcprop%taussxy(ix) + temp2d(i,j,idx_opt+26) = GFS_Data(nb)%Sfcprop%smcwtdxy(ix) + temp2d(i,j,idx_opt+27) = GFS_Data(nb)%Sfcprop%deeprechxy(ix) + temp2d(i,j,idx_opt+28) = GFS_Data(nb)%Sfcprop%rechxy(ix) + + temp2d(i,j,idx_opt+29) = GFS_Data(nb)%Sfcprop%snicexy(ix,-2) + temp2d(i,j,idx_opt+30) = GFS_Data(nb)%Sfcprop%snicexy(ix,-1) + temp2d(i,j,idx_opt+31) = GFS_Data(nb)%Sfcprop%snicexy(ix,0) + temp2d(i,j,idx_opt+32) = GFS_Data(nb)%Sfcprop%snliqxy(ix,-2) + temp2d(i,j,idx_opt+33) = GFS_Data(nb)%Sfcprop%snliqxy(ix,-1) + temp2d(i,j,idx_opt+34) = GFS_Data(nb)%Sfcprop%snliqxy(ix,0) + temp2d(i,j,idx_opt+35) = GFS_Data(nb)%Sfcprop%tsnoxy(ix,-2) + temp2d(i,j,idx_opt+36) = GFS_Data(nb)%Sfcprop%tsnoxy(ix,-1) + temp2d(i,j,idx_opt+37) = GFS_Data(nb)%Sfcprop%tsnoxy(ix,0) + temp2d(i,j,idx_opt+38) = GFS_Data(nb)%Sfcprop%smoiseq(ix,1) + temp2d(i,j,idx_opt+39) = GFS_Data(nb)%Sfcprop%smoiseq(ix,2) + temp2d(i,j,idx_opt+40) = GFS_Data(nb)%Sfcprop%smoiseq(ix,3) + temp2d(i,j,idx_opt+41) = GFS_Data(nb)%Sfcprop%smoiseq(ix,4) + temp2d(i,j,idx_opt+42) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,-2) + temp2d(i,j,idx_opt+43) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,-1) + temp2d(i,j,idx_opt+44) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,0) + temp2d(i,j,idx_opt+45) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,1) + temp2d(i,j,idx_opt+46) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,2) + temp2d(i,j,idx_opt+47) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,3) + temp2d(i,j,idx_opt+48) = GFS_Data(nb)%Sfcprop%zsnsoxy(ix,4) idx_opt = 136 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) + temp2d(i,j,idx_opt ) = GFS_Data(nb)%Sfcprop%tref(ix) + temp2d(i,j,idx_opt+ 1) = GFS_Data(nb)%Sfcprop%z_c(ix) + temp2d(i,j,idx_opt+ 2) = GFS_Data(nb)%Sfcprop%c_0(ix) + temp2d(i,j,idx_opt+ 3) = GFS_Data(nb)%Sfcprop%c_d(ix) + temp2d(i,j,idx_opt+ 4) = GFS_Data(nb)%Sfcprop%w_0(ix) + temp2d(i,j,idx_opt+ 5) = GFS_Data(nb)%Sfcprop%w_d(ix) + temp2d(i,j,idx_opt+ 6) = GFS_Data(nb)%Sfcprop%xt(ix) + temp2d(i,j,idx_opt+ 7) = GFS_Data(nb)%Sfcprop%xs(ix) + temp2d(i,j,idx_opt+ 8) = GFS_Data(nb)%Sfcprop%xu(ix) + temp2d(i,j,idx_opt+ 9) = GFS_Data(nb)%Sfcprop%xz(ix) + temp2d(i,j,idx_opt+10) = GFS_Data(nb)%Sfcprop%zm(ix) + temp2d(i,j,idx_opt+11) = GFS_Data(nb)%Sfcprop%xtts(ix) + temp2d(i,j,idx_opt+12) = GFS_Data(nb)%Sfcprop%xzts(ix) + temp2d(i,j,idx_opt+13) = GFS_Data(nb)%Sfcprop%ifd(ix) + temp2d(i,j,idx_opt+14) = GFS_Data(nb)%Sfcprop%dt_cool(ix) + temp2d(i,j,idx_opt+15) = GFS_Data(nb)%Sfcprop%qrain(ix) endif do l = 1,Model%ntot2d - temp2d(i,j,nsfcprop2d+l) = IPD_Data(nb)%Tbd%phy_f2d(ix,l) + temp2d(i,j,nsfcprop2d+l) = GFS_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) + temp2d(i,j,nsfcprop2d+Model%ntot2d+l) = GFS_Data(nb)%Tbd%phy_fctd(ix,l) enddo - temp3dlevsp1(i,j,:, 1) = IPD_Data(nb)%Statein%phii(ix,:) - temp3dlevsp1(i,j,:, 2) = IPD_Data(nb)%Statein%prsi(ix,:) - temp3dlevsp1(i,j,:, 3) = IPD_Data(nb)%Statein%prsik(ix,:) - - temp3d(i,j,:, 1) = IPD_Data(nb)%Statein%phil(ix,:) - temp3d(i,j,:, 2) = IPD_Data(nb)%Statein%prsl(ix,:) - temp3d(i,j,:, 3) = IPD_Data(nb)%Statein%prslk(ix,:) - temp3d(i,j,:, 4) = IPD_Data(nb)%Statein%ugrs(ix,:) - temp3d(i,j,:, 5) = IPD_Data(nb)%Statein%vgrs(ix,:) - temp3d(i,j,:, 6) = IPD_Data(nb)%Statein%vvl(ix,:) - temp3d(i,j,:, 7) = IPD_Data(nb)%Statein%tgrs(ix,:) - temp3d(i,j,:, 8) = IPD_Data(nb)%Stateout%gu0(ix,:) - temp3d(i,j,:, 9) = IPD_Data(nb)%Stateout%gv0(ix,:) - temp3d(i,j,:,10) = IPD_Data(nb)%Stateout%gt0(ix,:) - temp3d(i,j,:,11) = IPD_Data(nb)%Radtend%htrsw(ix,:) - temp3d(i,j,:,12) = IPD_Data(nb)%Radtend%htrlw(ix,:) - temp3d(i,j,:,13) = IPD_Data(nb)%Radtend%swhc(ix,:) - temp3d(i,j,:,14) = IPD_Data(nb)%Radtend%lwhc(ix,:) + temp3dlevsp1(i,j,:, 1) = GFS_Data(nb)%Statein%phii(ix,:) + temp3dlevsp1(i,j,:, 2) = GFS_Data(nb)%Statein%prsi(ix,:) + temp3dlevsp1(i,j,:, 3) = GFS_Data(nb)%Statein%prsik(ix,:) + + temp3d(i,j,:, 1) = GFS_Data(nb)%Statein%phil(ix,:) + temp3d(i,j,:, 2) = GFS_Data(nb)%Statein%prsl(ix,:) + temp3d(i,j,:, 3) = GFS_Data(nb)%Statein%prslk(ix,:) + temp3d(i,j,:, 4) = GFS_Data(nb)%Statein%ugrs(ix,:) + temp3d(i,j,:, 5) = GFS_Data(nb)%Statein%vgrs(ix,:) + temp3d(i,j,:, 6) = GFS_Data(nb)%Statein%vvl(ix,:) + temp3d(i,j,:, 7) = GFS_Data(nb)%Statein%tgrs(ix,:) + temp3d(i,j,:, 8) = GFS_Data(nb)%Stateout%gu0(ix,:) + temp3d(i,j,:, 9) = GFS_Data(nb)%Stateout%gv0(ix,:) + temp3d(i,j,:,10) = GFS_Data(nb)%Stateout%gt0(ix,:) + temp3d(i,j,:,11) = GFS_Data(nb)%Radtend%htrsw(ix,:) + temp3d(i,j,:,12) = GFS_Data(nb)%Radtend%htrlw(ix,:) + temp3d(i,j,:,13) = GFS_Data(nb)%Radtend%swhc(ix,:) + temp3d(i,j,:,14) = GFS_Data(nb)%Radtend%lwhc(ix,:) do l = 1,Model%ntot3d - temp3d(i,j,:,14+l) = IPD_Data(nb)%Tbd%phy_f3d(ix,:,l) + temp3d(i,j,:,14+l) = GFS_Data(nb)%Tbd%phy_f3d(ix,:,l) enddo do l = 1,ntr - temp3d(i,j,:,14+Model%ntot3d+l) = IPD_Data(nb)%Statein%qgrs(ix,:,l) - temp3d(i,j,:,14+Model%ntot3d+ntr+l) = IPD_Data(nb)%Stateout%gq0(ix,:,l) + temp3d(i,j,:,14+Model%ntot3d+l) = GFS_Data(nb)%Statein%qgrs(ix,:,l) + temp3d(i,j,:,14+Model%ntot3d+ntr+l) = GFS_Data(nb)%Stateout%gq0(ix,:,l) enddo enddo enddo @@ -458,7 +435,7 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) deallocate(temp2d) deallocate(temp3d) deallocate(temp3dlevsp1) - end subroutine FV3GFS_IPD_checksum + end subroutine FV3GFS_GFS_checksum !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! @@ -479,29 +456,20 @@ end subroutine FV3GFS_IPD_checksum ! opens: oro_data.tile?.nc, sfc_data.tile?.nc ! !---------------------------------------------------------------------- -#ifdef CCPP subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_start) -#else - subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) -#endif !--- 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(GFS_control_type), intent(inout) :: Model type (domain2d), intent(in) :: fv_domain -#ifdef CCPP logical, intent(in) :: warm_start -#endif !--- local variables integer :: i, j, k, ix, lsoil, num, nb, i_start, j_start, i_end, j_end integer :: isc, iec, jsc, jec, npz, nx, ny integer :: id_restart integer :: nvar_o2, nvar_s2m, nvar_s2o, nvar_s3 integer :: nvar_oro_ls_ss - integer :: nvar_s2mp, nvar_s3mp,isnow -#ifdef CCPP - integer :: nvar_s2r -#endif + integer :: nvar_s2r, nvar_s2mp, nvar_s3mp, isnow real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p1 => NULL() @@ -527,7 +495,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) nvar_o2 = 19 nvar_oro_ls_ss = 10 nvar_s2o = 18 -#ifdef CCPP + if (Model%lsm == Model%lsm_ruc .and. warm_start) then if(Model%rdlai) then nvar_s2r = 11 @@ -543,9 +511,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif nvar_s3 = 3 endif -#else - nvar_s3 = 3 -#endif if (Model%lsm == Model%lsm_noahmp) then nvar_s2mp = 29 !mp 2D @@ -656,7 +621,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) deallocate(oro_name2, oro_var2) call free_restart_type(Oro_restart) -#ifdef CCPP !--- Modify/read-in additional orographic static fields for GSL drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then @@ -738,29 +702,20 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) call free_restart_type(Oro_ls_restart) call free_restart_type(Oro_ss_restart) end if -#endif !--- SURFACE FILE if (.not. allocated(sfc_name2)) then !--- allocate the various containers needed for restarts -#ifdef CCPP allocate(sfc_name2(nvar_s2m+nvar_s2o+nvar_s2mp+nvar_s2r)) allocate(sfc_name3(0:nvar_s3+nvar_s3mp)) - allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp+nvar_s2r),sfc_var3ice(nx,ny,Model%kice)) + if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4 .or. (.not.warm_start)) then allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) else if (Model%lsm == Model%lsm_ruc) then allocate(sfc_var3(nx,ny,Model%lsoil_lsm,nvar_s3)) end if -#else - allocate(sfc_name2(nvar_s2m+nvar_s2o+nvar_s2mp)) - allocate(sfc_name3(0:nvar_s3+nvar_s3mp)) - allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) - allocate(sfc_var3ice(nx,ny,Model%kice)) - allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) -#endif sfc_var2 = -9999.0_r8 sfc_var3 = -9999.0_r8 sfc_var3ice= -9999.0_r8 @@ -869,7 +824,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) sfc_name2(nvar_s2m+45) = 'smcwtdxy' sfc_name2(nvar_s2m+46) = 'deeprechxy' sfc_name2(nvar_s2m+47) = 'rechxy' -#ifdef CCPP else if (Model%lsm == Model%lsm_ruc .and. warm_start) then sfc_name2(nvar_s2m+19) = 'wetness' sfc_name2(nvar_s2m+20) = 'clw_surf_land' @@ -886,7 +840,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif else if (Model%lsm == Model%lsm_ruc .and. Model%rdlai) then sfc_name2(nvar_s2m+19) = 'lai' -#endif endif !--- register the 2D fields @@ -909,14 +862,14 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=mand) enddo endif -#ifdef CCPP + if (Model%lsm == Model%lsm_ruc) then ! nvar_s2mp = 0 do num = nvar_s2m+nvar_s2o+1, nvar_s2m+nvar_s2o+nvar_s2r var2_p => sfc_var2(:,:,num) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) enddo endif ! mp/ruc -#endif + ! Noah MP register only necessary only lsm = 2, not necessary has values if (nvar_s2mp > 0) then mand = .false. @@ -930,7 +883,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif ! if not allocated -#ifdef CCPP if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4 .or. (.not.warm_start)) then !--- names of the 3D variables to save sfc_name3(1) = 'stc' @@ -951,26 +903,13 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) sfc_name3(4) = 'smfr' sfc_name3(5) = 'flfr' endif -#else - !--- 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 + !--- register the 3D fields - if (Model%frac_grid) then +! if (Model%frac_grid) then sfc_name3(0) = 'tiice' var3_p => sfc_var3ice(:,:,:) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name3(0), var3_p, domain=fv_domain, mandatory=.false.) - end if +! end if do num = 1,nvar_s3 var3_p => sfc_var3(:,:,:,num) @@ -1152,7 +1091,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain endif endif -#ifdef CCPP + if (Model%lsm == Model%lsm_ruc .and. warm_start) then !--- Extra RUC variables Sfcprop(nb)%wetness(ix) = sfc_var2(i,j,nvar_s2m+19) @@ -1168,15 +1107,14 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (Model%rdlai) then Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+29) endif - else if (Model%lsm == Model%lsm_ruc .and. Model%rdlai) then - Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+19) + else if (Model%lsm == Model%lsm_ruc) then + ! Initialize RUC snow cover on ice from snow cover + Sfcprop(nb)%sncovr_ice(ix) = Sfcprop(nb)%sncovr(ix) + if (Model%rdlai) then + Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+19) + end if elseif (Model%lsm == Model%lsm_noahmp) then !--- Extra Noah MP variables -#else -! Noah MP -! ------- - if (Model%lsm == Model%lsm_noahmp) then -#endif 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) @@ -1208,7 +1146,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%rechxy(ix) = sfc_var2(i,j,nvar_s2m+47) endif -#ifdef CCPP if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4 .or. (.not.warm_start)) then !--- 3D variables do lsoil = 1,Model%lsoil @@ -1247,30 +1184,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) do k = 1,Model%kice Sfcprop(nb)%tiice(ix,k)= sfc_var3ice(i,j,k) !--- internal ice temp enddo -#else - !--- 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 -#endif enddo !ix enddo !nb @@ -1287,45 +1200,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) ! 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 -#ifdef CCPP - ! Calculating sncovr does NOT belong into an I/O routine! - ! TODO: move to physics and stop building namelist_soilveg/set_soilveg - ! in the FV3/non-CCPP physics when the CCPP-enabled executable is built. -#endif -!#ifndef CCPP - i = Atm_block%index(1)%ii(1) - isc + 1 j = Atm_block%index(1)%jj(1) - jsc + 1 - !--- if sncovr does not exist in the restart, need to create it - if (sfc_var2(i,j,32) < -9990.0_r8) 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 -!$omp parallel do default(shared) private(nb, ix, vegtyp, rsnow) - do nb = 1, Atm_block%nblks - do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%sncovr(ix) = zero - if (Sfcprop(nb)%landfrac(ix) >= drythresh .or. Sfcprop(nb)%fice(ix) >= Model%min_seaice) then - vegtyp = Sfcprop(nb)%vtype(ix) - if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001_r8*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) - if (0.001_r8*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then - Sfcprop(nb)%sncovr(ix) = one - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) - else - Sfcprop(nb)%sncovr(ix) = one - endif - endif - enddo - enddo - !--- For RUC LSM: create sncovr_ice from sncovr - if (Model%lsm == Model%lsm_ruc) then - if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - fill sncovr_ice with sncovr') - do nb = 1, Atm_block%nblks - Sfcprop(nb)%sncovr_ice(:) = Sfcprop(nb)%sncovr(:) - end do - endif - endif ! if (Model%frac_grid) then @@ -1369,8 +1246,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif -!#endif - if(Model%frac_grid) then ! 3-way composite !$omp parallel do default(shared) private(nb, ix, tem, tem1) do nb = 1, Atm_block%nblks @@ -1431,7 +1306,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif endif ! if (Model%frac_grid) -!#ifdef CCPP if (nint(sfc_var3ice(1,1,1)) == -9999) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') do nb = 1, Atm_block%nblks @@ -1441,7 +1315,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif -!#endif if (Model%lsm == Model%lsm_noahmp) then if (nint(sfc_var2(1,1,nvar_s2m+19)) == -66666) then @@ -1707,6 +1580,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) endif endif !if Noah MP cold start ends +! *DH MOVE TO CCPP? + end subroutine sfc_prop_restart_read @@ -1724,7 +1599,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta !--- 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(GFS_control_type), intent(in) :: Model type(domain2d), intent(in) :: fv_domain character(len=32), optional, intent(in) :: timestamp !--- local variables @@ -1732,10 +1607,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta integer :: isc, iec, jsc, jec, npz, nx, ny integer :: id_restart integer :: nvar2m, nvar2o, nvar3 - integer :: nvar2mp, nvar3mp -#ifdef CCPP - integer :: nvar2r -#endif + integer :: nvar2r, nvar2mp, nvar3mp logical :: mand character(len=32) :: fn_srf = 'sfc_data.nc' real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() @@ -1751,7 +1623,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta ! endif if (Model%cplwav) nvar2m = nvar2m + 1 nvar2o = 18 -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then if (Model%rdlai) then nvar2r = 11 @@ -1763,9 +1634,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta nvar2r = 0 nvar3 = 3 endif -#else - nvar3 = 3 -#endif nvar2mp = 0 nvar3mp = 0 if (Model%lsm == Model%lsm_noahmp) then @@ -1781,7 +1649,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta nx = (iec - isc + 1) ny = (jec - jsc + 1) -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then if (allocated(sfc_name2)) then ! Re-allocate if one or more of the dimensions don't match @@ -1797,11 +1664,9 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta end if end if end if -#endif if (.not. allocated(sfc_name2)) then !--- allocate the various containers needed for restarts -#ifdef CCPP allocate(sfc_name2(nvar2m+nvar2o+nvar2mp+nvar2r)) allocate(sfc_name3(0:nvar3+nvar3mp)) allocate(sfc_var2(nx,ny,nvar2m+nvar2o+nvar2mp+nvar2r)) @@ -1810,12 +1675,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta elseif (Model%lsm == Model%lsm_ruc) then allocate(sfc_var3(nx,ny,Model%lsoil_lsm,nvar3)) endif -#else - allocate(sfc_name2(nvar2m+nvar2o+nvar2mp)) - allocate(sfc_name3(0:nvar3+nvar3mp)) - allocate(sfc_var2(nx,ny,nvar2m+nvar2o+nvar2mp)) - allocate(sfc_var3(nx,ny,Model%lsoil,nvar3)) -#endif sfc_var2 = -9999.0_r8 sfc_var3 = -9999.0_r8 if (Model%lsm == Model%lsm_noahmp) then @@ -1890,7 +1749,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(nvar2m+16) = 'ifd' sfc_name2(nvar2m+17) = 'dt_cool' sfc_name2(nvar2m+18) = 'qrain' -#ifdef CCPP if (Model%lsm == Model%lsm_ruc) then sfc_name2(nvar2m+19) = 'wetness' sfc_name2(nvar2m+20) = 'clw_surf_land' @@ -1906,10 +1764,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(nvar2m+29) = 'lai' endif else if(Model%lsm == Model%lsm_noahmp) then -#else -! Only needed when Noah MP LSM is used - 29 2D - if(Model%lsm == Model%lsm_noahmp) then -#endif + ! Only needed when Noah MP LSM is used - 29 2D sfc_name2(nvar2m+19) = 'snowxy' sfc_name2(nvar2m+20) = 'tvxy' sfc_name2(nvar2m+21) = 'tgxy' @@ -1959,16 +1814,13 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=mand) enddo endif -#ifdef CCPP - if (Model%lsm == Model%lsm_ruc) then ! nvar2mp =0 + + if (Model%lsm == Model%lsm_ruc) then ! nvar2mp =0 do num = nvar2m+nvar2o+1, nvar2m+nvar2o+nvar2r var2_p => sfc_var2(:,:,num) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) enddo - else if (Model%lsm == Model%lsm_noahmp) then ! nvar2r =0 -#else - if (Model%lsm == Model%lsm_noahmp) then -#endif + else if (Model%lsm == Model%lsm_noahmp) then ! nvar2r =0 mand = .true. ! actually should be true since it is after cold start do num = nvar2m+nvar2o+1,nvar2m+nvar2o+nvar2mp var2_p => sfc_var2(:,:,num) @@ -1977,7 +1829,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta endif nullify(var2_p) -#ifdef CCPP if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4) then !--- names of the 3D variables to save sfc_name3(1) = 'stc' @@ -1998,26 +1849,13 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name3(4) = 'smfr' sfc_name3(5) = 'flfr' end if -#else - !--- names of the 3D variables to save - sfc_name3(1) = 'stc' - sfc_name3(2) = 'smc' - sfc_name3(3) = 'slc' - 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 !--- register the 3D fields - if (Model%frac_grid) then +! if (Model%frac_grid) then sfc_name3(0) = 'tiice' var3_p => sfc_var3ice(:,:,:) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name3(0), var3_p, domain=fv_domain) - endif +! endif do num = 1,nvar3 var3_p => sfc_var3(:,:,:,num) @@ -2118,7 +1956,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,nvar2m+17) = Sfcprop(nb)%dt_cool(ix)!--- nsstm dt_cool sfc_var2(i,j,nvar2m+18) = Sfcprop(nb)%qrain(ix) !--- nsstm qrain endif -#ifdef CCPP + if (Model%lsm == Model%lsm_ruc) then !--- Extra RUC variables sfc_var2(i,j,nvar2m+19) = Sfcprop(nb)%wetness(ix) @@ -2135,12 +1973,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,nvar2m+29) = Sfcprop(nb)%xlaixy(ix) endif else if (Model%lsm == Model%lsm_noahmp) then - -#else -! Noah MP - if (Model%lsm == Model%lsm_noahmp) then -#endif - + !--- Extra Noah MP variables sfc_var2(i,j,nvar2m+19) = Sfcprop(nb)%snowxy(ix) sfc_var2(i,j,nvar2m+20) = Sfcprop(nb)%tvxy(ix) sfc_var2(i,j,nvar2m+21) = Sfcprop(nb)%tgxy(ix) @@ -2172,7 +2005,6 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,nvar2m+47) = Sfcprop(nb)%rechxy(ix) endif -#ifdef CCPP do k = 1,Model%kice sfc_var3ice(i,j,k) = Sfcprop(nb)%tiice(ix,k) !--- internal ice temperature end do @@ -2212,32 +2044,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var3(i,j,lsoil,5) = Sfcprop(nb)%flag_frsoil(ix,lsoil) !--- flag_frsoil enddo end if -#else - !--- 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 -#endif enddo enddo @@ -2259,11 +2066,11 @@ end subroutine sfc_prop_restart_write ! opens: phys_data.tile?.nc ! !---------------------------------------------------------------------- - subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) + subroutine phys_restart_read (GFS_Restart, Atm_block, Model, fv_domain) !--- interface variable definitions - type(IPD_restart_type), intent(in) :: IPD_Restart + type(GFS_restart_type), intent(in) :: GFS_Restart type(block_control_type), intent(in) :: Atm_block - type(IPD_control_type), intent(in) :: Model + type(GFS_control_type), intent(in) :: Model type(domain2d), intent(in) :: fv_domain !--- local variables integer :: i, j, k, nb, ix, num @@ -2282,10 +2089,10 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) npz = Atm_block%npz nx = (iec - isc + 1) ny = (jec - jsc + 1) - nvar2d = IPD_Restart%num2d - nvar3d = IPD_Restart%num3d - fdiag = IPD_Restart%fdiag - ldiag = IPD_Restart%ldiag + nvar2d = GFS_Restart%num2d + nvar3d = GFS_Restart%num3d + fdiag = GFS_Restart%fdiag + ldiag = GFS_Restart%ldiag !--- register the restart fields if (.not. allocated(phy_var2)) then @@ -2296,12 +2103,12 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) do num = 1,nvar2d var2_p => phy_var2(:,:,num) - id_restart = register_restart_field (Phy_restart, fn_phy, trim(IPD_Restart%name2d(num)), & + id_restart = register_restart_field (Phy_restart, fn_phy, trim(GFS_Restart%name2d(num)), & var2_p, domain=fv_domain, mandatory=.false.) enddo do num = 1,nvar3d var3_p => phy_var3(:,:,:,num) - id_restart = register_restart_field (Phy_restart, fn_phy, trim(IPD_restart%name3d(num)), & + id_restart = register_restart_field (Phy_restart, fn_phy, trim(GFS_restart%name3d(num)), & var3_p, domain=fv_domain, mandatory=.false.) enddo nullify(var2_p) @@ -2326,7 +2133,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) 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) + GFS_Restart%data(nb,num)%var2p(ix) = phy_var2(i,j,num) enddo enddo enddo @@ -2338,7 +2145,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) 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) = zero + GFS_Restart%data(nb,num)%var2p(ix) = zero enddo enddo enddo @@ -2350,7 +2157,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) 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) + GFS_Restart%data(nb,num)%var3p(ix,k) = phy_var3(i,j,k,num) enddo enddo enddo @@ -2369,11 +2176,11 @@ end subroutine phys_restart_read ! ! calls: register_restart_field, save_restart !---------------------------------------------------------------------- - subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timestamp) + subroutine phys_restart_write (GFS_Restart, Atm_block, Model, fv_domain, timestamp) !--- interface variable definitions - type(IPD_restart_type), intent(in) :: IPD_Restart + type(GFS_restart_type), intent(in) :: GFS_Restart type(block_control_type), intent(in) :: Atm_block - type(IPD_control_type), intent(in) :: Model + type(GFS_control_type), intent(in) :: Model type(domain2d), intent(in) :: fv_domain character(len=32), optional, intent(in) :: timestamp !--- local variables @@ -2392,8 +2199,8 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta npz = Atm_block%npz nx = (iec - isc + 1) ny = (jec - jsc + 1) - nvar2d = IPD_Restart%num2d - nvar3d = IPD_Restart%num3d + nvar2d = GFS_Restart%num2d + nvar3d = GFS_Restart%num3d !--- register the restart fields if (.not. allocated(phy_var2)) then @@ -2404,12 +2211,12 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta do num = 1,nvar2d var2_p => phy_var2(:,:,num) - id_restart = register_restart_field (Phy_restart, fn_phy, trim(IPD_Restart%name2d(num)), & + id_restart = register_restart_field (Phy_restart, fn_phy, trim(GFS_Restart%name2d(num)), & var2_p, domain=fv_domain, mandatory=.false.) enddo do num = 1,nvar3d var3_p => phy_var3(:,:,:,num) - id_restart = register_restart_field (Phy_restart, fn_phy, trim(IPD_restart%name3d(num)), & + id_restart = register_restart_field (Phy_restart, fn_phy, trim(GFS_restart%name3d(num)), & var3_p, domain=fv_domain, mandatory=.false.) enddo nullify(var2_p) @@ -2423,7 +2230,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta 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) + phy_var2(i,j,num) = GFS_Restart%data(nb,num)%var2p(ix) enddo enddo enddo @@ -2435,7 +2242,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta 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) + phy_var3(i,j,k,num) = GFS_Restart%data(nb,num)%var3p(ix,k) enddo enddo enddo @@ -2460,10 +2267,10 @@ end subroutine phys_restart_write subroutine fv3gfs_diag_register(Diag, Time, Atm_block, Model, xlon, xlat, axes) use physcons, only: con_g !--- subroutine interface variable definitions - type(IPD_diag_type), intent(inout) :: Diag(:) + type(GFS_externaldiag_type), intent(inout) :: Diag(:) type(time_type), intent(in) :: Time type (block_control_type), intent(in) :: Atm_block - type(IPD_control_type), intent(in) :: Model + type(GFS_control_type), intent(in) :: Model real(kind=kind_phys), intent(in) :: xlon(:,:) real(kind=kind_phys), intent(in) :: xlat(:,:) integer, dimension(4), intent(in) :: axes @@ -2576,7 +2383,7 @@ subroutine fv3gfs_diag_output(time, diag, atm_block, nx, ny, levs, ntcw, ntoz, & dt, time_int, time_intfull, time_radsw, time_radlw) !--- subroutine interface variable definitions type(time_type), intent(in) :: time - type(IPD_diag_type), intent(in) :: diag(:) + type(GFS_externaldiag_type), intent(in) :: diag(:) type (block_control_type), intent(in) :: atm_block integer, intent(in) :: nx, ny, levs, ntcw, ntoz real(kind=kind_phys), intent(in) :: dt @@ -3029,7 +2836,7 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb ! implicit none ! - type(IPD_diag_type),intent(in) :: Diag(:) + type(GFS_externaldiag_type),intent(in) :: Diag(:) integer, intent(in) :: axes(:) type(ESMF_FieldBundle),intent(inout) :: phys_bundle(:) type(ESMF_Grid),intent(inout) :: fcst_grid diff --git a/io/makefile b/io/makefile deleted file mode 100644 index 99a0dbdce..000000000 --- a/io/makefile +++ /dev/null @@ -1,101 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 io ...) - $(info ) -endif -$(info $$ESMF_INC is [${ESMF_INC}]) - -LIBRARY = libfv3io.a - -FFLAGS += -I$(FMS_DIR) -I../gfsphysics -I../ipd - -ifneq (,$(findstring NO_INLINE_POST,$(CPPDEFS))) -POST_SRC = \ - ./post_gfs_stub.F90 -else -POST_SRC = \ - ./post_gfs.F90 \ - ./post_nems_routines.F90 -endif - -SRCS_f = - -SRCS_f90 = - -SRCS_F = - -SRCS_F90 = \ - ./ffsync.F90 \ - ./FV3GFS_io.F90 \ - $(POST_SRC) \ - ./module_write_nemsio.F90 \ - ./module_write_netcdf.F90 \ - ./module_write_netcdf_parallel.F90 \ - ./module_fv3_io_def.F90 \ - ./module_write_internal_state.F90 \ - ./module_wrt_grid_comp.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -FV3GFS_io.o: FV3GFS_io.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c FV3GFS_io.F90 -post_nems_routines.o: post_nems_routines.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) -I$(UPP_INC) -c post_nems_routines.F90 -module_write_nemsio.o: module_write_nemsio.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) $(NEMSIOINC) -c module_write_nemsio.F90 -module_write_netcdf.o: module_write_netcdf.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_write_netcdf.F90 -module_write_netcdf_parallel.o: module_write_netcdf_parallel.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_write_netcdf_parallel.F90 -module_fv3_io_def.o: module_fv3_io_def.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_fv3_io_def.F90 -module_write_internal_state.o: module_write_internal_state.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_write_internal_state.F90 -module_wrt_grid_comp.o: module_wrt_grid_comp.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_wrt_grid_comp.F90 -post_gfs.o: post_gfs.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -I$(UPP_INC) -c post_gfs.F90 -post_gfs_stub.o: post_gfs_stub.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c post_gfs_stub.F90 - - -.PHONY: clean -clean: - @echo "Cleaning io ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.o *.mod *.i90 *.lst *.i depend - -MKDEPENDS = ../mkDepends.pl -include ../conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/ipd/CMakeLists.txt b/ipd/CMakeLists.txt deleted file mode 100644 index d0a6bba23..000000000 --- a/ipd/CMakeLists.txt +++ /dev/null @@ -1,33 +0,0 @@ -if(32BIT) - message ("Force 64 bits in ipd") - if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") - if(REPRO) - string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") - else() - string (REPLACE "-i4 -real-size 32" "-i4 -real-size 64 -no-prec-div -no-prec-sqrt" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") - endif() - elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") - endif() -endif() - -if(CCPP) - list(APPEND _ipd_defs_private CCPP) -endif() - -add_library( - ipd - - IPD_driver.F90 - IPD_typedefs.F90 -) -set_target_properties(ipd PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod) -target_compile_definitions(ipd PRIVATE "${_ipd_defs_private}") -target_include_directories(ipd PUBLIC $) - -if(CCPP) - target_include_directories(ipd PRIVATE ${CMAKE_BINARY_DIR}/FV3/ccpp/framework/src - ${CMAKE_BINARY_DIR}/FV3/ccpp/physics) -endif() - -target_link_libraries(ipd PRIVATE gfsphysics) diff --git a/ipd/IPD_driver.F90 b/ipd/IPD_driver.F90 deleted file mode 100644 index 93a61055d..000000000 --- a/ipd/IPD_driver.F90 +++ /dev/null @@ -1,121 +0,0 @@ -module IPD_driver - - use IPD_typedefs, only: IPD_kind_phys, IPD_init_type, & - IPD_control_type, IPD_data_type, & - IPD_diag_type, IPD_restart_type, & - IPD_func0d_proc, IPD_func1d_proc, & - initialize, & - diagnostic_populate, & - restart_populate -#ifdef CCPP - use IPD_typedefs, only: IPD_interstitial_type -#endif - - 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, IPD_initialize_rst - public IPD_step - - CONTAINS -!******************************************************************************************* - - -!---------------- -! IPD Initialize -!---------------- -#ifdef CCPP - subroutine IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, & - IPD_Interstitial, communicator, ntasks, IPD_init_parm) -#else - subroutine IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, IPD_init_parm) -#endif - 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 -#ifdef CCPP - type(IPD_interstitial_type), intent(inout) :: IPD_Interstitial(:) - integer, intent(in) :: communicator - integer, intent(in) :: ntasks -#endif - 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, & -#ifdef CCPP - IPD_Data(:)%Intdiag, IPD_Interstitial(:), communicator, & - ntasks, IPD_init_parm) -#else - IPD_Data(:)%Intdiag, IPD_init_parm) -#endif - - - !--- populate/associate the Diag container elements - call diagnostic_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) - - - end subroutine IPD_initialize - -!---------------- -! IPD Initialize phase_rst -!---------------- - subroutine IPD_initialize_rst (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 - - !--- 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, IPD_Diag) - - end subroutine IPD_initialize_rst - -!---------------------------------------------------------- -! IPD step -! runs the given routine/function pointed to by IPD_func -!---------------------------------------------------------- - subroutine IPD_step (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, IPD_func0d, IPD_func1d) - 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 - procedure(IPD_func0d_proc), intent(in), optional, pointer :: IPD_func0d - procedure(IPD_func1d_proc), intent(in), optional, pointer :: IPD_func1d - - if (size(IPD_Data,1) == 1 .and. PRESENT(IPD_func0d)) then - call IPD_func0d (IPD_Control, IPD_Data(1)%Statein, IPD_Data(1)%Stateout, & - IPD_Data(1)%Sfcprop, IPD_Data(1)%Coupling, IPD_Data(1)%Grid, & - IPD_Data(1)%Tbd, IPD_Data(1)%Cldprop, IPD_Data(1)%Radtend, & - IPD_Data(1)%Intdiag) - else - call IPD_func1d (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) - endif - - end subroutine IPD_step - -end module IPD_driver diff --git a/ipd/IPD_typedefs.F90 b/ipd/IPD_typedefs.F90 deleted file mode 100644 index 9a0bbbb77..000000000 --- a/ipd/IPD_typedefs.F90 +++ /dev/null @@ -1,165 +0,0 @@ -module IPD_typedefs - -!--------------------------------------------------------- -! Physics/Radiation types used to create various IPD types -!--------------------------------------------------------- - use physics_abstraction_layer, only: IPD_control_type => control_type, & - IPD_init_type => init_type, & - IPD_restart_type => restart_type, & - IPD_diag_type => diagnostic_type, & - IPD_kind_phys => kind_phys -#ifdef CCPP - use physics_abstraction_layer, only: IPD_interstitial_type => interstitial_type -#endif - -!--------------------------------------------------------- -! Physics/Radiation types used to create the IPD_data_type -!--------------------------------------------------------- - use physics_abstraction_layer, only: statein_type, stateout_type, & - sfcprop_type, coupling_type, & - grid_type, tbd_type, & - cldprop_type, radtend_type, & - intdiag_type -#ifdef CCPP - use physics_abstraction_layer, only: IPD_data_type => data_type -#endif - -!------------------------------------------------- -! Physics/Radiation routines to pass to IPD_driver -!------------------------------------------------- - use physics_abstraction_layer, only: initialize, & - diagnostic_populate, & - restart_populate - -#ifndef CCPP -!------------------------------------------------------- -! IPD_data_type -! container of physics data types that can be blocked -!------------------------------------------------------- - 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 -#endif - - -!------------------------------------------------------ -! IPD function procedures -! definitions for scalar(0d) and vector(1d) versions -!------------------------------------------------------ - abstract interface - subroutine IPD_func0d_proc (Control, Statein, Stateout, & - Sfcprop, Coupling, Grid, & - Tbd, Cldprop, Radtend, & - Intdiag) - import :: IPD_control_type, statein_type, stateout_type, & - sfcprop_type, coupling_type, grid_type, tbd_type, & - cldprop_type, radtend_type, intdiag_type - type(IPD_control_type), intent(inout) :: Control - type(statein_type), intent(inout) :: Statein - type(stateout_type), intent(inout) :: Stateout - type(sfcprop_type), intent(inout) :: Sfcprop - type(coupling_type), intent(inout) :: Coupling - type(grid_type), intent(inout) :: Grid - type(tbd_type), intent(inout) :: Tbd - type(cldprop_type), intent(inout) :: Cldprop - type(radtend_type), intent(inout) :: Radtend - type(intdiag_type), intent(inout) :: Intdiag - end subroutine IPD_func0d_proc - - subroutine IPD_func1d_proc (Control, Statein, Stateout, & - Sfcprop, Coupling, Grid, & - Tbd, Cldprop, Radtend, & - Intdiag) - import :: IPD_control_type, statein_type, stateout_type, & - sfcprop_type, coupling_type, grid_type, tbd_type, & - cldprop_type, radtend_type, intdiag_type - type(IPD_control_type), intent(inout) :: Control - type(statein_type), intent(inout) :: Statein(:) - type(stateout_type), intent(inout) :: Stateout(:) - type(sfcprop_type), intent(inout) :: Sfcprop(:) - type(coupling_type), intent(inout) :: Coupling(:) - type(grid_type), intent(inout) :: Grid(:) - type(tbd_type), intent(inout) :: Tbd(:) - type(cldprop_type), intent(inout) :: Cldprop(:) - type(radtend_type), intent(inout) :: Radtend(:) - type(intdiag_type), intent(inout) :: Intdiag(:) - end subroutine IPD_func1d_proc - end interface - - -!------------------------------------------------ -! SAMPLE var_subtype -! pointers to two and three dimensional objects -!------------------------------------------------ -! 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 -! -!-------------------------------------------------- -! SAMPLE restart_type to import as IPD_restart_type -! data necessary for reproducible restarts -!-------------------------------------------------- -! type 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 restart_type -! -!-------------------------------------------------- -! SAMPLE diagnostic_type to import as IPD_diag_type -! fields targetted as diagnostic output -!-------------------------------------------------- -! type 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 diag_type - - -!------------------------ -! IPD public declarations -!------------------------ - public IPD_kind_phys - public IPD_control_type - public IPD_data_type - public IPD_restart_type - public IPD_diag_type - public IPD_init_type -#ifdef CCPP - public IPD_interstitial_type -#endif - - -!----------------------------------- -! public declarations for IPD_driver -!----------------------------------- - public initialize - public diagnostic_populate - public restart_populate - - CONTAINS -!******************************************************************************************* - -end module IPD_typedefs diff --git a/ipd/makefile b/ipd/makefile deleted file mode 100644 index ed4a2749b..000000000 --- a/ipd/makefile +++ /dev/null @@ -1,58 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 gfsphysics ...) - $(info ) -endif - -LIBRARY = libipd.a - -FFLAGS += -I$(FMS_DIR) -I../gfsphysics - -CPPDEFS += -DNEW_TAUCTMAX -DSMALL_PE -DNEMS_GSM -DINTERNAL_FILE_NML - -SRCS_F90 = \ - ./IPD_driver.F90 \ - ./IPD_typedefs.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -.PHONY: clean -clean: - @echo "Cleaning ipd ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.o */*.o *.mod *.i90 *.lst *.i depend - -MKDEPENDS = ../mkDepends.pl -include ../conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/makefile b/makefile deleted file mode 100644 index 4191b4777..000000000 --- a/makefile +++ /dev/null @@ -1,165 +0,0 @@ -SHELL = /bin/sh - -include conf/configure.fv3 - -ifeq ($(strip $(FMS_DIR)),) - FMS_DIR=$(realpath ../FMS/FMS_INSTALL) -endif - -exist=$(wildcard $(FMS_DIR)) -ifeq ($(strip $(exist)),) - $(error ERROR: FMS_DIR variable is unset and FMS_INSTALL is not in ../FMS/FMS_INSTALL ) -endif - - -FFLAGS += -I$(FMS_DIR) -Igfsphysics -Iipd -Icpl -Iio -Iatmos_cubed_sphere -Iccpp/driver -Istochastic_physics -CPPDEFS += -DESMF_VERSION_MAJOR=$(ESMF_VERSION_MAJOR) - -# Flag to CCPP build for 32bit dynamics -ifeq ($(32BIT),Y) - DYN32 = Y -else - DYN32 = N -endif - -FV3_EXE = fv3.exe -FV3CAP_LIB = libfv3cap.a - -all: libs - $(MAKE) $(FV3_EXE) $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - -nems: libs - $(MAKE) $(FV3CAP_LIB) $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) esmf_make_fragment FMS_DIR=$(FMS_DIR) - -ifneq (,$(findstring CCPP,$(CPPDEFS))) -libs: - $(MAKE) -C cpl $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C gfsphysics $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N DYN32=$(DYN32) # force gfs physics to 64bit, flag to CCPP build for 32bit dynamics - $(MAKE) -C ccpp/driver $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N DYN32=$(DYN32) # force gfs physics to 64bit, flag to CCPP build for 32bit dynamics - $(MAKE) -C ipd $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - $(MAKE) -C io $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C atmos_cubed_sphere $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C ../stochastic_physics $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - $(MAKE) -C stochastic_physics $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - -$(FV3_EXE): atmos_model.o coupler_main.o ccpp/driver/libccppdriver.a atmos_cubed_sphere/libfv3core.a io/libfv3io.a ipd/libipd.a gfsphysics/libgfsphys.a stochastic_physics/libstochastic_physics_wrapper.a ../stochastic_physics/libstochastic_physics.a cpl/libfv3cpl.a - $(LD) -o $@ $^ $(NCEPLIBS) $(LDFLAGS) - -else -libs: - $(MAKE) -C cpl $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C gfsphysics $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - $(MAKE) -C ipd $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - $(MAKE) -C io $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C atmos_cubed_sphere $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) - $(MAKE) -C ../stochastic_physics $(MAKE_OPTS) FMS_DIR=$(FMS_DIR) 32BIT=N # force gfs physics to 64bit - -$(FV3_EXE): atmos_model.o coupler_main.o atmos_cubed_sphere/libfv3core.a io/libfv3io.a ipd/libipd.a gfsphysics/libgfsphys.a ../stochastic_physics/libstochastic_physics.a cpl/libfv3cpl.a - $(LD) -o $@ $^ $(NCEPLIBS) $(LDFLAGS) -endif - -$(FV3CAP_LIB): atmos_model.o module_fv3_config.o module_fcst_grid_comp.o time_utils.o fv3_cap.o - ar rv $(FV3CAP_LIB) $? - -atmos_model.o : atmos_model.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c atmos_model.F90 - -module_fv3_config.o: module_fv3_config.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_fv3_config.F90 -module_fcst_grid_comp.o: module_fcst_grid_comp.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c module_fcst_grid_comp.F90 -time_utils.o: time_utils.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c time_utils.F90 -fv3_cap.o: fv3_cap.F90 - $(FC) $(CPPDEFS) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c fv3_cap.F90 - -DEPEND_FILES = time_utils.F90 module_fv3_config.F90 atmos_model.F90 module_fcst_grid_comp.F90 fv3_cap.F90 coupler_main.F90 - -# For CCPP, check if SIONlib is used and set linker flags accordingly -ifneq (,$(findstring CCPP,$(CPPDEFS))) -ifneq (,$(findstring SION,$(CPPDEFS))) - SIONLIB_LINK_FLAGS = $(SIONLIB_LIB) -else - SIONLIB_LINK_FLAGS = -endif -endif - -ifneq (,$(findstring CCPP,$(CPPDEFS))) -esmf_make_fragment: - @rm -rf nems_dir; mkdir nems_dir - @cp $(FV3CAP_LIB) ccpp/driver/libccppdriver.a atmos_cubed_sphere/libfv3core.a io/libfv3io.a ipd/libipd.a gfsphysics/libgfsphys.a cpl/libfv3cpl.a stochastic_physics/libstochastic_physics_wrapper.a ../stochastic_physics/libstochastic_physics.a nems_dir - @cp fv3gfs_cap_mod.mod nems_dir - @echo "# ESMF self-describing build dependency makefile fragment" > fv3.mk - @echo "# src location $(PWD)" >> fv3.mk - @echo >> fv3.mk - @echo "ESMF_DEP_FRONT = fv3gfs_cap_mod" >> fv3.mk - # additional include files needed for PGI - #@echo "ESMF_DEP_INCPATH = $(PWD)/nems_dir" >> fv3.mk - @echo "ESMF_DEP_INCPATH = $(PWD) $(addprefix $(PWD)/, nems_dir ccpp/driver atmos_cubed_sphere io gfsphysics cpl ipd ../stochastic_physics)" >> fv3.mk - @echo "ESMF_DEP_CMPL_OBJS =" >> fv3.mk - @echo "ESMF_DEP_LINK_OBJS = $(addprefix $(PWD)/nems_dir/, libfv3cap.a libccppdriver.a libfv3core.a libfv3io.a libipd.a libgfsphys.a libfv3cpl.a libstochastic_physics_wrapper.a libstochastic_physics.a) $(SIONLIB_LINK_FLAGS)" >> fv3.mk - @echo "ESMF_DEP_SHRD_PATH =" >> fv3.mk - @echo "ESMF_DEP_SHRD_LIBS =" >> fv3.mk - @echo - @echo "Finished generating ESMF self-describing build dependency makefile fragment:" fv3.mk - @echo -else -esmf_make_fragment: - @rm -rf nems_dir; mkdir nems_dir - @cp $(FV3CAP_LIB) atmos_cubed_sphere/libfv3core.a io/libfv3io.a ipd/libipd.a gfsphysics/libgfsphys.a cpl/libfv3cpl.a ../stochastic_physics/libstochastic_physics.a nems_dir - @cp fv3gfs_cap_mod.mod nems_dir - @echo "# ESMF self-describing build dependency makefile fragment" > fv3.mk - @echo "# src location $(PWD)" >> fv3.mk - @echo >> fv3.mk - @echo "ESMF_DEP_FRONT = fv3gfs_cap_mod" >> fv3.mk - # additional include files needed for PGI - #@echo "ESMF_DEP_INCPATH = $(PWD)/nems_dir" >> fv3.mk - @echo "ESMF_DEP_INCPATH = $(PWD) $(addprefix $(PWD)/, nems_dir atmos_cubed_sphere io gfsphysics cpl ipd ../stochastic_physics)" >> fv3.mk - @echo "ESMF_DEP_CMPL_OBJS =" >> fv3.mk - @echo "ESMF_DEP_LINK_OBJS = $(addprefix $(PWD)/nems_dir/, libfv3cap.a libfv3core.a libfv3io.a libipd.a libgfsphys.a libfv3cpl.a libstochastic_physics.a)" >> fv3.mk - @echo "ESMF_DEP_SHRD_PATH =" >> fv3.mk - @echo "ESMF_DEP_SHRD_LIBS =" >> fv3.mk - @echo - @echo "Finished generating ESMF self-describing build dependency makefile fragment:" fv3.mk - @echo -endif - -# fv3 library installation defaults (for NEMS): -DESTDIR := $(PWD) -INSTDIR := FV3_INSTALL - -nemsinstall: nems - @mkdir -p $(DESTDIR)/$(INSTDIR) - @cp nems_dir/* $(DESTDIR)/$(INSTDIR) - @sed -e 's;'$(PWD)/nems_dir';'$(DESTDIR)/$(INSTDIR)';g' fv3.mk > $(DESTDIR)/$(INSTDIR)/fv3.mk - @echo Installation into \"$(DESTDIR)/$(INSTDIR)\" complete! - @echo - -.PHONY: clean cleanall -clean: - @echo "Cleaning ... " - @echo - (cd gfsphysics && make clean) - (cd ccpp/driver && make clean) - (cd ipd && make clean) - (cd ../stochastic_physics && make clean) - (cd stochastic_physics && make clean) - (cd io && make clean) - (cd atmos_cubed_sphere && make clean) - (cd cpl && make clean) - $(RM) -f $(FV3_EXE) $(FV3CAP_LIB) *.o *.mod *.i90 *.lst depend - -cleanall: clean - $(RM) -rf nems_dir fv3.mk $(INSTDIR) - $(RM) -f conf/modules.fv3 - $(RM) -f conf/configure.fv3 - -MKDEPENDS = ./mkDepends.pl -include conf/make.rules - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/mkDepends.pl b/mkDepends.pl deleted file mode 100755 index 97c992715..000000000 --- a/mkDepends.pl +++ /dev/null @@ -1,357 +0,0 @@ -#!/usr/bin/env perl - -# Modifications to Brian Eaton's original to relax the restrictions on -# source file name matching module name and only one module per source -# file. See the new "-m" and "-d" options for details. -# -# One important limitation remains. If your module is named "procedure", -# this script will quietly ignore it. -# -# Tom Henderson -# Global Systems Division, NOAA/OAR -# Mar 2011 -# -# Brian Eaton's original comments follow: -# -# Generate dependencies in a form suitable for inclusion into a Makefile. -# The source filenames are provided in a file, one per line. Directories -# to be searched for the source files and for their dependencies are provided -# in another file, one per line. Output is written to STDOUT. -# -# For CPP type dependencies (lines beginning with #include) the dependency -# search is recursive. Only dependencies that are found in the specified -# directories are included. So, for example, the standard include file -# stdio.h would not be included as a dependency unless /usr/include were -# one of the specified directories to be searched. -# -# For Fortran module USE dependencies (lines beginning with a case -# insensitive "USE", possibly preceded by whitespace) the Fortran compiler -# must be able to access the .mod file associated with the .o file that -# contains the module. In order to correctly generate these dependencies -# two restrictions must be observed. -# 1) All modules must be contained in files that have the same base name as -# the module, in a case insensitive sense. This restriction implies that -# there can only be one module per file. -# 2) All modules that are to be contained in the dependency list must be -# contained in one of the source files in the list provided on the command -# line. -# The reason for the second restriction is that since the makefile doesn't -# contain rules to build .mod files the dependency takes the form of the .o -# file that contains the module. If a module is being used for which the -# source code is not available (e.g., a module from a library), then adding -# a .o dependency for that module is a mistake because make will attempt to -# build that .o file, and will fail if the source code is not available. -# -# Author: B. Eaton -# Climate Modelling Section, NCAR -# Feb 2001 - -use Getopt::Std; -use File::Basename; - -# Check for usage request. -@ARGV >= 2 or usage(); - -# Process command line. -my %opt = (); -getopts( "t:wmd:", \%opt ) or usage(); -my $filepath_arg = shift() or usage(); -my $srcfile_arg = shift() or usage(); -@ARGV == 0 or usage(); # Check that all args were processed. - -my $obj_dir; -if ( defined $opt{'t'} ) { $obj_dir = $opt{'t'}; } - -my $additional_obj = ""; -if ( defined $opt{'d'} ) { $additional_obj = $opt{'d'}; } - -open(FILEPATH, $filepath_arg) or die "Can't open $filepath_arg: $!\n"; -open(SRCFILES, $srcfile_arg) or die "Can't open $srcfile_arg: $!\n"; - -# Make list of paths to use when looking for files. -# Prepend "." so search starts in current directory. This default is for -# consistency with the way GNU Make searches for dependencies. -my @file_paths = ; -close(FILEPATH); -chomp @file_paths; -unshift(@file_paths,'.'); -foreach $dir (@file_paths) { # (could check that directories exist here) - $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name - ($dir) = glob $dir; # Expand tildes in path names. -} - -# Make list of files containing source code. -my @src = ; -close(SRCFILES); -chomp @src; - -my %module_files = (); - -#TODO: DRY this out -if ( defined $opt{'m'} ) { - # Attempt to parse each file for /^\s*module/ and extract module names - # for each file. - my ($f, $name, $path, $suffix, $mod); - my @suffixes = ('\.[fF]90', '\.[fF]' ); - foreach $f (@src) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - open(FH, $f) or die "Can't open $f: $!\n"; - while ( ) { - # Search for module definitions. - if ( /^\s*MODULE\s+(\w+)/i ) { - ($mod = $1) =~ tr/a-z/A-Z/; - # skip "module procedure foo" statements - if ( $mod ne "PROCEDURE" ) { - if ( defined $module_files{$mod} ) { - die "Duplicate definitions of module $mod in $module_files{$mod} and $name: $!\n"; - } - $module_files{$mod} = $path.$name; - } - } - } - close( FH ); - } -} else { - # For each file that may contain a Fortran module (*.[fF]90 *.[fF]) convert the - # file's basename to uppercase and use it as a hash key whose value is the file's - # basename. This allows fast identification of the files that contain modules. - # The only restriction is that the file's basename and the module name must match - # in a case insensitive way. - my ($f, $name, $path, $suffix, $mod); - my @suffixes = ('\.[fF]90', '\.[fF]' ); - foreach $f (@src) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - ($mod = $name) =~ tr/a-z/A-Z/; - $module_files{$mod} = $path.$name; - } -} - -#print STDERR "\%module_files\n"; -#while ( ($k,$v) = each %module_files ) { -# print STDERR "$k => $v\n"; -#} - -# Find module and include dependencies of the source files. -my ($file_path, $rmods, $rincs); -my %file_modules = (); -my %file_includes = (); -my @check_includes = (); -foreach $f ( @src ) { - - # Find the file in the seach path (@file_paths). - unless ($file_path = find_file($f)) { - if (defined $opt{'w'}) {print STDERR "$f not found\n";} - next; - } - - # Find the module and include dependencies. - ($rmods, $rincs) = find_dependencies( $file_path ); - - # Remove redundancies (a file can contain multiple procedures that have - # the same dependencies). - $file_modules{$f} = rm_duplicates($rmods); - $file_includes{$f} = rm_duplicates($rincs); - - # Make a list of all include files. - push @check_includes, @{$file_includes{$f}}; -} - -#print STDERR "\%file_modules\n"; -#while ( ($k,$v) = each %file_modules ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\@check_includes\n"; -#print STDERR "@check_includes\n"; - -# Find include file dependencies. -my %include_depends = (); -while (@check_includes) { - $f = shift @check_includes; - if (defined($include_depends{$f})) { next; } - - # Mark files not in path so they can be removed from the dependency list. - unless ($file_path = find_file($f)) { - $include_depends{$f} = -1; - next; - } - - # Find include file dependencies. - ($rmods, $include_depends{$f}) = find_dependencies($file_path); - - # Add included include files to the back of the check_includes list so - # that their dependencies can be found. - push @check_includes, @{$include_depends{$f}}; - - # Add included modules to the include_depends list. - if ( @$rmods ) { push @{$include_depends{$f}}, @$rmods; } -} - -#print STDERR "\%include_depends\n"; -#while ( ($k,$v) = each %include_depends ) { -# print STDERR (ref $v ? "$k => @$v\n" : "$k => $v\n"); -#} - -# Remove include file dependencies that are not in the Filepath. -my $i, $ii; -foreach $f (keys %include_depends) { - - unless (ref $include_depends{$f}) { next; } - $rincs = $include_depends{$f}; - unless (@$rincs) { next; } - $ii = 0; - $num_incs = @$rincs; - for ($i = 0; $i < $num_incs; ++$i) { - if ($include_depends{$$rincs[$ii]} == -1) { - splice @$rincs, $ii, 1; - next; - } - ++$ii; - } -} - -# Substitute the include file dependencies into the %file_includes lists. -foreach $f (keys %file_includes) { - my @expand_incs = (); - - # Initialize the expanded %file_includes list. - my $i; - unless (@{$file_includes{$f}}) { next; } - foreach $i (@{$file_includes{$f}}) { - push @expand_incs, $i unless ($include_depends{$i} == -1); - } - unless (@expand_incs) { - $file_includes{$f} = []; - next; - } - - # Expand - for ($i = 0; $i <= $#expand_incs; ++$i) { - push @expand_incs, @{ $include_depends{$expand_incs[$i]} }; - } - - $file_includes{$f} = rm_duplicates(\@expand_incs); -} - -#print STDERR "expanded \%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} - -# Print dependencies to STDOUT. -foreach $f (sort keys %file_modules) { - $f =~ /(.+)\./; - $target = "$1.o"; - if ( defined $opt{'t'} ) { $target = "$opt{'t'}/$1.o"; } - push(@{$file_modules{$f}},$additional_obj); - print "$target : $f @{noncircular(@{$file_modules{$f}},$target)} @{noncircular(@{$file_includes{$f}},$target)}\n"; -} - -#-------------------------------------------------------------------------------------- - -sub noncircular -{ - # Return an array identical to that represented by the first argument, except - # for the absence of the element specified by the second argument. - my @a=(); - my $x=pop(@_); - foreach (@_) { unless ($_ eq $x) { push(@a,$_) } }; - return \@a; -} - -sub find_dependencies { - - # Find dependencies of input file. - # Use'd Fortran 90 modules are returned in \@mods. - # Files that are "#include"d by the cpp preprocessor are returned in \@incs. - - my( $file ) = @_; - my( @mods, @incs ); - - open(FH, $file) or die "Can't open $file: $!\n"; - - while ( ) { - # Search for "#include" and strip filename when found. - if ( /^#include\s+[<"](.*)[>"]/ ) { - push @incs, $1; - } - # Search for module dependencies. - elsif ( /^\s*USE\s+(\w+)/i ) { - # Return dependency in the form of a .o version of the file that contains - # the module. - ($module = $1) =~ tr/a-z/A-Z/; - if ( defined $module_files{$module} ) { - if ( defined $obj_dir ) { - push @mods, "$obj_dir/$module_files{$module}.o"; - } else { - push @mods, "$module_files{$module}.o"; - } - } - } - } - close( FH ); - return (\@mods, \@incs); -} - -#-------------------------------------------------------------------------------------- - -sub find_file { - -# Search for the specified file in the list of directories in the global -# array @file_paths. Return the first occurance found, or the null string if -# the file is not found. - - my($file) = @_; - my($dir, $fname); - - foreach $dir (@file_paths) { - $fname = "$dir/$file"; - if ( -f $fname ) { return $fname; } - } - return ''; # file not found -} - -#-------------------------------------------------------------------------------------- - -sub rm_duplicates { - -# Return a list with duplicates removed. - - my ($in) = @_; # input arrary reference - my @out = (); - my $i; - my %h = (); - foreach $i (@$in) { - $h{$i} = ''; - } - @out = keys %h; - return \@out; -} - -#-------------------------------------------------------------------------------------- - -sub usage { - ($ProgName = $0) =~ s!.*/!!; # name of program - die <) target_link_libraries(stochastic_physics_wrapper PUBLIC fms stochastic_physics diff --git a/stochastic_physics/makefile b/stochastic_physics/makefile deleted file mode 100644 index c841571a4..000000000 --- a/stochastic_physics/makefile +++ /dev/null @@ -1,54 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 io ...) - $(info ) -endif -$(info $$ESMF_INC is [${ESMF_INC}]) - -LIBRARY = libstochastic_physics_wrapper.a - -FFLAGS += -I$(FMS_DIR) -I ../../stochastic_physics -I../ccpp/physics -I../ccpp/build/physics -I../atmos_cubed_sphere - -SRCS_f = - -SRCS_f90 = - -SRCS_F = - -SRCS_F90 = stochastic_physics_wrapper.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -.PHONY: clean -clean: - @echo "Cleaning io ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.o *.mod *.i90 *.lst *.i - -include ../conf/make.rules From 730ac5d8d334438dbef93e974b32cd7872d73404 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 26 Feb 2021 16:18:08 -0700 Subject: [PATCH 008/115] Remove inconsistencies in computation of air density with Thompson MP (#74) * Update .gitmodules and submodule pointer for ccpp-physics for code review and testing * Revert change to .gitmodules and update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index b2c7bd5ef..c82e50126 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b2c7bd5ef36141ff4888f93b84c4216e9ee2b9fb +Subproject commit c82e50126dbb2cd63b866411f3aca76e39da0eb2 From 4516ae0c84a03fb34f9034bd392aed6d03266c8d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 16 Mar 2021 05:54:09 -0600 Subject: [PATCH 009/115] Update thompson mp 20210213 (#567) for gsl/develop (#75) * Add logical convert_dry_rho for Thompson MP, hardcoded to false * Initialize all variables to NaN in ccpp-physics in DEBUG mode * Update submodule pointer for ccpp-physics --- ccpp/CMakeLists.txt | 2 +- ccpp/data/GFS_typedefs.F90 | 5 +++++ ccpp/data/GFS_typedefs.meta | 6 ++++++ ccpp/physics | 2 +- 4 files changed, 13 insertions(+), 2 deletions(-) diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index 760e09a8e..b1fc8ed42 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -109,7 +109,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -ftrapuv -traceback") set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -ftrapuv -traceback") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -check -check noarg_temp_created -check nopointer -warn -warn noerrors -fp-stack-check") - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fstack-protector-all -fpe0 -traceback -debug -ftrapuv") + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fstack-protector-all -fpe0 -traceback -debug -ftrapuv -init=snan,arrays") elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") if(LEGACY_INTEL) set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -debug minimal -fp-model strict -qoverride-limits -traceback") diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index f91fdc06f..82fbed80f 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -686,6 +686,11 @@ module GFS_typedefs !--- microphysical switch integer :: ncld !< choice of cloud scheme + logical :: convert_dry_rho = .false. !< flag for converting number concentrations from moist to dry + !< this flag will no longer be needed once the CCPP standard + !< names and the CCPP framework logic have been augmented to + !< automatically determine whether such conversions are necessary + !< and if yes, perform them; hardcoded to .false. for now !--- new microphysical switch integer :: imp_physics !< choice of microphysics scheme integer :: imp_physics_gfdl = 11 !< choice of GFDL microphysics scheme diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index f39248d4c..c039c0a38 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -2806,6 +2806,12 @@ units = count dimensions = () type = integer +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme diff --git a/ccpp/physics b/ccpp/physics index c82e50126..8507df659 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c82e50126dbb2cd63b866411f3aca76e39da0eb2 +Subproject commit 8507df659d7d37bae5a697d684b8046f19e2f36b From 1c59364b02ee887264da60a837ba0e18719329bb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 18 Mar 2021 14:07:56 -0600 Subject: [PATCH 010/115] Revert change to .gitmodules and update submodule pointer for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index f15e46e6c..4760351ce 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_master_20210316 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_master_20210316 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index 3ea13cac7..05e2a23c5 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 3ea13cac7a1dd9fe47a0f65ca0412c2c0b9944e1 +Subproject commit 05e2a23c59fe01fbb9dac94959c41543fee7a66c diff --git a/ccpp/physics b/ccpp/physics index b629944df..1488fa603 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b629944dfdc90970bbb1169c8057cb916aaaef43 +Subproject commit 1488fa603a48706926d4b8a33608146b0e4ad458 From 7fb4c3082a5e41a2c6315624f4798035190d41ae Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Mar 2021 20:12:52 +0000 Subject: [PATCH 011/115] &gfs_physics_nml print_diff_pgr=.true. will print per-timestep pgr change stats --- atmos_cubed_sphere | 2 +- atmos_model.F90 | 53 ++++++++++++++++++++++++++++++++++++- ccpp/data/GFS_typedefs.F90 | 17 +++++++++--- ccpp/data/GFS_typedefs.meta | 13 +++++++++ 4 files changed, 79 insertions(+), 6 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 306ff3137..28d54bda0 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 306ff31371e74694e5d9f4a57584295c7122b9ac +Subproject commit 28d54bda01edeaf4cb20a17baa6f595ae5d5a6aa diff --git a/atmos_model.F90 b/atmos_model.F90 index 3730da692..586c5cd0d 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -226,9 +226,14 @@ module atmos_model_mod subroutine update_atmos_radiation_physics (Atmos) !----------------------------------------------------------------------- + use fv_mp_mod, only: mp_reduce_sum, mp_reduce_maxloc, is_master + implicit none type (atmos_data_type), intent(in) :: Atmos !--- local variables--- - integer :: nb, jdat(8), rc, ierr + integer :: nb, jdat(8), rc, ierr, i, count + real(kind=8) :: pdiff, psum, pcount, maxabs, pmaxloc(5) ! must be kind=8 to match fv_mp_mod + integer :: isc, iec, jsc, jec, nlev, tile_num + logical :: p_hydro, hydro if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "statein driver" !--- get atmospheric state from the dynamic core @@ -358,6 +363,52 @@ subroutine update_atmos_radiation_physics (Atmos) endif + if(GFS_control%print_diff_pgr) then + if(.not. GFS_control%first_time_step) then + ! Get tile number: + call atmosphere_control_data (isc, iec, jsc, jec, nlev, p_hydro, hydro, tile_num) + pmaxloc(1) = tile_num + pmaxloc(2:5) = 0 + + ! Get pgr stats: + psum = 0 + pcount = 0 + maxabs = 0 + do nb = 1,ATM_block%nblks + count = size(GFS_data(nb)%Statein%pgr) + do i=1,count + pdiff = GFS_data(nb)%Statein%pgr(i)-GFS_data(nb)%Intdiag%old_pgr(i) + psum = psum+pdiff + if(abs(pdiff)>=maxabs) then + maxabs=abs(pdiff) + pmaxloc(2)=ATM_block%index(nb)%ii(i) + pmaxloc(3)=ATM_block%index(nb)%jj(i) + pmaxloc(4)=pdiff + pmaxloc(5)=GFS_data(nb)%Statein%pgr(i) + endif + enddo + pcount = pcount+count + enddo + + ! Sum pgr stats + call mp_reduce_sum(pcount) + call mp_reduce_sum(psum) + call mp_reduce_maxloc(maxabs,pmaxloc,size(pmaxloc)) + + if(is_master() .and. pcount>0) then +2933 format('At forecast hour ',F9.3,' mean pgr change is ',F15.7) +2934 format(' abs max change ',F15.7,' at tile=',I0,' i=',I0,' j=',I0) +2935 format(' value at that point ',F15.7) + print 2933, GFS_control%fhour, psum/pcount + print 2934, pmaxloc(4), nint(pmaxloc(1:3)) + print 2935, pmaxloc(5) + endif + endif + do nb = 1,ATM_block%nblks + GFS_data(nb)%Intdiag%old_pgr=GFS_data(nb)%Statein%pgr + enddo + endif + ! Update flag for first time step of time integration GFS_control%first_time_step = .false. diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 72e7ca565..cf2c3b7ce 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1141,9 +1141,10 @@ module GFS_typedefs integer :: npsdelt !< the index of surface air pressure at the previous timestep for Z-C MP in phy_f2d integer :: ncnvwind !< the index of surface wind enhancement due to convection for MYNN SFC and RAS CNV in phy f2d -!--- debug flag +!--- debug flags logical :: debug logical :: pre_rad !< flag for testing purpose + logical :: print_diff_pgr !< print average change in pgr every timestep (does not need debug flag) !--- variables modified at each time step integer :: ipt !< index for diagnostic printout point @@ -1670,6 +1671,7 @@ module GFS_typedefs !< for black carbon, organic carbon, and sulfur dioxide ( ug/m**2/s ) real (kind=kind_phys), pointer :: aecm (:,:) => null() !< instantaneous aerosol column mass densities for !< pm2.5, black carbon, organic carbon, sulfate, dust, sea salt ( g/m**2 ) + real (kind=kind_phys), pointer :: old_pgr(:) => null() !< pgr at last timestep ! Auxiliary output arrays for debugging real (kind=kind_phys), pointer :: aux2d(:,:) => null() !< auxiliary 2d arrays in output (for debugging) @@ -3375,9 +3377,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: iau_filter_increments = .false. !< filter IAU increments logical :: iau_drymassfixer = .false. !< IAU dry mass fixer -!--- debug flag +!--- debug flags logical :: debug = .false. logical :: pre_rad = .false. !< flag for testing purpose + logical :: print_diff_pgr = .false. !< print average change in pgr every timestep ! max and min lon and lat for critical relative humidity integer :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 @@ -3497,7 +3500,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & iau_delthrs,iaufhrs,iau_inc_files,iau_filter_increments, & iau_drymassfixer, & !--- debug options - debug, pre_rad, & + debug, pre_rad, print_diff_pgr, & !--- parameter range for critical relative humidity max_lon, max_lat, min_lon, min_lat, rhcmax, & phys_version, & @@ -4186,9 +4189,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%iau_drymassfixer = iau_drymassfixer if(Model%me==0) print *,' model init,iaufhrs=',Model%iaufhrs -!--- debug flag +!--- debug flags Model%debug = debug Model%pre_rad = pre_rad + Model%print_diff_pgr = print_diff_pgr !--- tracer handling Model%ntrac = size(tracer_names) @@ -5593,6 +5597,11 @@ subroutine diag_create (Diag, IM, Model) ! logical, save :: linit + if(Model%print_diff_pgr) then + allocate(Diag%old_pgr(IM)) + Diag%old_pgr = clear_val + endif + !--- Radiation allocate (Diag%fluxr (IM,Model%nfxr)) allocate (Diag%topfsw (IM)) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 3b1019119..86ba37f8c 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -4612,6 +4612,12 @@ units = flag dimensions = () type = logical +[print_diff_pgr] + standard_name = flag_to_print_pgr_differences_every_timestep + long_name = flag to print pgr differences every timestep + units = flag + dimensions = () + type = logical [ipt] standard_name = index_for_diagnostic_printout long_name = horizontal index for point used for diagnostic printout @@ -7362,6 +7368,13 @@ type = real kind = kind_phys active = (number_of_2d_auxiliary_arrays > 0) +[old_pgr] + standard_name = surface_air_pressure_from_previous_timestep + long_name = surface air pressure from previous timestep + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys ######################################################################## [ccpp-table-properties] From c19100b0693767740a87b66db03790ffa072dc9a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Mar 2021 20:29:00 +0000 Subject: [PATCH 012/115] point to sam's repository for atmos_cubed_sphere --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4760351ce..8d222a4bb 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,7 +1,7 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere - branch = dev/emc + url = https://github.com/SamuelTrahanNOAA/GFDL_atmos_cubed_sphere + branch = feature/per-timestep-pgr-like-wrf [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NOAA-GSL/ccpp-framework From 6f9299bb1793ad0fe21f5266c6ad16cab6e96e49 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Mar 2021 21:32:56 +0000 Subject: [PATCH 013/115] Add units and lat/lon to per-timestep pgr stats --- atmos_model.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 586c5cd0d..c5021502c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -231,7 +231,7 @@ subroutine update_atmos_radiation_physics (Atmos) type (atmos_data_type), intent(in) :: Atmos !--- local variables--- integer :: nb, jdat(8), rc, ierr, i, count - real(kind=8) :: pdiff, psum, pcount, maxabs, pmaxloc(5) ! must be kind=8 to match fv_mp_mod + real(kind=8) :: pdiff, psum, pcount, maxabs, pmaxloc(7) ! must be kind=8 to match fv_mp_mod integer :: isc, iec, jsc, jec, nlev, tile_num logical :: p_hydro, hydro @@ -381,10 +381,9 @@ subroutine update_atmos_radiation_physics (Atmos) psum = psum+pdiff if(abs(pdiff)>=maxabs) then maxabs=abs(pdiff) - pmaxloc(2)=ATM_block%index(nb)%ii(i) - pmaxloc(3)=ATM_block%index(nb)%jj(i) - pmaxloc(4)=pdiff - pmaxloc(5)=GFS_data(nb)%Statein%pgr(i) + pmaxloc(2:3)=(/ ATM_block%index(nb)%ii(i), ATM_block%index(nb)%jj(i) /) + pmaxloc(4:7)=(/ pdiff, GFS_data(nb)%Statein%pgr(i), & + GFS_data(nb)%Grid%xlat(i), GFS_data(nb)%Grid%xlon(i) /) endif enddo pcount = pcount+count @@ -396,12 +395,12 @@ subroutine update_atmos_radiation_physics (Atmos) call mp_reduce_maxloc(maxabs,pmaxloc,size(pmaxloc)) if(is_master() .and. pcount>0) then -2933 format('At forecast hour ',F9.3,' mean pgr change is ',F15.7) -2934 format(' abs max change ',F15.7,' at tile=',I0,' i=',I0,' j=',I0) -2935 format(' value at that point ',F15.7) +2933 format('At forecast hour ',F9.3,' mean pgr change is ',F15.7,' Pa') +2934 format(' abs max change ',F15.7,' Pa at tile=',I0,' i=',I0,' j=',I0) +2935 format(' value at that point ',F15.7,' Pa lat=',F12.6,' lon=',F12.6) print 2933, GFS_control%fhour, psum/pcount print 2934, pmaxloc(4), nint(pmaxloc(1:3)) - print 2935, pmaxloc(5) + print 2935, pmaxloc(5), pmaxloc(6:7)*57.29577951308232 ! 180/pi endif endif do nb = 1,ATM_block%nblks From 1d47548f7f779fb812a3c5882442788e9896dc37 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Mar 2021 22:22:10 +0000 Subject: [PATCH 014/115] Rebase atmos_cubed_sphere to NOAA-GFDL dev/emc branch --- .gitmodules | 2 +- atmos_cubed_sphere | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 8d222a4bb..193c0a044 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,7 +1,7 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere url = https://github.com/SamuelTrahanNOAA/GFDL_atmos_cubed_sphere - branch = feature/per-timestep-pgr-like-wrf + branch = feature/per-timestep-pgr-like-wrf-rebase-gfdl [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NOAA-GSL/ccpp-framework diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 28d54bda0..0b4433452 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 28d54bda01edeaf4cb20a17baa6f595ae5d5a6aa +Subproject commit 0b4433452e4ca83039601a94d70a888ae6e5dc2b From cd31df5fa54b100dbb4057b264f7e9db4a4f30b0 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Mar 2021 23:03:16 +0000 Subject: [PATCH 015/115] Print mean pgr change as hPa/hr and other pgr data as bars. --- atmos_model.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index c5021502c..ddcc8a206 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -231,7 +231,7 @@ subroutine update_atmos_radiation_physics (Atmos) type (atmos_data_type), intent(in) :: Atmos !--- local variables--- integer :: nb, jdat(8), rc, ierr, i, count - real(kind=8) :: pdiff, psum, pcount, maxabs, pmaxloc(7) ! must be kind=8 to match fv_mp_mod + real(kind=8) :: to_hpa, pdiff, psum, pcount, maxabs, pmaxloc(7) ! must be kind=8 to match fv_mp_mod integer :: isc, iec, jsc, jec, nlev, tile_num logical :: p_hydro, hydro @@ -395,12 +395,13 @@ subroutine update_atmos_radiation_physics (Atmos) call mp_reduce_maxloc(maxabs,pmaxloc,size(pmaxloc)) if(is_master() .and. pcount>0) then -2933 format('At forecast hour ',F9.3,' mean pgr change is ',F15.7,' Pa') -2934 format(' abs max change ',F15.7,' Pa at tile=',I0,' i=',I0,' j=',I0) -2935 format(' value at that point ',F15.7,' Pa lat=',F12.6,' lon=',F12.6) - print 2933, GFS_control%fhour, psum/pcount - print 2934, pmaxloc(4), nint(pmaxloc(1:3)) - print 2935, pmaxloc(5), pmaxloc(6:7)*57.29577951308232 ! 180/pi + to_hpa = 3600.0/GFS_control%dtp * 1.0/100.0 ! convert Pa/timestep to hPa/hour +2933 format('At forecast hour ',F9.3,' mean pgr change is ',F16.8,' hPa/hr') +2934 format(' abs max change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) +2935 format(' pgr at that point',F15.10,' bar lat=',F12.6,' lon=',F12.6) + print 2933, GFS_control%fhour, psum/pcount*to_hpa + print 2934, pmaxloc(4)*1e-5, nint(pmaxloc(1:3)) + print 2935, pmaxloc(5)*1e-5, pmaxloc(6:7)*57.29577951308232 ! 180/pi endif endif do nb = 1,ATM_block%nblks From 84c9f0b0d7eae4916bea0546ffab8f15069eec1f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 26 Mar 2021 16:30:08 +0000 Subject: [PATCH 016/115] Remove changes from atmos_cubed_sphere and simplify atmos_model.F90 changes. --- .gitmodules | 4 +- atmos_cubed_sphere | 2 +- atmos_model.F90 | 94 ++++++++++++++++++++++++++++++++-------------- 3 files changed, 69 insertions(+), 31 deletions(-) diff --git a/.gitmodules b/.gitmodules index 193c0a044..4760351ce 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,7 +1,7 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/SamuelTrahanNOAA/GFDL_atmos_cubed_sphere - branch = feature/per-timestep-pgr-like-wrf-rebase-gfdl + url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere + branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NOAA-GSL/ccpp-framework diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 0b4433452..306ff3137 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 0b4433452e4ca83039601a94d70a888ae6e5dc2b +Subproject commit 306ff31371e74694e5d9f4a57584295c7122b9ac diff --git a/atmos_model.F90 b/atmos_model.F90 index ddcc8a206..eff951aa0 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -226,14 +226,10 @@ module atmos_model_mod subroutine update_atmos_radiation_physics (Atmos) !----------------------------------------------------------------------- - use fv_mp_mod, only: mp_reduce_sum, mp_reduce_maxloc, is_master implicit none type (atmos_data_type), intent(in) :: Atmos !--- local variables--- - integer :: nb, jdat(8), rc, ierr, i, count - real(kind=8) :: to_hpa, pdiff, psum, pcount, maxabs, pmaxloc(7) ! must be kind=8 to match fv_mp_mod - integer :: isc, iec, jsc, jec, nlev, tile_num - logical :: p_hydro, hydro + integer :: nb, jdat(8), rc, ierr if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "statein driver" !--- get atmospheric state from the dynamic core @@ -363,17 +359,58 @@ subroutine update_atmos_radiation_physics (Atmos) endif + ! Per-timestep diagnostics must be after physics but before + ! flagging the first timestep. + call atmos_timestep_diagnostics(Atmos) + + ! Update flag for first time step of time integration + GFS_control%first_time_step = .false. + +!----------------------------------------------------------------------- + end subroutine update_atmos_radiation_physics +! + + +!####################################################################### +! +! +! +! Calculates per-timestep, domain-wide, diagnostic, information and +! prints to stdout from master rank. Must be called after physics +! update but before first_time_step flag is cleared. +! + +! + +! +! 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 atmos_timestep_diagnostics(Atmos) + use mpi + implicit none + type (atmos_data_type), intent(in) :: Atmos +!--- local variables--- + integer :: i, nb, count, ierror + ! double precision ensures ranks and sums are not truncated + ! regardless of compilation settings + double precision :: pdiff, psum, pcount, maxabs, pmaxloc(7) + double precision :: sendbuf(2), recvbuf(2), global_average + if(GFS_control%print_diff_pgr) then if(.not. GFS_control%first_time_step) then - ! Get tile number: - call atmosphere_control_data (isc, iec, jsc, jec, nlev, p_hydro, hydro, tile_num) - pmaxloc(1) = tile_num - pmaxloc(2:5) = 0 - - ! Get pgr stats: - psum = 0 - pcount = 0 - maxabs = 0 + pmaxloc = 0.0d0 + recvbuf = 0.0d0 + psum = 0.0d0 + pcount = 0.0d0 + maxabs = 0.0d0 + + ! Put pgr stats in pmaxloc, psum, and pcount: + pmaxloc(1) = GFS_Control%tile_num do nb = 1,ATM_block%nblks count = size(GFS_data(nb)%Statein%pgr) do i=1,count @@ -389,34 +426,35 @@ subroutine update_atmos_radiation_physics (Atmos) pcount = pcount+count enddo - ! Sum pgr stats - call mp_reduce_sum(pcount) - call mp_reduce_sum(psum) - call mp_reduce_maxloc(maxabs,pmaxloc,size(pmaxloc)) + ! Sum pgr stats from psum/pcount and convert to hPa/hour global avg: + sendbuf(1:2) = (/ psum, pcount /) + call MPI_Allreduce(sendbuf,recvbuf,2,MPI_DOUBLE_PRECISION,MPI_SUM,GFS_Control%communicator,ierror) + global_average = recvbuf(1)/recvbuf(2) * 36.0d0/GFS_control%dtp + + ! Get the pmaxloc for the global maximum: + sendbuf(1:2) = (/ maxabs, dble(GFS_Control%me) /) + call MPI_Allreduce(sendbuf,recvbuf,1,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,GFS_Control%communicator,ierror) + call MPI_Bcast(pmaxloc,size(pmaxloc),MPI_DOUBLE_PRECISION,nint(recvbuf(2)),GFS_Control%communicator,ierror) - if(is_master() .and. pcount>0) then - to_hpa = 3600.0/GFS_control%dtp * 1.0/100.0 ! convert Pa/timestep to hPa/hour + if(GFS_Control%me == GFS_Control%master) then 2933 format('At forecast hour ',F9.3,' mean pgr change is ',F16.8,' hPa/hr') 2934 format(' abs max change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) 2935 format(' pgr at that point',F15.10,' bar lat=',F12.6,' lon=',F12.6) - print 2933, GFS_control%fhour, psum/pcount*to_hpa - print 2934, pmaxloc(4)*1e-5, nint(pmaxloc(1:3)) - print 2935, pmaxloc(5)*1e-5, pmaxloc(6:7)*57.29577951308232 ! 180/pi + print 2933, GFS_control%fhour, global_average + print 2934, pmaxloc(4)*1d-5, nint(pmaxloc(1:3)) + print 2935, pmaxloc(5)*1d-5, pmaxloc(6:7)*57.29577951308232d0 ! 180/pi endif endif + ! old_pgr is updated every timestep, including the first one where stats aren't printed: do nb = 1,ATM_block%nblks GFS_data(nb)%Intdiag%old_pgr=GFS_data(nb)%Statein%pgr enddo endif - - ! Update flag for first time step of time integration - GFS_control%first_time_step = .false. !----------------------------------------------------------------------- - end subroutine update_atmos_radiation_physics +end subroutine atmos_timestep_diagnostics ! - !####################################################################### ! ! From 591edc0179ffe05090dd46eef634773560999319 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 26 Mar 2021 18:51:26 +0000 Subject: [PATCH 017/115] print mean abs change instead of mean change in pgr --- atmos_model.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index eff951aa0..cdcf7ba0c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -398,7 +398,7 @@ subroutine atmos_timestep_diagnostics(Atmos) integer :: i, nb, count, ierror ! double precision ensures ranks and sums are not truncated ! regardless of compilation settings - double precision :: pdiff, psum, pcount, maxabs, pmaxloc(7) + double precision :: pdiff, psum, pcount, maxabs, pmaxloc(7), adiff double precision :: sendbuf(2), recvbuf(2), global_average if(GFS_control%print_diff_pgr) then @@ -415,9 +415,10 @@ subroutine atmos_timestep_diagnostics(Atmos) count = size(GFS_data(nb)%Statein%pgr) do i=1,count pdiff = GFS_data(nb)%Statein%pgr(i)-GFS_data(nb)%Intdiag%old_pgr(i) - psum = psum+pdiff - if(abs(pdiff)>=maxabs) then - maxabs=abs(pdiff) + adiff = abs(pdiff) + psum = psum+adiff + if(adiff>=maxabs) then + maxabs=adiff pmaxloc(2:3)=(/ ATM_block%index(nb)%ii(i), ATM_block%index(nb)%jj(i) /) pmaxloc(4:7)=(/ pdiff, GFS_data(nb)%Statein%pgr(i), & GFS_data(nb)%Grid%xlat(i), GFS_data(nb)%Grid%xlon(i) /) @@ -437,7 +438,7 @@ subroutine atmos_timestep_diagnostics(Atmos) call MPI_Bcast(pmaxloc,size(pmaxloc),MPI_DOUBLE_PRECISION,nint(recvbuf(2)),GFS_Control%communicator,ierror) if(GFS_Control%me == GFS_Control%master) then -2933 format('At forecast hour ',F9.3,' mean pgr change is ',F16.8,' hPa/hr') +2933 format('At forecast hour ',F9.3,' mean abs pgr change is ',F16.8,' hPa/hr') 2934 format(' abs max change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) 2935 format(' pgr at that point',F15.10,' bar lat=',F12.6,' lon=',F12.6) print 2933, GFS_control%fhour, global_average From ad2f849e68ebdb8c163fc04e152831b9bd489e74 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 31 Mar 2021 16:35:58 -0600 Subject: [PATCH 018/115] Update .gitmodules and submodule pointers for ccpp-framework and ccpp-physics for code review and testing --- .gitmodules | 12 ++++++++---- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4760351ce..7fe3274ad 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,13 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NOAA-GSL/ccpp-framework - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-framework + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-framework + branch = update_gsl_develop_from_master_20210331 [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsl_develop_from_master_20210331 diff --git a/ccpp/framework b/ccpp/framework index 05e2a23c5..3e885e6b4 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 05e2a23c59fe01fbb9dac94959c41543fee7a66c +Subproject commit 3e885e6b4cf55edcd49965a0a88aaad6442d40f2 diff --git a/ccpp/physics b/ccpp/physics index 1488fa603..e09c3b26c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 1488fa603a48706926d4b8a33608146b0e4ad458 +Subproject commit e09c3b26c738c48d635f0d8f96cbafd0b3b1c000 From e51884b6a317f60addf432ba1710f32885f63947 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 31 Mar 2021 20:12:28 -0600 Subject: [PATCH 019/115] Revert change to .gitmodules and update submodule pointers for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index bff54b022..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_master_20210331 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_master_20210331 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index 3e885e6b4..ed43d983c 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 3e885e6b4cf55edcd49965a0a88aaad6442d40f2 +Subproject commit ed43d983c62a1825c1533ba5978dab61635d0727 diff --git a/ccpp/physics b/ccpp/physics index e09c3b26c..21df4016f 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e09c3b26c738c48d635f0d8f96cbafd0b3b1c000 +Subproject commit 21df4016f4d435ed531b773e80b462d57e1f4213 From b92eeebde9e3505e617b732734f698159d996abc Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 1 Apr 2021 16:26:36 +0000 Subject: [PATCH 020/115] clarify one print --- atmos_model.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index cdcf7ba0c..6c9495042 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -439,7 +439,7 @@ subroutine atmos_timestep_diagnostics(Atmos) if(GFS_Control%me == GFS_Control%master) then 2933 format('At forecast hour ',F9.3,' mean abs pgr change is ',F16.8,' hPa/hr') -2934 format(' abs max change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) +2934 format(' max abs change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) 2935 format(' pgr at that point',F15.10,' bar lat=',F12.6,' lon=',F12.6) print 2933, GFS_control%fhour, global_average print 2934, pmaxloc(4)*1d-5, nint(pmaxloc(1:3)) From 51d7265586f18ab6f5a64cb1abf4325dc4a6ed84 Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Mon, 12 Apr 2021 17:50:01 -0400 Subject: [PATCH 021/115] More 3D diagnostic tendencies (#76) Add diagnostic tendencies for all tracers. Move all d*3dt variables into a 4D sparse array stored as `dtend(i,k,dtidx(tracer,process))` to reduce memory usage. --- atmos_model.F90 | 48 ++- ccpp/data/GFS_typedefs.F90 | 547 +++++++++++++++++++++++-- ccpp/data/GFS_typedefs.meta | 483 ++++++++-------------- ccpp/driver/GFS_diagnostics.F90 | 566 ++++---------------------- ccpp/physics | 2 +- ccpp/suites/suite_FV3_RRFS_v1beta.xml | 1 + io/FV3GFS_io.F90 | 32 -- 7 files changed, 790 insertions(+), 889 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 506fcee00..18f99484f 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -229,6 +229,7 @@ subroutine update_atmos_radiation_physics (Atmos) implicit none type (atmos_data_type), intent(in) :: Atmos !--- local variables--- + integer :: idtend, itrac integer :: nb, jdat(8), rc, ierr if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "statein driver" @@ -283,21 +284,40 @@ subroutine update_atmos_radiation_physics (Atmos) ! Calculate total non-physics tendencies by substracting old IPD Stateout ! variables from new/updated IPD Statein variables (gives the tendencies ! due to anything else than physics) - if (GFS_control%ldiag3d) then - do nb = 1,Atm_block%nblks - GFS_data(nb)%Intdiag%du3dt(:,:,8) = GFS_data(nb)%Intdiag%du3dt(:,:,8) & - + (GFS_data(nb)%Statein%ugrs - GFS_data(nb)%Stateout%gu0) - GFS_data(nb)%Intdiag%dv3dt(:,:,8) = GFS_data(nb)%Intdiag%dv3dt(:,:,8) & - + (GFS_data(nb)%Statein%vgrs - GFS_data(nb)%Stateout%gv0) - GFS_data(nb)%Intdiag%dt3dt(:,:,11) = GFS_data(nb)%Intdiag%dt3dt(:,:,11) & - + (GFS_data(nb)%Statein%tgrs - GFS_data(nb)%Stateout%gt0) - enddo - if (GFS_control%qdiag3d) then + if (GFS_Control%ldiag3d) then + idtend = GFS_Control%dtidx(GFS_Control%index_of_x_wind,GFS_Control%index_of_process_non_physics) + if(idtend>=1) then + do nb = 1,Atm_block%nblks + GFS_data(nb)%Intdiag%dtend(:,:,idtend) = GFS_data(nb)%Intdiag%dtend(:,:,idtend) & + + (GFS_data(nb)%Statein%ugrs - GFS_data(nb)%Stateout%gu0) + enddo + endif + + idtend = GFS_Control%dtidx(GFS_Control%index_of_y_wind,GFS_Control%index_of_process_non_physics) + if(idtend>=1) then + do nb = 1,Atm_block%nblks + GFS_data(nb)%Intdiag%dtend(:,:,idtend) = GFS_data(nb)%Intdiag%dtend(:,:,idtend) & + + (GFS_data(nb)%Statein%vgrs - GFS_data(nb)%Stateout%gv0) + enddo + endif + + idtend = GFS_Control%dtidx(GFS_Control%index_of_temperature,GFS_Control%index_of_process_non_physics) + if(idtend>=1) then do nb = 1,Atm_block%nblks - GFS_data(nb)%Intdiag%dq3dt(:,:,12) = GFS_data(nb)%Intdiag%dq3dt(:,:,12) & - + (GFS_data(nb)%Statein%qgrs(:,:,GFS_control%ntqv) - GFS_data(nb)%Stateout%gq0(:,:,GFS_control%ntqv)) - GFS_data(nb)%Intdiag%dq3dt(:,:,13) = GFS_data(nb)%Intdiag%dq3dt(:,:,13) & - + (GFS_data(nb)%Statein%qgrs(:,:,GFS_control%ntoz) - GFS_data(nb)%Stateout%gq0(:,:,GFS_control%ntoz)) + GFS_data(nb)%Intdiag%dtend(:,:,idtend) = GFS_data(nb)%Intdiag%dtend(:,:,idtend) & + + (GFS_data(nb)%Statein%tgrs - GFS_data(nb)%Stateout%gt0) + enddo + endif + + if (GFS_Control%qdiag3d) then + do itrac=1,GFS_Control%ntrac + idtend = GFS_Control%dtidx(itrac+100,GFS_Control%index_of_process_non_physics) + if(idtend>=1) then + do nb = 1,Atm_block%nblks + GFS_data(nb)%Intdiag%dtend(:,:,idtend) = GFS_data(nb)%Intdiag%dtend(:,:,idtend) & + + (GFS_data(nb)%Statein%qgrs(:,:,itrac) - GFS_data(nb)%Stateout%gq0(:,:,itrac)) + enddo + endif enddo endif endif diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 96a7aaa36..29c8cf5a5 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -521,11 +521,30 @@ module GFS_typedefs real (kind=kind_phys), pointer :: dkt (:,:) => null() !< instantaneous dkt diffusion coefficient for temperature (m**2/s) real (kind=kind_phys), pointer :: qci_conv(:,:) => null() !< convective cloud condesate after rainout - contains procedure :: create => coupling_create !< allocate array data end type GFS_coupling_type +!---------------------------------------------------------------- +! dtend_var_label +! Information about first dimension of dtidx +!---------------------------------------------------------------- + type dtend_var_label + character(len=20) :: name + character(len=44) :: desc + character(len=32) :: unit + end type dtend_var_label + +!---------------------------------------------------------------- +! dtend_process_label +! Information about second dimension of dtidx +!---------------------------------------------------------------- + type dtend_process_label + character(len=20) :: name + character(len=44) :: desc + logical :: time_avg + character(len=20) :: mod_name + end type dtend_process_label !---------------------------------------------------------------------------------- ! GFS_control_type @@ -1093,7 +1112,41 @@ module GFS_typedefs character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core integer :: ntrac !< number of tracers integer :: ntracp1 !< number of tracers plus one + integer :: ntracp100 !< number of tracers plus one hundred integer :: nqrimef !< tracer index for mass weighted rime factor + + integer, pointer :: dtidx(:,:) => null() !< index in outermost dimension of dtend + integer :: ndtend !< size of outermost dimension of dtend + type(dtend_var_label), pointer :: dtend_var_labels(:) => null() !< information about first dim of dtidx + type(dtend_process_label), pointer :: dtend_process_labels(:) => null() !< information about second dim of dtidx + + ! Indices within inner dimension of dtidx for things that are not tracers: + integer :: index_of_temperature !< temperature in dtidx + integer :: index_of_x_wind !< x wind in dtidx + integer :: index_of_y_wind !< y wind in dtidx + + ! Indices within outer dimension of dtidx: + integer :: nprocess !< maximum value of the below index_for_process_ variables + integer :: nprocess_summed !< number of causes in dtend(:,:,dtidx(...)) to sum to make the physics tendency + integer :: index_of_process_pbl !< tracer changes caused by PBL scheme + integer :: index_of_process_dcnv !< tracer changes caused by deep convection scheme + integer :: index_of_process_scnv !< tracer changes caused by shallow convection scheme + integer :: index_of_process_mp !< tracer changes caused by microphysics scheme + integer :: index_of_process_prod_loss !< tracer changes caused by ozone production and loss + integer :: index_of_process_ozmix !< tracer changes caused by ozone mixing ratio + integer :: index_of_process_temp !< tracer changes caused by temperature + integer :: index_of_process_longwave !< tracer changes caused by long wave radiation + integer :: index_of_process_shortwave !< tracer changes caused by short wave radiation + integer :: index_of_process_orographic_gwd !< tracer changes caused by orographic gravity wave drag + integer :: index_of_process_rayleigh_damping !< tracer changes caused by Rayleigh damping + integer :: index_of_process_nonorographic_gwd !< tracer changes caused by convective gravity wave drag + integer :: index_of_process_overhead_ozone !< tracer changes caused by overhead ozone column + integer :: index_of_process_conv_trans !< tracer changes caused by convective transport + integer :: index_of_process_physics !< tracer changes caused by physics schemes + integer :: index_of_process_non_physics !< tracer changes caused by everything except physics schemes + integer :: index_of_process_photochem !< all changes to ozone + logical, pointer :: is_photochem(:) => null()!< flags for which processes should be summed as photochemical + integer :: ntqv !< tracer index for water vapor (specific humidity) integer :: ntoz !< tracer index for ozone mixing ratio integer :: ntcw !< tracer index for cloud condensate (or liquid water) @@ -1410,6 +1463,7 @@ module GFS_typedefs 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 @@ -1544,10 +1598,12 @@ module GFS_typedefs real (kind=kind_phys), pointer :: shum_wts(:,:) => null() !< real (kind=kind_phys), pointer :: sfc_wts(:,:) => null() !< real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() !< u momentum change due to physics - real (kind=kind_phys), pointer :: dv3dt (:,:,:) => null() !< v momentum change due to physics - real (kind=kind_phys), pointer :: dt3dt (:,:,:) => null() !< temperature change due to physics - real (kind=kind_phys), pointer :: dq3dt (:,:,:) => null() !< moisture change due to physics + + ! dtend/dtidxt: Multitudenous 3d tendencies in a 4D array: (i,k,0:ntrac,nprocess) + ! Sparse in outermost two dimensions. dtidx(1:100+ntrac,nprocess) maps to dtend + ! outer dimension index. + real (kind=kind_phys), pointer :: dtend (:,:,:) => null() !< tracer changes due to physics + real (kind=kind_phys), pointer :: refdmax (:) => null() !< max hourly 1-km agl reflectivity real (kind=kind_phys), pointer :: refdmax263k(:) => null() !< max hourly -10C reflectivity real (kind=kind_phys), pointer :: t02max (:) => null() !< max hourly 2m T @@ -2126,6 +2182,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: f_rimef (:,:) => null() !< real (kind=kind_phys), pointer :: cwm (:,:) => null() !< + !-- 3D diagnostics + integer :: rtg_ozone_index contains procedure :: create => interstitial_create !< allocate array data @@ -2959,6 +3017,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: ldiag3d = .false. !< flag for 3d diagnostic fields logical :: qdiag3d = .false. !< flag for 3d tracer diagnostic fields logical :: lssav = .false. !< logical flag for storing diagnostics + integer, parameter :: pat_len = 60, pat_count=100 !< dimensions of dtend_select + character(len=pat_len) :: dtend_select(pat_count) !< fglob_list() patterns to decide which 3d diagnostic fields to enable integer :: naux2d = 0 !< number of auxiliary 2d arrays to output (for debugging) integer :: naux3d = 0 !< number of auxiliary 3d arrays to output (for debugging) logical :: aux2d_time_avg(1:naux2dmax) = .false. !< flags for time averaging of auxiliary 2d arrays @@ -3411,8 +3471,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & NAMELIST /gfs_physics_nml/ & !--- general parameters - fhzero, ldiag3d, qdiag3d, lssav, naux2d, naux3d, & - aux2d_time_avg, aux3d_time_avg, fhcyc, & + fhzero, ldiag3d, qdiag3d, lssav, naux2d, dtend_select, & + naux3d, aux2d_time_avg, aux3d_time_avg, fhcyc, & thermodyn_id, sfcpress_id, & !--- coupling parameters cplflx, cplwav, cplwav2atm, cplchm, lsidea, & @@ -3527,6 +3587,16 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- convective clouds integer :: ncnvcld3d = 0 !< number of convective 3d clouds fields + integer :: itrac, ipat, ichem + logical :: have_pbl, have_dcnv, have_scnv, have_mp, have_oz_phys, have_samf, have_pbl_edmf + character(len=20) :: namestr + character(len=44) :: descstr + + ! dtend selection: default is to match all variables: + dtend_select(1)='*' + do ipat=2,pat_count + dtend_select(ipat)=' ' + enddo !--- read in the namelist #ifdef INTERNAL_FILE_NML @@ -3567,7 +3637,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%fhzero = fhzero Model%ldiag3d = ldiag3d Model%qdiag3d = qdiag3d - if (Model%qdiag3d .and. .not. Model%ldiag3d) then + if (qdiag3d .and. .not. ldiag3d) then write(0,*) 'Logic error in GFS_typedefs.F90: qdiag3d requires ldiag3d' stop endif @@ -3608,9 +3678,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if(me==master) & write(0,*) 'FLAG: imfshalcnv_gf so scnv not generic' Model%flag_for_scnv_generic_tend=.false. - ! else if(imfshalcnv == Model%imfshalcnv_samf) then - ! write(0,*) 'FLAG: imfshalcnv_samf so scnv not generic' - ! Model%flag_for_scnv_generic_tend=.false. elseif(me==master) then write(0,*) 'NO FLAG: scnv is generic' endif @@ -3619,9 +3686,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if(me==master) & write(0,*) 'FLAG: imfdeepcnv_gf so dcnv not generic' Model%flag_for_dcnv_generic_tend=.false. - ! else if(imfdeepcnv == Model%imfdeepcnv_samf) then - ! write(0,*) 'FLAG: imfdeepcnv_samf so dcnv not generic' - ! Model%flag_for_dcnv_generic_tend=.false. elseif(me==master) then write(0,*) 'NO FLAG: dcnv is generic' endif @@ -4209,6 +4273,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- tracer handling Model%ntrac = size(tracer_names) Model%ntracp1 = Model%ntrac + 1 + Model%ntracp100 = Model%ntrac + 100 allocate (Model%tracer_names(Model%ntrac)) Model%tracer_names(:) = tracer_names(:) Model%ntqv = 1 @@ -4288,6 +4353,228 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & enddo endif + ! Tracer diagnostics indices and dimension size, which must be in + ! Model to be forwarded to the right places. + + ! Individual processes: + Model%index_of_process_pbl = 1 + Model%index_of_process_dcnv = 2 + Model%index_of_process_scnv = 3 + Model%index_of_process_mp = 4 + Model%index_of_process_prod_loss = 5 + Model%index_of_process_ozmix = 6 + Model%index_of_process_temp = 7 + Model%index_of_process_overhead_ozone = 8 + Model%index_of_process_longwave = 9 + Model%index_of_process_shortwave = 10 + Model%index_of_process_orographic_gwd = 11 + Model%index_of_process_rayleigh_damping = 12 + Model%index_of_process_nonorographic_gwd = 13 + Model%index_of_process_conv_trans = 14 + + ! Number of processes to sum (last index of prior set) + Model%nprocess_summed = 14 + + ! Sums of other processes, which must be after nprocess_summed: + Model%index_of_process_physics = 15 + Model%index_of_process_non_physics = 16 + Model%index_of_process_photochem = 17 + + ! Total number of processes (last index of prior set) + Model%nprocess = 17 + + ! List which processes should be summed as photochemical: + allocate(Model%is_photochem(Model%nprocess)) + Model%is_photochem = .false. + Model%is_photochem(Model%index_of_process_prod_loss) = .true. + Model%is_photochem(Model%index_of_process_ozmix) = .true. + Model%is_photochem(Model%index_of_process_temp) = .true. + Model%is_photochem(Model%index_of_process_overhead_ozone) = .true. + + ! Non-tracers that appear in first dimension of dtidx: + Model%index_of_temperature = 10 + Model%index_of_x_wind = 11 + Model%index_of_y_wind = 12 + + ! Last index of outermost dimension of dtend + Model%ndtend = 0 + allocate(Model%dtidx(Model%ntracp100,Model%nprocess)) + Model%dtidx = -99 + + if(ldiag3d) then + ! Flags used to turn on or off tracer "causes" + have_pbl_edmf = Model%hybedmf .or. Model%satmedmf .or. do_mynnedmf + have_samf = Model%satmedmf .or. Model%trans_trac .or. Model%ras .or. Model%do_shoc + have_pbl = .true. + have_dcnv = Model%imfdeepcnv>=0 !Model%ras .or. Model%cscnv .or. Model%do_deep .or. Model%hwrf_samfdeep + have_scnv = Model%imfshalcnv>=0 !Model%shal_cnv + have_mp = Model%imp_physics>0 + have_oz_phys = Model%oz_phys .or. Model%oz_phys_2015 + + ! Increment idtend and fill dtidx: + allocate(Model%dtend_var_labels(Model%ntracp100)) + allocate(Model%dtend_process_labels(Model%nprocess)) + + call allocate_dtend_labels_and_causes(Model) + + ! Default names of tracers just in case later code does not initialize them: + do itrac=1,Model%ntrac + write(namestr,'("tracer",I0)') itrac + write(descstr,'("tracer ",I0," of ",I0)') itrac, Model%ntrac + call label_dtend_tracer(Model,100+itrac,trim(namestr),trim(descstr)) + enddo + + if(Model%ntchs>0) then + if(Model%ntchm>0) then + ! Chemical tracers are first so more specific tracer names + ! replace them. There is no straightforward way of getting + ! chemical tracer short names or descriptions, so we use + ! indices instead. + do ichem=Model%ntchs,Model%ntchs+Model%ntchm-1 + write(namestr,'("chem",I0)') ichem + write(descstr,'("chemical tracer ",I0," of ",I0)') ichem, Model%ntchm + call label_dtend_tracer(Model,100+ichem,trim(namestr),trim(descstr)) + enddo + endif + + ! More specific chemical tracer names: + call label_dtend_tracer(Model,100+Model%ntchs,'so2','sulfur dioxide concentration') + if(Model%ntchm>0) then + ! Need better descriptions of these. + call label_dtend_tracer(Model,100+Model%ntchm+Model%ntchs-1,'pp10','pp10 concentration') + + itrac=get_tracer_index(Model%tracer_names, 'DMS', Model%me, Model%master, Model%debug) + if(itrac>0) then + call label_dtend_tracer(Model,100+itrac,'DMS','DMS concentration') + endif + itrac=get_tracer_index(Model%tracer_names, 'msa', Model%me, Model%master, Model%debug) + if(itrac>0) then + call label_dtend_tracer(Model,100+itrac,'msa','msa concentration') + endif + endif + endif + + call label_dtend_tracer(Model,Model%index_of_temperature,'temp','temperature','K s-1') + call label_dtend_tracer(Model,Model%index_of_x_wind,'u','x wind','m s-2') + call label_dtend_tracer(Model,Model%index_of_y_wind,'v','y wind','m s-2') + + ! Other tracer names. These were taken from GFS_typedefs.F90 with descriptions from GFS_typedefs.meta + call label_dtend_tracer(Model,100+Model%ntqv,'qv','water vapor specific humidity') + call label_dtend_tracer(Model,100+Model%ntoz,'o3','ozone concentration') + call label_dtend_tracer(Model,100+Model%ntcw,'liq_wat','cloud condensate (or liquid water)') + call label_dtend_tracer(Model,100+Model%ntiw,'ice_wat','ice water') + call label_dtend_tracer(Model,100+Model%ntrw,'rainwat','rain water') + call label_dtend_tracer(Model,100+Model%ntsw,'snowwat','snow water') + call label_dtend_tracer(Model,100+Model%ntgl,'graupel','graupel') + call label_dtend_tracer(Model,100+Model%ntclamt,'cld_amt','cloud amount integer') + call label_dtend_tracer(Model,100+Model%ntlnc,'water_nc','liquid number concentration') + call label_dtend_tracer(Model,100+Model%ntinc,'ice_nc','ice number concentration') + call label_dtend_tracer(Model,100+Model%ntrnc,'rain_nc','rain number concentration') + call label_dtend_tracer(Model,100+Model%ntsnc,'snow_nc','snow number concentration') + call label_dtend_tracer(Model,100+Model%ntgnc,'graupel_nc','graupel number concentration') + call label_dtend_tracer(Model,100+Model%ntke,'sgs_tke','turbulent kinetic energy') + call label_dtend_tracer(Model,100+Model%nqrimef,'q_rimef','mass weighted rime factor') + call label_dtend_tracer(Model,100+Model%ntwa,'liq_aero','number concentration of water-friendly aerosols') + call label_dtend_tracer(Model,100+Model%ntia,'ice_aero','number concentration of ice-friendly aerosols') + call label_dtend_tracer(Model,100+Model%nto,'o_ion','oxygen ion concentration') + call label_dtend_tracer(Model,100+Model%nto2,'o2','oxygen concentration') + + call label_dtend_cause(Model,Model%index_of_process_pbl,'pbl','tendency due to PBL') + call label_dtend_cause(Model,Model%index_of_process_dcnv,'deepcnv','tendency due to deep convection') + call label_dtend_cause(Model,Model%index_of_process_scnv,'shalcnv','tendency due to shallow convection') + call label_dtend_cause(Model,Model%index_of_process_mp,'mp','tendency due to microphysics') + call label_dtend_cause(Model,Model%index_of_process_prod_loss,'prodloss','tendency due to production and loss rate') + call label_dtend_cause(Model,Model%index_of_process_ozmix,'o3mix','tendency due to ozone mixing ratio') + call label_dtend_cause(Model,Model%index_of_process_temp,'temp','tendency due to temperature') + call label_dtend_cause(Model,Model%index_of_process_overhead_ozone,'o3column','tendency due to overhead ozone column') + call label_dtend_cause(Model,Model%index_of_process_photochem,'photochem','tendency due to photochemical processes') + call label_dtend_cause(Model,Model%index_of_process_physics,'phys','tendency due to physics') + call label_dtend_cause(Model,Model%index_of_process_non_physics,'nophys','tendency due to non-physics processes', & + mod_name='gfs_dyn') + call label_dtend_cause(Model,Model%index_of_process_conv_trans,'cnvtrans','tendency due to convective transport') + call label_dtend_cause(Model,Model%index_of_process_longwave,'lw','tendency due to long wave radiation') + call label_dtend_cause(Model,Model%index_of_process_shortwave,'sw','tendency due to short wave radiation') + call label_dtend_cause(Model,Model%index_of_process_orographic_gwd,'orogwd','tendency due to orographic gravity wave drag') + call label_dtend_cause(Model,Model%index_of_process_rayleigh_damping,'rdamp','tendency due to Rayleigh damping') + call label_dtend_cause(Model,Model%index_of_process_nonorographic_gwd,'cnvgwd','tendency due to convective gravity wave drag') + + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_longwave) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_shortwave) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_mp,have_mp) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_orographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_rayleigh_damping) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_nonorographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_physics) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_non_physics) + + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_orographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_orographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_nonorographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_nonorographic_gwd) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_rayleigh_damping) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_rayleigh_damping) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_physics) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_physics) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_non_physics) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_non_physics) + + if(qdiag3d) then + if(have_samf) then + do itrac=1,Model%ntrac + if(itrac==Model%ntchs) exit ! remaining tracers are chemical + if(itrac==Model%ntke) cycle ! TKE is handled by convective transport (see below) + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_scnv,have_scnv) + enddo + else + call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,100+Model%ntcw,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,100+Model%ntcw,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,100+Model%ntiw,Model%index_of_process_dcnv,have_dcnv) + call fill_dtidx(Model,dtend_select,100+Model%ntiw,Model%index_of_process_scnv,have_scnv) + endif + call fill_dtidx(Model,dtend_select,100+Model%ntke,Model%index_of_process_conv_trans,have_scnv.or.have_dcnv) + call fill_dtidx(Model,dtend_select,100+Model%ntclamt,Model%index_of_process_conv_trans,have_scnv.or.have_dcnv) + + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_pbl,have_pbl .and. have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_prod_loss,have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_ozmix,have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_temp,have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_overhead_ozone,have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_photochem,have_oz_phys) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_physics,.true.) + call fill_dtidx(Model,dtend_select,100+Model%ntoz,Model%index_of_process_non_physics,.true.) + + if(.not.Model%do_mynnedmf .and. .not. Model%satmedmf) then + call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,100+Model%ntcw,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,100+Model%ntiw,Model%index_of_process_pbl,have_pbl) + call fill_dtidx(Model,dtend_select,100+Model%ntke,Model%index_of_process_pbl,have_pbl) + endif + + do itrac=1,Model%ntrac + if(itrac==Model%ntchs) exit ! remaining tracers are chemical + if(itrac==Model%ntoz) cycle ! already took care of ozone + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_mp,have_mp) + if(have_pbl_edmf) then + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_pbl,have_pbl) + endif + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_physics,.true.) + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_non_physics,.true.) + enddo + endif + end if + ! To ensure that these values match what's in the physics, ! array sizes are compared during model init in GFS_phys_time_vary_init() ! @@ -5602,17 +5889,231 @@ subroutine radtend_create (Radtend, IM, Model) end subroutine radtend_create + subroutine fill_dtidx(Model,dtend_select,itrac,icause,flag) + implicit none + class(GFS_control_type), intent(inout) :: Model + character(len=*), intent(in) :: dtend_select(:) + integer, intent(in) :: itrac + integer, intent(in) :: icause + logical, intent(in), optional :: flag + + character(len=100) :: name + logical :: flag2 + + flag2=.true. + if(present(flag)) flag2=flag + + if(icause>0 .and. flag2 .and. itrac>0) then + name = 'dtend_'//trim(Model%dtend_var_labels(itrac)%name)//'_'//trim(Model%dtend_process_labels(icause)%name) + if(fglob_list(dtend_select,trim(name))) then + Model%ndtend = Model%ndtend+1 + Model%dtidx(itrac,icause) = Model%ndtend + elseif(Model%me==Model%master) then + print '(A,A,A)','Skipping ',trim(name),' due to mismatch with dtend_select.' + endif + endif + end subroutine fill_dtidx + + recursive function fglob(pattern,string) result(match) + ! Matches UNIX-style globs. A '*' matches 0 or more characters, + ! and a '?' matches one character. Other characters must match + ! exactly. The entire string must match, so if you want to match + ! a substring in the middle, put '*' at the ends. + ! + ! Spaces ARE significant, so make sure you trim() the inputs. + ! + ! Examples: + ! + ! fglob('dtend*_mp','dtend_temp_mp') => .true. + ! fglob('dtend*_mp','dtend_cow_mp_dog') => .false. ! entire string must match + ! fglob('c?w','cow') => .true. + ! fglob('c?w','coow') => .false. ! "?" matches one char, not two + ! fglob('c?w ','cow ') => .false. ! You forgot to trim() the inputs. + implicit none + logical :: match + character(len=*), intent(in) :: pattern,string + integer :: npat, nstr, ipat, istr, min_match, num_match + logical :: match_infinity + + npat=len(pattern) + nstr=len(string) + ipat=1 ! Next pattern character to process + istr=1 ! First string character not yet matched + outer: do while(ipat<=npat) + if_glob: if(pattern(ipat:ipat)=='*' .or. pattern(ipat:ipat)=='?') then + ! Collect sequences of * and ? to avoid pathalogical cases. + min_match=0 ! Number of "?" which is minimum number of chars to match + match_infinity=.false. ! Do we see a "*"? + glob_collect: do while(ipat<=npat) + if(pattern(ipat:ipat)=='*') then + match_infinity=.true. + else if(pattern(ipat:ipat)=='?') then + min_match=min_match+1 + else + exit + endif + ipat=ipat+1 + end do glob_collect + + num_match=0 + glob_match: do while(istr<=len(string)) + if(num_match>=min_match) then + if(match_infinity) then + if(fglob(pattern(ipat:npat),string(istr:nstr))) then + ! Remaining pattern matches remaining string. + match=.true. + return + else + ! Remaining pattern does NOT match, so we have + ! to consume another char. + endif + else + ! This is a sequence of "?" and we matched them all. + cycle outer + endif + else + ! Haven't consumed enough chars for all the "?" yet. + endif + istr=istr+1 + num_match=num_match+1 + enddo glob_match + ! We get here if we hit the end of the string. + if(num_matchnstr) then + ! Not enough string left to match the pattern + match=.false. + return + elseif(string(istr:istr)/=pattern(ipat:ipat)) then + ! Exact character mismatch + match=.false. + return + endif if_glob + ! Exact character match + istr=istr+1 + ipat=ipat+1 + end do outer + ! We get here if we ran out of pattern. We must also hit the end of the string. + match = istr>nstr + end function fglob + + logical function fglob_list(patterns,string) + ! Wrapper around fglob that returns .true. if ANY pattern + ! matches. Unlike fglob(), patterns and strings ARE automatically + ! trim()ed. Patterns are processed in order until one matches, one + ! is empty, or one is '*'. + implicit none + character(len=*), intent(in) :: patterns(:) + character(len=*), intent(in) :: string + integer :: i,n,s + fglob_list=.false. + s=len_trim(string) + do i=1,len(patterns) + n=len_trim(patterns(i)) + if(n<1) then + return ! end of pattern list + elseif(n==1 .and. patterns(i)(1:1)=='*') then + fglob_list=.true. ! A single "*" matches anything + return + else if(fglob(patterns(i)(1:n),string(1:s))) then + fglob_list=.true. + return + else + endif + enddo + end function fglob_list + + subroutine allocate_dtend_labels_and_causes(Model) + implicit none + type(GFS_control_type), intent(inout) :: Model + integer :: i + + allocate(Model%dtend_var_labels(Model%ntracp100)) + allocate(Model%dtend_process_labels(Model%nprocess)) + + Model%dtend_var_labels(1)%name = 'unallocated' + Model%dtend_var_labels(1)%desc = 'unallocated tracer' + Model%dtend_var_labels(1)%unit = 'kg kg-1 s-1' + + do i=2,Model%ntracp100 + Model%dtend_var_labels(i)%name = 'unknown' + Model%dtend_var_labels(i)%desc = 'unspecified tracer' + Model%dtend_var_labels(i)%unit = 'kg kg-1 s-1' + enddo + do i=1,Model%nprocess + Model%dtend_process_labels(i)%name = 'unknown' + Model%dtend_process_labels(i)%desc = 'unspecified tendency' + Model%dtend_process_labels(i)%time_avg = .true. + Model%dtend_process_labels(i)%mod_name = 'gfs_phys' + enddo + end subroutine allocate_dtend_labels_and_causes + + subroutine label_dtend_tracer(Model,itrac,name,desc,unit) + implicit none + type(GFS_control_type), intent(inout) :: Model + integer, intent(in) :: itrac + character(len=*), intent(in) :: name, desc + character(len=*), optional, intent(in) :: unit + + if(itrac<2) then + ! Special index 1 is for unallocated tracers + return + endif + + Model%dtend_var_labels(itrac)%name = name + Model%dtend_var_labels(itrac)%desc = desc + if(present(unit)) then + Model%dtend_var_labels(itrac)%unit=unit + else + Model%dtend_var_labels(itrac)%unit='kg kg-1 s-1' + endif + end subroutine label_dtend_tracer + + subroutine label_dtend_cause(Model,icause,name,desc,mod_name,time_avg) + implicit none + type(GFS_control_type), intent(inout) :: Model + integer, intent(in) :: icause + character(len=*), intent(in) :: name, desc + character(len=*), optional, intent(in) :: mod_name + logical, optional, intent(in) :: time_avg + + Model%dtend_process_labels(icause)%name=name + Model%dtend_process_labels(icause)%desc=desc + if(present(mod_name)) then + Model%dtend_process_labels(icause)%mod_name = mod_name + else + Model%dtend_process_labels(icause)%mod_name = "gfs_phys" + endif + if(present(time_avg)) then + Model%dtend_process_labels(icause)%time_avg = time_avg + else + Model%dtend_process_labels(icause)%time_avg = .true. + endif + end subroutine label_dtend_cause !---------------- ! GFS_diag%create !---------------- subroutine diag_create (Diag, IM, Model) + use parse_tracers, only: get_tracer_index class(GFS_diag_type) :: Diag integer, intent(in) :: IM type(GFS_control_type), intent(in) :: Model ! logical, save :: linit + logical :: have_pbl, have_dcnv, have_scnv, have_mp, have_oz_phys if(Model%print_diff_pgr) then allocate(Diag%old_pgr(IM)) @@ -5729,22 +6230,13 @@ subroutine diag_create (Diag, IM, Model) !--- 3D diagnostics if (Model%ldiag3d) then - allocate (Diag%du3dt (IM,Model%levs,8)) - allocate (Diag%dv3dt (IM,Model%levs,8)) - allocate (Diag%dt3dt (IM,Model%levs,11)) + allocate(Diag%dtend(IM,Model%levs,Model%ndtend)) + Diag%dtend = clear_val if (Model%qdiag3d) then - allocate (Diag%dq3dt (IM,Model%levs,13)) allocate (Diag%upd_mf (IM,Model%levs)) allocate (Diag%dwn_mf (IM,Model%levs)) allocate (Diag%det_mf (IM,Model%levs)) - else - allocate (Diag%dq3dt (1,1,13)) endif - else - allocate (Diag%du3dt (1,1,8)) - allocate (Diag%dv3dt (1,1,8)) - allocate (Diag%dt3dt (1,1,11)) - allocate (Diag%dq3dt (1,1,13)) endif ! UGWP @@ -6030,11 +6522,8 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) ! if(Model%me == Model%master) print *,'in diag_phys_zero, totprcpb set to 0,kdt=',Model%kdt if (Model%ldiag3d) then - Diag%du3dt = zero - Diag%dv3dt = zero - Diag%dt3dt = zero + Diag%dtend = zero if (Model%qdiag3d) then - Diag%dq3dt = zero Diag%upd_mf = zero Diag%dwn_mf = zero Diag%det_mf = zero diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 4247f9395..7d0fb0182 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -4354,6 +4354,162 @@ units = count dimensions = () type = integer +[ntracp100] + standard_name = number_of_tracers_plus_one_hundred + long_name = number of tracers plus one hundred + units = count + dimensions = () + type = integer +[nprocess] + standard_name = number_of_cumulative_change_processes + long_name = number of processes that cause changes in state variables + units = count + dimensions = () + type = integer +[nprocess_summed] + standard_name = number_of_physics_causes_of_tracer_changes + long_name = number of causes in dtidx per tracer summed for total physics tendency + units = count + dimensions = () + type = integer +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer +[ndtend] + standard_name = cumulative_change_of_state_variables_outer_index_max + long_name = last dimension of array of diagnostic tendencies for state variables + units = count + dimensions = () + type = integer +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_mp] + standard_name = index_of_microphysics_process_process_in_cumulative_change_index + long_name = index of microphysics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_prod_loss] + standard_name = index_of_production_and_loss_process_in_cumulative_change_index + long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_ozmix] + standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index + long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_temp] + standard_name = index_of_temperature_process_in_cumulative_change_index + long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_overhead_ozone] + standard_name = index_of_overhead_process_in_cumulative_change_index + long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_longwave] + standard_name = index_of_longwave_heating_process_in_cumulative_change_index + long_name = index of longwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_shortwave] + standard_name = index_of_shortwave_heating_process_in_cumulative_change_index + long_name = index of shortwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_orographic_gwd] + standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_rayleigh_damping] + standard_name = index_of_rayleigh_damping_process_in_cumulative_change_index + long_name = index of rayleigh damping process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_nonorographic_gwd] + standard_name = index_of_nonorographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of nonorographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_conv_trans] + standard_name = index_of_convective_transport_process_in_cumulative_change_index + long_name = index of convective transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_physics] + standard_name = index_of_all_physics_process_in_cumulative_change_index + long_name = index of all physics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_non_physics] + standard_name = index_of_non_physics_process_in_cumulative_change_index + long_name = index of non-physics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_process_photochem] + standard_name = index_of_photochemistry_process_in_cumulative_change_index + long_name = index of photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer +[is_photochem] + standard_name = flags_for_photochemistry_processes_to_sum + long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change + units = flag + dimensions = (number_of_cumulative_change_processes) + type = logical +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer [ntqv] standard_name = index_for_water_vapor long_name = tracer index for water vapor (specific humidity) @@ -6555,325 +6711,14 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys -[du3dt(:,:,1)] - standard_name = cumulative_change_in_x_wind_due_to_PBL - long_name = cumulative change in x wind due to PBL - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,2)] - standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag - long_name = cumulative change in x wind due to orographic gravity wave drag - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,3)] - standard_name = cumulative_change_in_x_wind_due_to_deep_convection - long_name = cumulative change in x wind due to deep convection - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,4)] - standard_name = cumulative_change_in_x_wind_due_to_convective_gravity_wave_drag - long_name = cumulative change in x wind due to convective gravity wave drag - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,5)] - standard_name = cumulative_change_in_x_wind_due_to_rayleigh_damping - long_name = cumulative change in x wind due to Rayleigh damping - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,6)] - standard_name = cumulative_change_in_x_wind_due_to_shallow_convection - long_name = cumulative change in x wind due to shallow convection - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,7)] - standard_name = cumulative_change_in_x_wind_due_to_physics - long_name = cumulative change in x wind due to physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[du3dt(:,:,8)] - standard_name = cumulative_change_in_x_wind_due_to_non_physics_processes - long_name = cumulative change in x wind due to non-physics processes - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,1)] - standard_name = cumulative_change_in_y_wind_due_to_PBL - long_name = cumulative change in y wind due to PBL - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,2)] - standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag - long_name = cumulative change in y wind due to orographic gravity wave drag - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,3)] - standard_name = cumulative_change_in_y_wind_due_to_deep_convection - long_name = cumulative change in y wind due to deep convection - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,4)] - standard_name = cumulative_change_in_y_wind_due_to_convective_gravity_wave_drag - long_name = cumulative change in y wind due to convective gravity wave drag - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys -[dv3dt(:,:,5)] - standard_name = cumulative_change_in_y_wind_due_to_rayleigh_damping - long_name = cumulative change in y wind due to Rayleigh damping - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,6)] - standard_name = cumulative_change_in_y_wind_due_to_shallow_convection - long_name = cumulative change in y wind due to shallow convection - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,7)] - standard_name = cumulative_change_in_y_wind_due_to_physics - long_name = cumulative change in y wind due to physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dv3dt(:,:,8)] - standard_name = cumulative_change_in_y_wind_due_to_non_physics_processes - long_name = cumulative change in y wind due to non-physics processes - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,1)] - standard_name = cumulative_change_in_temperature_due_to_longwave_radiation - long_name = cumulative change in temperature due to longwave radiation - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,2)] - standard_name = cumulative_change_in_temperature_due_to_shortwave_radiation - long_name = cumulative change in temperature due to shortwave radiation - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,3)] - standard_name = cumulative_change_in_temperature_due_to_PBL - long_name = cumulative change in temperature due to PBL - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,4)] - standard_name = cumulative_change_in_temperature_due_to_deep_convection - long_name = cumulative change in temperature due to deep convection - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,5)] - standard_name = cumulative_change_in_temperature_due_to_shallow_convection - long_name = cumulative change in temperature due to shallow convection - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,6)] - standard_name = cumulative_change_in_temperature_due_to_microphysics - long_name = cumulative change in temperature due to microphysics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,7)] - standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag - long_name = cumulative change in temperature due to orographic gravity wave drag - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,8)] - standard_name = cumulative_change_in_temperature_due_to_rayleigh_damping - long_name = cumulative change in temperature due to Rayleigh damping - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,9)] - standard_name = cumulative_change_in_temperature_due_to_convective_gravity_wave_drag - long_name = cumulative change in temperature due to convective gravity wave drag - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,10)] - standard_name = cumulative_change_in_temperature_due_to_physics - long_name = cumulative change in temperature due to physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D) -[dt3dt(:,:,11)] - standard_name = cumulative_change_in_temperature_due_to_non_physics_processes - long_name = cumulative change in temperature due to non-physics processed - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = various + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_cumulative_change_processes) type = real kind = kind_phys active = (flag_diagnostics_3D) -[dq3dt(:,:,1)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL - long_name = cumulative change in water vapor specific humidity due to PBL - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,2)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_deep_convection - long_name = cumulative change in water vapor specific humidity due to deep convection - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,3)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_shallow_convection - long_name = cumulative change in water vapor specific humidity due to shallow convection - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,4)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_microphysics - long_name = cumulative change in water vapor specific humidity due to microphysics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,5)] - standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL - long_name = cumulative change in ozone mixing ratio due to PBL - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,6)] - standard_name = cumulative_change_in_ozone_concentration_due_to_production_and_loss_rate - long_name = cumulative change in ozone concentration due to production and loss rate - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,7)] - standard_name = cumulative_change_in_ozone_concentration_due_to_ozone_mixing_ratio - long_name = cumulative change in ozone concentration due to ozone mixing ratio - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,8)] - standard_name = cumulative_change_in_ozone_concentration_due_to_temperature - long_name = cumulative change in ozone concentration due to temperature - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,9)] - standard_name = cumulative_change_in_ozone_concentration_due_to_overhead_ozone_column - long_name = cumulative change in ozone concentration due to overhead ozone column - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,10)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_physics - long_name = cumulative change in water vapor specific humidity due to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,11)] - standard_name = cumulative_change_in_ozone_concentration_due_to_physics - long_name = cumulative change in ozone concentration due to physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,12)] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_non_physics_processes - long_name = cumulative change in water vapor specific humidity due to non-physics processes - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) -[dq3dt(:,:,13)] - standard_name = cumulative_change_in_ozone_concentration_due_to_non_physics_processes - long_name = cumulative change in ozone_concentration due to non-physics processes - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) [refdmax] standard_name = maximum_reflectivity_at_1km_agl_over_maximum_hourly_time_interval long_name = maximum reflectivity at 1km agl over maximum hourly time interval @@ -10611,6 +10456,12 @@ type = character kind = len=128 active = (flag_for_rrtmgp_radiation_scheme) +[rtg_ozone_index] + standard_name = vertically_diffused_tracer_index_of_ozone + long_name = number of tracers + units = count + dimensions = () + type = integer ######################################################################## [ccpp-table-properties] diff --git a/ccpp/driver/GFS_diagnostics.F90 b/ccpp/driver/GFS_diagnostics.F90 index fea122446..f3d8faf9b 100644 --- a/ccpp/driver/GFS_diagnostics.F90 +++ b/ccpp/driver/GFS_diagnostics.F90 @@ -46,11 +46,52 @@ module GFS_diagnostics !--- public interfaces --- public GFS_externaldiag_populate - + CONTAINS !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - + + ! Helper function for GFS_externaldiag_populate to handle the massive dtend(:,:,dtidx(:,:)) array + subroutine add_dtend(Model,ExtDiag,IntDiag,idx,nblks,itrac,iprocess,desc,unit) + implicit none + type(GFS_control_type), intent(in) :: Model + type(GFS_externaldiag_type), intent(inout) :: ExtDiag(:) + type(GFS_diag_type), intent(in) :: IntDiag(:) + integer, intent(in) :: nblks, itrac, iprocess + integer, intent(inout) :: idx + real(kind=kind_phys), pointer :: dtend(:,:,:) ! Assumption: dtend is null iff all(dtidx <= 1) + character(len=*), intent(in), optional :: desc, unit + + integer :: idtend, nb + + idtend = Model%dtidx(itrac,iprocess) + if(idtend>=1) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'dtend_'//trim(Model%dtend_var_labels(itrac)%name)//'_'//trim(Model%dtend_process_labels(iprocess)%name) + ExtDiag(idx)%mod_name = Model%dtend_process_labels(iprocess)%mod_name + ExtDiag(idx)%time_avg = Model%dtend_process_labels(iprocess)%time_avg + if(present(desc)) then + ExtDiag(idx)%desc = desc + else + ExtDiag(idx)%desc = trim(Model%dtend_var_labels(itrac)%desc)//' '//trim(Model%dtend_process_labels(iprocess)%desc) + endif + if(present(unit)) then + ExtDiag(idx)%unit = trim(unit) + else + ExtDiag(idx)%unit = trim(Model%dtend_var_labels(itrac)%unit) + endif + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dtend(:,:,idtend) + enddo + if(Model%me==Model%master .and. Model%ldiag3d) then +307 format('ExtDiag(',I4,') = dtend(:,:,',I4,') = ',A,' (',A,': ',A,')') + print 307,idx,idtend,trim(ExtDiag(idx)%name),trim(ExtDiag(idx)%mod_name),trim(ExtDiag(idx)%desc) + endif + endif + end subroutine add_dtend + !------------------------------------------------------------------------- !--- GFS_externaldiag_populate --- !------------------------------------------------------------------------- @@ -81,7 +122,8 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ! ExtDiag%data(nb)%var3(:,:) [real*8 ] pointer to 3D data [=> null() for a 2D field] ! !---------------------------------------------------------------------------------------------! - implicit none + use parse_tracers, only: get_tracer_index + implicit none ! ! --- interface variables type(GFS_externaldiag_type), intent(inout) :: ExtDiag(:) @@ -98,12 +140,13 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop type(GFS_init_type), intent(in) :: Init_parm !--- local variables - integer :: idt, idx, num, nb, nblks, NFXR + integer :: idt, idx, num, nb, nblks, NFXR, idtend, ichem, itrac, iprocess 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 + character(len=30) :: namestr, descstr NFXR = Model%NFXR nblks = size(Statein) @@ -2336,526 +2379,55 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ! if(mpp_pe()==mpp_root_pe())print *,'in gfdl_diag_register,af shum_wts,idx=',idx -!--- three-dimensional variables that need to be handled special when writing +!--- Three-dimensional diagnostic tendencies stored in a 4D sparse +!--- array need special handling: if_ldiag3d: if(Model%ldiag3d) then - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_lw' - ExtDiag(idx)%desc = 'temperature tendency due to long wave radiation' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,1) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_sw' - ExtDiag(idx)%desc = 'temperature tendency due to short wave radiation' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,2) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_pbl' - ExtDiag(idx)%desc = 'temperature tendency due to PBL' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,3) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_deepcnv' - ExtDiag(idx)%desc = 'temperature tendency due to deep convection' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,4) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_shalcnv' - ExtDiag(idx)%desc = 'temperature tendency due to shallow convection' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,5) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_mp' - ExtDiag(idx)%desc = 'temperature tendency due to microphysics' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,6) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_orogwd' - ExtDiag(idx)%desc = 'temperature tendency due to orographic gravity wave drag' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,7) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_rdamp' - ExtDiag(idx)%desc = 'temperature tendency due to Rayleigh damping' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,8) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_cnvgwd' - ExtDiag(idx)%desc = 'temperature tendency due to convective gravity wave drag' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,9) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_phys' - ExtDiag(idx)%desc = 'temperature tendency due to physics' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,10) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dt3dt_nophys' - ExtDiag(idx)%desc = 'temperature tendency due to non-physics processes' - ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_dyn' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dt3dt(:,:,11) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_pbl' - ExtDiag(idx)%desc = 'u momentum tendency due to PBL' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,1) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_pbl' - ExtDiag(idx)%desc = 'v momentum tendency due to PBL' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,1) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_orogwd' - ExtDiag(idx)%desc = 'u momentum tendency due to orographic gravity wave drag' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,2) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_orogwd' - ExtDiag(idx)%desc = 'v momentum tendency due to orographic gravity wave drag' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,2) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_deepcnv' - ExtDiag(idx)%desc = 'u momentum tendency due to deep convection' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,3) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_deepcnv' - ExtDiag(idx)%desc = 'v momentum tendency due to deep convection' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,3) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_cnvgwd' - ExtDiag(idx)%desc = 'u momentum tendency due to convective gravity wave drag' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,4) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_cnvgwd' - ExtDiag(idx)%desc = 'v momentum tendency due to convective gravity wave drag' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,4) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_rdamp' - ExtDiag(idx)%desc = 'u momentum tendency due to Rayleigh damping' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,5) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_damp' - ExtDiag(idx)%desc = 'v momentum tendency due to Rayleigh damping' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,5) - enddo - - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_shalcnv' - ExtDiag(idx)%desc = 'u momentum tendency due to shallow convection' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,6) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_shalcnv' - ExtDiag(idx)%desc = 'v momentum tendency due to shallow convection' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,6) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_phys' - ExtDiag(idx)%desc = 'u momentum tendency due to physics' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,7) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_phys' - ExtDiag(idx)%desc = 'v momentum tendency due to physics' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,7) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'du3dt_nophys' - ExtDiag(idx)%desc = 'u momentum tendency due to non-physics processes' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_dyn' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%du3dt(:,:,8) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dv3dt_nophys' - ExtDiag(idx)%desc = 'v momentum tendency due to non-physics processes' - ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_dyn' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dv3dt(:,:,8) + do iprocess=1,Model%nprocess + do itrac=1,Model%ntracp100 + if(Model%dtidx(itrac,iprocess)>=1) then + call add_dtend(Model,ExtDiag,IntDiag,idx,nblks,itrac,iprocess) + endif + enddo enddo - + if_qdiag3d: if(Model%qdiag3d) then - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_pbl' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to PBL' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,1) - enddo idx = idx + 1 ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_deepcnv' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to deep convection' - ExtDiag(idx)%unit = 'kg kg-1 s-1' + ExtDiag(idx)%name = 'upd_mf' + ExtDiag(idx)%desc = 'updraft convective mass flux' + ExtDiag(idx)%unit = 'kg m-1 s-3' ExtDiag(idx)%mod_name = 'gfs_phys' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,2) + ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%upd_mf(:,:) enddo idx = idx + 1 ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_shalcnv' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to shallow convection' - ExtDiag(idx)%unit = 'kg kg-1 s-1' + ExtDiag(idx)%name = 'dwn_mf' + ExtDiag(idx)%desc = 'downdraft convective mass flux' + ExtDiag(idx)%unit = 'kg m-1 s-3' ExtDiag(idx)%mod_name = 'gfs_phys' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,3) + ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dwn_mf(:,:) enddo idx = idx + 1 ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_mp' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to microphysics' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,4) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3pbl' - ExtDiag(idx)%desc = 'ozone mixing ratio tendency due to PBL' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,5) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3prodloss' - ExtDiag(idx)%desc = 'ozone concentration tendency due to production and loss rate' - ExtDiag(idx)%unit = 'kg kg-1 s-1' + ExtDiag(idx)%name = 'det_mf' + ExtDiag(idx)%desc = 'detrainment convective mass flux' + ExtDiag(idx)%unit = 'kg m-1 s-3' ExtDiag(idx)%mod_name = 'gfs_phys' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,6) + ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%det_mf(:,:) enddo - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3mix' - ExtDiag(idx)%desc = 'ozone concentration tendency due to ozone mixing ratio' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,7) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3temp' - ExtDiag(idx)%desc = 'ozone concentration tendency due to temperature' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,8) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3column' - ExtDiag(idx)%desc = 'ozone concentration tendency due to overhead ozone column' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,9) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_phys' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to physics' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,10) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3phys' - ExtDiag(idx)%desc = 'ozone concentration tendency due to physics' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,11) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_nophys' - ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to non-physics processes' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_dyn' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,12) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dq3dt_o3nophys' - ExtDiag(idx)%desc = 'ozone concentration tendency due to non-physics processes' - ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_dyn' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dq3dt(:,:,13) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'upd_mf' - ExtDiag(idx)%desc = 'updraft convective mass flux' - ExtDiag(idx)%unit = 'kg m-1 s-3' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%upd_mf(:,:) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'dwn_mf' - ExtDiag(idx)%desc = 'downdraft convective mass flux' - ExtDiag(idx)%unit = 'kg m-1 s-3' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dwn_mf(:,:) - enddo - - idx = idx + 1 - ExtDiag(idx)%axes = 3 - ExtDiag(idx)%name = 'det_mf' - ExtDiag(idx)%desc = 'detrainment convective mass flux' - ExtDiag(idx)%unit = 'kg m-1 s-3' - ExtDiag(idx)%mod_name = 'gfs_phys' - ExtDiag(idx)%time_avg = .TRUE. - allocate (ExtDiag(idx)%data(nblks)) - do nb = 1,nblks - ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%det_mf(:,:) - enddo - end if if_qdiag3d end if if_ldiag3d @@ -2865,7 +2437,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop !rab write (xtra,'(I1)') num !rab idx = idx + 1 !rab ExtDiag(idx)%axes = 3 -!rab ExtDiag(idx)%name = 'dq3dt_'//trim(xtra) +!rab ExtDiag(idx)%name = 'dtend_'//trim(xtra) !rab ExtDiag(idx)%desc = 'moisture change due to physics '//trim(xtra)//'' !rab ExtDiag(idx)%unit = 'XXX' !rab ExtDiag(idx)%mod_name = 'gfs_phys' diff --git a/ccpp/physics b/ccpp/physics index 21df4016f..417ec2d0c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 21df4016f4d435ed531b773e80b462d57e1f4213 +Subproject commit 417ec2d0cdb9c89fd745104ee3fcd316168f0977 diff --git a/ccpp/suites/suite_FV3_RRFS_v1beta.xml b/ccpp/suites/suite_FV3_RRFS_v1beta.xml index 2691dedd4..74baa3a98 100644 --- a/ccpp/suites/suite_FV3_RRFS_v1beta.xml +++ b/ccpp/suites/suite_FV3_RRFS_v1beta.xml @@ -77,6 +77,7 @@ GFS_stochastics + phys_tend diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 5fa2e13c2..6fe8673a8 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -2288,38 +2288,6 @@ subroutine fv3gfs_diag_output(time, diag, atm_block, nx, ny, levs, ntcw, ntoz, & call store_data3D(Diag(idx)%id, var3, Time, idx, Diag(idx)%intpl_method, Diag(idx)%name) #ifdef JUNK else - !--- dt3dt variables - do num = 1,6 - write(xtra,'(i1)') num - if (trim(Diag(idx)%name) == 'dt3dt_'//trim(xtra)) then - var3(1:nx,1:ny,1:levs) = RESHAPE(Gfs_diag%dt3dt(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 - !--- 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/)) From aa22b696f75669afe63ef76f29f64beecfd9ebf9 Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Fri, 23 Apr 2021 06:29:12 -0400 Subject: [PATCH 022/115] Fix incorrect units in dtend metadata (#82) * Fix incorrect units in dtend metadata * Make the tracer tendency units mandatory. --- ccpp/data/GFS_typedefs.F90 | 56 ++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 30 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 29c8cf5a5..7aaaac08c 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -4421,7 +4421,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & do itrac=1,Model%ntrac write(namestr,'("tracer",I0)') itrac write(descstr,'("tracer ",I0," of ",I0)') itrac, Model%ntrac - call label_dtend_tracer(Model,100+itrac,trim(namestr),trim(descstr)) + call label_dtend_tracer(Model,100+itrac,trim(namestr),trim(descstr),'kg kg-1 s-1') enddo if(Model%ntchs>0) then @@ -4433,7 +4433,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & do ichem=Model%ntchs,Model%ntchs+Model%ntchm-1 write(namestr,'("chem",I0)') ichem write(descstr,'("chemical tracer ",I0," of ",I0)') ichem, Model%ntchm - call label_dtend_tracer(Model,100+ichem,trim(namestr),trim(descstr)) + call label_dtend_tracer(Model,100+ichem,trim(namestr),trim(descstr),'kg kg-1 s-1') enddo endif @@ -4441,15 +4441,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call label_dtend_tracer(Model,100+Model%ntchs,'so2','sulfur dioxide concentration') if(Model%ntchm>0) then ! Need better descriptions of these. - call label_dtend_tracer(Model,100+Model%ntchm+Model%ntchs-1,'pp10','pp10 concentration') + call label_dtend_tracer(Model,100+Model%ntchm+Model%ntchs-1,'pp10','pp10 concentration','kg kg-1 s-1') itrac=get_tracer_index(Model%tracer_names, 'DMS', Model%me, Model%master, Model%debug) if(itrac>0) then - call label_dtend_tracer(Model,100+itrac,'DMS','DMS concentration') + call label_dtend_tracer(Model,100+itrac,'DMS','DMS concentration','kg kg-1 s-1') endif itrac=get_tracer_index(Model%tracer_names, 'msa', Model%me, Model%master, Model%debug) if(itrac>0) then - call label_dtend_tracer(Model,100+itrac,'msa','msa concentration') + call label_dtend_tracer(Model,100+itrac,'msa','msa concentration','kg kg-1 s-1') endif endif endif @@ -4459,25 +4459,25 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call label_dtend_tracer(Model,Model%index_of_y_wind,'v','y wind','m s-2') ! Other tracer names. These were taken from GFS_typedefs.F90 with descriptions from GFS_typedefs.meta - call label_dtend_tracer(Model,100+Model%ntqv,'qv','water vapor specific humidity') - call label_dtend_tracer(Model,100+Model%ntoz,'o3','ozone concentration') - call label_dtend_tracer(Model,100+Model%ntcw,'liq_wat','cloud condensate (or liquid water)') - call label_dtend_tracer(Model,100+Model%ntiw,'ice_wat','ice water') - call label_dtend_tracer(Model,100+Model%ntrw,'rainwat','rain water') - call label_dtend_tracer(Model,100+Model%ntsw,'snowwat','snow water') - call label_dtend_tracer(Model,100+Model%ntgl,'graupel','graupel') - call label_dtend_tracer(Model,100+Model%ntclamt,'cld_amt','cloud amount integer') - call label_dtend_tracer(Model,100+Model%ntlnc,'water_nc','liquid number concentration') - call label_dtend_tracer(Model,100+Model%ntinc,'ice_nc','ice number concentration') - call label_dtend_tracer(Model,100+Model%ntrnc,'rain_nc','rain number concentration') - call label_dtend_tracer(Model,100+Model%ntsnc,'snow_nc','snow number concentration') - call label_dtend_tracer(Model,100+Model%ntgnc,'graupel_nc','graupel number concentration') - call label_dtend_tracer(Model,100+Model%ntke,'sgs_tke','turbulent kinetic energy') - call label_dtend_tracer(Model,100+Model%nqrimef,'q_rimef','mass weighted rime factor') - call label_dtend_tracer(Model,100+Model%ntwa,'liq_aero','number concentration of water-friendly aerosols') - call label_dtend_tracer(Model,100+Model%ntia,'ice_aero','number concentration of ice-friendly aerosols') - call label_dtend_tracer(Model,100+Model%nto,'o_ion','oxygen ion concentration') - call label_dtend_tracer(Model,100+Model%nto2,'o2','oxygen concentration') + call label_dtend_tracer(Model,100+Model%ntqv,'qv','water vapor specific humidity','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntoz,'o3','ozone concentration','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntcw,'liq_wat','cloud condensate (or liquid water)','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntiw,'ice_wat','ice water','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntrw,'rainwat','rain water','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntsw,'snowwat','snow water','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntgl,'graupel','graupel','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntclamt,'cld_amt','cloud amount integer','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntlnc,'water_nc','liquid number concentration','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntinc,'ice_nc','ice number concentration','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntrnc,'rain_nc','rain number concentration','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntsnc,'snow_nc','snow number concentration','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntgnc,'graupel_nc','graupel number concentration','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntke,'sgs_tke','turbulent kinetic energy','J s-1') + call label_dtend_tracer(Model,100+Model%nqrimef,'q_rimef','mass weighted rime factor','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntwa,'liq_aero','number concentration of water-friendly aerosols','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%ntia,'ice_aero','number concentration of ice-friendly aerosols','kg-1 s-1') + call label_dtend_tracer(Model,100+Model%nto,'o_ion','oxygen ion concentration','kg kg-1 s-1') + call label_dtend_tracer(Model,100+Model%nto2,'o2','oxygen concentration','kg kg-1 s-1') call label_dtend_cause(Model,Model%index_of_process_pbl,'pbl','tendency due to PBL') call label_dtend_cause(Model,Model%index_of_process_dcnv,'deepcnv','tendency due to deep convection') @@ -6064,7 +6064,7 @@ subroutine label_dtend_tracer(Model,itrac,name,desc,unit) type(GFS_control_type), intent(inout) :: Model integer, intent(in) :: itrac character(len=*), intent(in) :: name, desc - character(len=*), optional, intent(in) :: unit + character(len=*), intent(in) :: unit if(itrac<2) then ! Special index 1 is for unallocated tracers @@ -6073,11 +6073,7 @@ subroutine label_dtend_tracer(Model,itrac,name,desc,unit) Model%dtend_var_labels(itrac)%name = name Model%dtend_var_labels(itrac)%desc = desc - if(present(unit)) then - Model%dtend_var_labels(itrac)%unit=unit - else - Model%dtend_var_labels(itrac)%unit='kg kg-1 s-1' - endif + Model%dtend_var_labels(itrac)%unit = unit end subroutine label_dtend_tracer subroutine label_dtend_cause(Model,icause,name,desc,mod_name,time_avg) From a16085a69dd71c0da6fa09237430a6166c7fd08f Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Mon, 26 Apr 2021 16:11:14 -0400 Subject: [PATCH 023/115] Add SO2 tendency units (#86) --- ccpp/data/GFS_typedefs.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 7aaaac08c..0221ee37d 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -4438,7 +4438,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif ! More specific chemical tracer names: - call label_dtend_tracer(Model,100+Model%ntchs,'so2','sulfur dioxide concentration') + call label_dtend_tracer(Model,100+Model%ntchs,'so2','sulfur dioxide concentration','kg kg-1 s-1') if(Model%ntchm>0) then ! Need better descriptions of these. call label_dtend_tracer(Model,100+Model%ntchm+Model%ntchs-1,'pp10','pp10 concentration','kg kg-1 s-1') From 78e1af469fae94ca7c5e83ed26febe4e7b1feb2a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 20 May 2021 15:18:55 -0600 Subject: [PATCH 024/115] Update .gitmodules and submodule pointers for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++++++---- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..6d6e52ed5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,13 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NOAA-GSL/ccpp-framework - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-framework + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-framework + branch = update_gsl_develop_from_main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsl_develop_from_main diff --git a/ccpp/framework b/ccpp/framework index ed43d983c..c1ab8a292 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit ed43d983c62a1825c1533ba5978dab61635d0727 +Subproject commit c1ab8a292fc2acc6430d020e367362deb61ca9db diff --git a/ccpp/physics b/ccpp/physics index 417ec2d0c..94bf98964 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 417ec2d0cdb9c89fd745104ee3fcd316168f0977 +Subproject commit 94bf989642fc311360ade8b1609e22fa3c7017ab From ef024c736d41188b5a81afd39448e18f686f121e Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 21 May 2021 07:02:31 -0600 Subject: [PATCH 025/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 94bf98964..1da87101a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 94bf989642fc311360ade8b1609e22fa3c7017ab +Subproject commit 1da87101a430202cc5daa24ae4968ac49d42ef40 From e361a826345973c46c599a00e687fb3a82a1b2f2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 21 May 2021 13:46:54 -0600 Subject: [PATCH 026/115] Revert change to .gitmodules and update submodule pointer for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d6e52ed5..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index c1ab8a292..84007ab59 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit c1ab8a292fc2acc6430d020e367362deb61ca9db +Subproject commit 84007ab5964b965501f32f607d444db4ad1f491d diff --git a/ccpp/physics b/ccpp/physics index 1da87101a..378a905fa 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 1da87101a430202cc5daa24ae4968ac49d42ef40 +Subproject commit 378a905fa1552aaaddd57308bd80238131e1951d From d38ae349d675f9a5370ecf0393de3d4536ff0970 Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Fri, 28 May 2021 17:09:30 -0400 Subject: [PATCH 027/115] dtend: add missing tendencies and fix bugs in convection tendencies (#92) * Fix incorrect units in dtend metadata * Point to corresponding ccpp/physics branch * fixes to dtend support: 1. Store rtg (AKA clw AKA qtr) instead of gq0 in DCNV and SCNV pre/post for schemes that use convective transport. Tracers handled solely by convective transport (ones not in rtg) are reported as convective transport tendencies. Tendencies for variables in rtg are reported as dcnv and scnv tendencies. 2. Report TKE tendencies from gfs v16 PBL. 3. Add diagnostic tendencies to drag_suite 4. Only report rayleigh damping tendencies if rayleigh damping is enabled 5. List all possible diagnostic tendencies, even if they are not enabled. In the output, label them "selected" or "disabled." 6. Add phys_tend to the fv3_rap suite. * Merge gsl/develop into ccpp/physics * Add phys_tend to suite_FV3_GSD_SAR and remove some debug prints * Remove some debug prints and commented-out code. * Correct error in dtend variable availability list print. * Enable convtrans diagnostic tendencies for number concentrations and qrimef. * Disable cnvtrans diagnostic tendencies for schemes that do their own diagnostic tendency reporting. * Point to gsl repositories --- ccpp/data/GFS_typedefs.F90 | 102 ++++++++++++++++++++---------- ccpp/data/GFS_typedefs.meta | 21 ++++++ ccpp/driver/GFS_diagnostics.F90 | 4 -- ccpp/physics | 2 +- ccpp/suites/suite_FV3_GSD_SAR.xml | 1 + ccpp/suites/suite_FV3_HRRR.xml | 1 + ccpp/suites/suite_FV3_RAP.xml | 1 + 7 files changed, 93 insertions(+), 39 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 6be054457..7c55ee701 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -2184,7 +2184,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: cwm (:,:) => null() !< !-- 3D diagnostics - integer :: rtg_ozone_index + integer :: rtg_ozone_index, rtg_tke_index contains procedure :: create => interstitial_create !< allocate array data @@ -3600,7 +3600,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: ncnvcld3d = 0 !< number of convective 3d clouds fields integer :: itrac, ipat, ichem - logical :: have_pbl, have_dcnv, have_scnv, have_mp, have_oz_phys, have_samf, have_pbl_edmf + logical :: have_pbl, have_dcnv, have_scnv, have_mp, have_oz_phys, have_samf, have_pbl_edmf, have_cnvtrans, have_rdamp character(len=20) :: namestr character(len=44) :: descstr @@ -4450,14 +4450,23 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if(ldiag3d) then ! Flags used to turn on or off tracer "causes" - have_pbl_edmf = Model%hybedmf .or. Model%satmedmf .or. do_mynnedmf + have_pbl_edmf = Model%hybedmf .or. Model%satmedmf .or. Model%do_mynnedmf have_samf = Model%satmedmf .or. Model%trans_trac .or. Model%ras .or. Model%do_shoc have_pbl = .true. - have_dcnv = Model%imfdeepcnv>=0 !Model%ras .or. Model%cscnv .or. Model%do_deep .or. Model%hwrf_samfdeep - have_scnv = Model%imfshalcnv>=0 !Model%shal_cnv + have_dcnv = Model%imfdeepcnv>0 !Model%ras .or. Model%cscnv .or. Model%do_deep .or. Model%hwrf_samfdeep + have_scnv = Model%imfshalcnv>0 !Model%shal_cnv have_mp = Model%imp_physics>0 have_oz_phys = Model%oz_phys .or. Model%oz_phys_2015 - + + ! Rayleigh damping flag must match logic in rayleigh_damp.f + have_rdamp = .not. (Model%lsidea .or. Model%ral_ts <= 0.0 .or. Model%prslrd0 == 0.0) + + ! have_cnvtrans flag must match logic elsewhere in GFS_typedefs and suite interstitials. + have_cnvtrans = (have_dcnv .or. have_scnv) .and. & + (cscnv .or. satmedmf .or. trans_trac .or. ras) & + .and. Model%flag_for_scnv_generic_tend & + .and. Model%flag_for_dcnv_generic_tend + ! Increment idtend and fill dtidx: allocate(Model%dtend_var_labels(Model%ntracp100)) allocate(Model%dtend_process_labels(Model%nprocess)) @@ -4552,7 +4561,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_scnv,have_scnv) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_mp,have_mp) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_orographic_gwd) - call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_rayleigh_damping) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_rayleigh_damping,have_rdamp) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_nonorographic_gwd) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_physics) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_non_physics) @@ -4565,8 +4574,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_dcnv,have_dcnv) call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_nonorographic_gwd) call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_nonorographic_gwd) - call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_rayleigh_damping) - call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_rayleigh_damping) + call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_rayleigh_damping,have_rdamp) + call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_rayleigh_damping,have_rdamp) call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_scnv,have_scnv) call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_scnv,have_scnv) call fill_dtidx(Model,dtend_select,Model%index_of_x_wind,Model%index_of_process_physics) @@ -4575,25 +4584,35 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call fill_dtidx(Model,dtend_select,Model%index_of_y_wind,Model%index_of_process_non_physics) if(qdiag3d) then - if(have_samf) then - do itrac=1,Model%ntrac - if(itrac==Model%ntchs) exit ! remaining tracers are chemical - if(itrac==Model%ntke) cycle ! TKE is handled by convective transport (see below) - call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_dcnv,have_dcnv) - call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_scnv,have_scnv) - enddo - else - call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_dcnv,have_dcnv) - call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_scnv,have_scnv) - call fill_dtidx(Model,dtend_select,100+Model%ntcw,Model%index_of_process_dcnv,have_dcnv) - call fill_dtidx(Model,dtend_select,100+Model%ntcw,Model%index_of_process_scnv,have_scnv) - call fill_dtidx(Model,dtend_select,100+Model%ntiw,Model%index_of_process_dcnv,have_dcnv) - call fill_dtidx(Model,dtend_select,100+Model%ntiw,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,100+Model%ntqv,Model%index_of_process_dcnv,have_dcnv) + + if(have_cnvtrans) then + do itrac=2,Model%ntrac + if(itrac==Model%ntchs) exit ! remaining tracers are chemical + if ( itrac /= Model%ntcw .and. itrac /= Model%ntiw .and. itrac /= Model%ntclamt .and. & + itrac /= Model%ntrw .and. itrac /= Model%ntsw .and. itrac /= Model%ntrnc .and. & + itrac /= Model%ntsnc .and. itrac /= Model%ntgl .and. itrac /= Model%ntgnc) then + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_scnv,have_scnv) + call fill_dtidx(Model,dtend_select,100+itrac,Model%index_of_process_dcnv,have_dcnv) + else if(Model%ntchs<=0 .or. itrac0 .and. itrac>0) then + if(Model%dtidx(itrac,icause)>0) then + return ! This tendency is already allocated. + endif - if(icause>0 .and. flag2 .and. itrac>0) then name = 'dtend_'//trim(Model%dtend_var_labels(itrac)%name)//'_'//trim(Model%dtend_process_labels(icause)%name) + if(fglob_list(dtend_select,trim(name))) then Model%ndtend = Model%ndtend+1 Model%dtidx(itrac,icause) = Model%ndtend + if(Model%me==Model%master) then + print 308,'selected',trim(Model%dtend_process_labels(icause)%mod_name), trim(name), & + trim(Model%dtend_var_labels(itrac)%desc), trim(Model%dtend_process_labels(icause)%desc), & + trim(Model%dtend_var_labels(itrac)%unit) + endif elseif(Model%me==Model%master) then - print '(A,A,A)','Skipping ',trim(name),' due to mismatch with dtend_select.' + print 308,'disabled',trim(Model%dtend_process_labels(icause)%mod_name), trim(name), & + trim(Model%dtend_var_labels(itrac)%desc), trim(Model%dtend_process_labels(icause)%desc), & + trim(Model%dtend_var_labels(itrac)%unit) endif endif +308 format('dtend ',A,': ',A,' ',A,' = ',A,' ',A,' (',A,')') end subroutine fill_dtidx recursive function fglob(pattern,string) result(match) @@ -6006,7 +6040,7 @@ recursive function fglob(pattern,string) result(match) istr=1 ! First string character not yet matched outer: do while(ipat<=npat) if_glob: if(pattern(ipat:ipat)=='*' .or. pattern(ipat:ipat)=='?') then - ! Collect sequences of * and ? to avoid pathalogical cases. + ! Collect sequences of * and ? to avoid pathological cases. min_match=0 ! Number of "?" which is minimum number of chars to match match_infinity=.false. ! Do we see a "*"? glob_collect: do while(ipat<=npat) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 9adbdbf70..ed9d7ec0b 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -9261,6 +9261,13 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys +[save_q(:,:,index_for_turbulent_kinetic_energy)] + standard_name = turbulent_kinetic_energy_save + long_name = turbulent kinetic energy before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys [save_q(:,:,index_for_liquid_cloud_condensate)] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme @@ -9282,6 +9289,20 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys +[save_q(:,:,index_for_liquid_cloud_number_concentration)] + standard_name = liquid_cloud_number_concentration_save + long_name = liquid cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys +[save_q(:,:,index_for_ice_cloud_number_concentration)] + standard_name = ice_cloud_number_concentration_save + long_name = ice cloud number concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys [save_q] standard_name = tracer_concentration_save long_name = tracer concentration before entering a physics scheme diff --git a/ccpp/driver/GFS_diagnostics.F90 b/ccpp/driver/GFS_diagnostics.F90 index 45985783c..c5ea95eb6 100644 --- a/ccpp/driver/GFS_diagnostics.F90 +++ b/ccpp/driver/GFS_diagnostics.F90 @@ -85,10 +85,6 @@ subroutine add_dtend(Model,ExtDiag,IntDiag,idx,nblks,itrac,iprocess,desc,unit) do nb = 1,nblks ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%dtend(:,:,idtend) enddo - if(Model%me==Model%master .and. Model%ldiag3d) then -307 format('ExtDiag(',I4,') = dtend(:,:,',I4,') = ',A,' (',A,': ',A,')') - print 307,idx,idtend,trim(ExtDiag(idx)%name),trim(ExtDiag(idx)%mod_name),trim(ExtDiag(idx)%desc) - endif endif end subroutine add_dtend diff --git a/ccpp/physics b/ccpp/physics index 378a905fa..9346bb724 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 378a905fa1552aaaddd57308bd80238131e1951d +Subproject commit 9346bb7244d5469742dda697113a04d94b27d5a0 diff --git a/ccpp/suites/suite_FV3_GSD_SAR.xml b/ccpp/suites/suite_FV3_GSD_SAR.xml index 29f6d3707..20fdd6cca 100644 --- a/ccpp/suites/suite_FV3_GSD_SAR.xml +++ b/ccpp/suites/suite_FV3_GSD_SAR.xml @@ -78,6 +78,7 @@ GFS_stochastics + phys_tend diff --git a/ccpp/suites/suite_FV3_HRRR.xml b/ccpp/suites/suite_FV3_HRRR.xml index c74fe17f8..113462ddd 100644 --- a/ccpp/suites/suite_FV3_HRRR.xml +++ b/ccpp/suites/suite_FV3_HRRR.xml @@ -77,6 +77,7 @@ GFS_stochastics + phys_tend diff --git a/ccpp/suites/suite_FV3_RAP.xml b/ccpp/suites/suite_FV3_RAP.xml index da3fe46bf..f9444802b 100644 --- a/ccpp/suites/suite_FV3_RAP.xml +++ b/ccpp/suites/suite_FV3_RAP.xml @@ -83,6 +83,7 @@ GFS_stochastics + phys_tend From 97aa974fa836ab061ba5d4164fff4d535b2b1fde Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 31 May 2021 14:51:05 -0600 Subject: [PATCH 028/115] Update .gitmodules for code review and regression testing --- .gitmodules | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..4a7c41250 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NOAA-GSL/ccpp-framework - branch = gsl/develop + url = https://github.com/climbfuji/ccpp-framework + branch = update_gsl_develop_from_main_20210531 [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsl_develop_from_main_20210531 From 06c0421163ba35c6ac750c334c41b05497a6c894 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Jun 2021 13:04:24 -0600 Subject: [PATCH 029/115] Formatting changes in ccpp/data/GFS_typedefs.F90 --- ccpp/data/GFS_typedefs.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 08565afdf..7652c0b19 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1133,9 +1133,9 @@ module GFS_typedefs integer :: ntracp100 !< number of tracers plus one hundred integer :: nqrimef !< tracer index for mass weighted rime factor - integer, pointer :: dtidx(:,:) => null() !< index in outermost dimension of dtend - integer :: ndtend !< size of outermost dimension of dtend - type(dtend_var_label), pointer :: dtend_var_labels(:) => null() !< information about first dim of dtidx + integer, pointer :: dtidx(:,:) => null() !< index in outermost dimension of dtend + integer :: ndtend !< size of outermost dimension of dtend + type(dtend_var_label), pointer :: dtend_var_labels(:) => null() !< information about first dim of dtidx type(dtend_process_label), pointer :: dtend_process_labels(:) => null() !< information about second dim of dtidx ! Indices within inner dimension of dtidx for things that are not tracers: @@ -1620,7 +1620,7 @@ module GFS_typedefs ! dtend/dtidxt: Multitudenous 3d tendencies in a 4D array: (i,k,0:ntrac,nprocess) ! Sparse in outermost two dimensions. dtidx(1:100+ntrac,nprocess) maps to dtend ! outer dimension index. - real (kind=kind_phys), pointer :: dtend (:,:,:) => null() !< tracer changes due to physics + real (kind=kind_phys), pointer :: dtend (:,:,:) => null() !< tracer changes due to physics real (kind=kind_phys), pointer :: refdmax (:) => null() !< max hourly 1-km agl reflectivity real (kind=kind_phys), pointer :: refdmax263k(:) => null() !< max hourly -10C reflectivity From 7c257a0c7ac23d6b7f41b16b8e387b51e28637cb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Jun 2021 13:05:00 -0600 Subject: [PATCH 030/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 462a87030..10ab813d6 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 462a87030aa2635dedf4e9ad51310d7919a94caa +Subproject commit 10ab813d658c288e2b872406a5f15d991d3cb6d6 From 5b75e268a0f4dcd1a8c5d8521746e7eb1c918d91 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 3 Jun 2021 10:27:20 -0600 Subject: [PATCH 031/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 10ab813d6..ef5db3119 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 10ab813d658c288e2b872406a5f15d991d3cb6d6 +Subproject commit ef5db3119c2f924dfe2c1da180b92f388b1a82f7 From de014c4871df7cc753916f088b2ab40b2f0ebac6 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Mon, 7 Jun 2021 23:44:17 +0000 Subject: [PATCH 032/115] Point update_gsl_develop_from_develop_20210531 to NOAA-GSL branches of ccpp/physics and ccpp/framework --- ccpp/framework | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ccpp/framework b/ccpp/framework index 6f96532a8..1ed228994 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 6f96532a862d5bb7fff8b32662d965bb4fa97458 +Subproject commit 1ed2289941d830696192c49901cafc81d00a6ec4 diff --git a/ccpp/physics b/ccpp/physics index ef5db3119..40ad71ee6 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ef5db3119c2f924dfe2c1da180b92f388b1a82f7 +Subproject commit 40ad71ee63e64c4180a4b988dd5fb0a5cbe69bb0 From 52c80143d22ef86c93b0600eac7e96edb8965993 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Fri, 9 Jul 2021 14:44:55 -0600 Subject: [PATCH 033/115] GF aerosols updates and tunings --- ccpp/data/GFS_typedefs.F90 | 6 ++++++ ccpp/data/GFS_typedefs.meta | 14 ++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 7652c0b19..a3d2da59d 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1384,6 +1384,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: prevst (:,:) => null() !< real (kind=kind_phys), pointer :: prevsq (:,:) => null() !< integer, pointer :: cactiv (:) => null() !< convective activity memory contour + integer, pointer :: cactiv_m (:) => null() !< mid-level convective activity memory contour + real (kind=kind_phys), pointer :: aod_gf (:) => null() !--- MYNN prognostic variables that can't be in the Intdiag or Interstitial DDTs real (kind=kind_phys), pointer :: CLDFRA_BL (:,:) => null() ! @@ -5884,7 +5886,11 @@ subroutine tbd_create (Tbd, IM, Model) if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then allocate(Tbd%cactiv(IM)) + allocate(Tbd%cactiv_m(IM)) + allocate(Tbd%aod_gf(IM)) Tbd%cactiv = zero + Tbd%cactiv_m = zero + Tbd%aod_gf = zero end if !--- MYNN variables: diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 681f318b5..3a0530207 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5648,6 +5648,13 @@ dimensions = (horizontal_loop_extent,vertical_dimension,number_of_aerosol_tracers_MG) type = real kind = kind_phys +[aod_gf] + standard_name = aod_gf_deep + long_name = aerosol optical depth used in Grell-Freitas Convective Parameterization + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [imap] standard_name = map_of_block_column_number_to_global_i_index long_name = map of local index ix to global index i for this block @@ -5903,6 +5910,13 @@ dimensions = (horizontal_loop_extent) type = integer active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) +[cactiv_m] + standard_name = mid_conv_activity_counter + long_name = mid-level convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) [CLDFRA_BL] standard_name = subgrid_cloud_fraction_pbl long_name = subgrid cloud fraction from PBL scheme From 487c7dea33ecca61800f1f5cb3f254c5fe721304 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Fri, 9 Jul 2021 14:45:56 -0600 Subject: [PATCH 034/115] GF aerosol updates and tunings from physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 40ad71ee6..d35b3d56a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 40ad71ee63e64c4180a4b988dd5fb0a5cbe69bb0 +Subproject commit d35b3d56ac9c07a9899ad78dac6e9f6a8c13c21b From 6c0262b3b7c738d8ed37785220c67536fc26ded1 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 12 Jul 2021 14:36:13 -0600 Subject: [PATCH 035/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 8 +++++--- ccpp/physics | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4a7c41250..dd1519254 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,11 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main_20210531 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20210531 + branch = gsl_develop_hannah_and_joe_changes_combined_20210712 diff --git a/ccpp/physics b/ccpp/physics index 40ad71ee6..43fd15cf1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 40ad71ee63e64c4180a4b988dd5fb0a5cbe69bb0 +Subproject commit 43fd15cf1ce8794743645c0fe5a6b903e5c8c6cf From dcbc0ec45ab03f042eb6ac40527faa5cfba08964 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 12 Jul 2021 15:01:11 -0600 Subject: [PATCH 036/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 43fd15cf1..65a18233c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 43fd15cf1ce8794743645c0fe5a6b903e5c8c6cf +Subproject commit 65a18233c185e6da4afb2daeeacbdcaea855b787 From 3a9e20d5870e46e4401be75818b353f78fc6d267 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 14 Jul 2021 14:49:26 -0600 Subject: [PATCH 037/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 65a18233c..2c67750a3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 65a18233c185e6da4afb2daeeacbdcaea855b787 +Subproject commit 2c67750a3a4c16cf2683d46c7558ea6701728c53 From 8043a8ae21528559c33cd7d1dd5e888ca0b55e68 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 14 Jul 2021 20:56:12 -0600 Subject: [PATCH 038/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 2c67750a3..99ad1a792 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 2c67750a3a4c16cf2683d46c7558ea6701728c53 +Subproject commit 99ad1a792e2eb54749a6a48733db32ef54591387 From ec202a38b876eb1ad894c79aec70c718be8231e4 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 15 Jul 2021 10:18:50 -0600 Subject: [PATCH 039/115] Make aod_gf and cactiv_m work appriopriately for restarts Minor code cleanup --- ccpp/data/GFS_typedefs.F90 | 3 +++ ccpp/driver/GFS_restart.F90 | 10 ++++++++++ ccpp/physics | 2 +- 3 files changed, 14 insertions(+), 1 deletion(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index a3d2da59d..d2f357cc5 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -275,6 +275,7 @@ module GFS_typedefs !-- In/Out real (kind=kind_phys), pointer :: conv_act(:) => null() !< convective activity counter for Grell-Freitas + real (kind=kind_phys), pointer :: conv_act_m(:) => null() !< midlevel convective activity counter for Grell-Freitas 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 @@ -2721,7 +2722,9 @@ subroutine sfcprop_create (Sfcprop, IM, Model) end if if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then allocate (Sfcprop%conv_act(IM)) + allocate (Sfcprop%conv_act_m(IM)) Sfcprop%conv_act = zero + Sfcprop%conv_act_m = zero end if end subroutine sfcprop_create diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index e4bc8350d..aa4a1a16d 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -193,6 +193,16 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & do nb = 1,nblks Restart%data(nb,num)%var2p => Sfcprop(nb)%conv_act(:) enddo + num = num + 1 + Restart%name2d(num) = 'gf_2d_conv_act_m' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%conv_act_m(:) + enddo + num = num + 1 + Restart%name2d(num) = 'aod_gf' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Tbd(nb)%aod_gf(:) + enddo endif ! NoahMP if (Model%lsm == Model%lsm_noahmp) then diff --git a/ccpp/physics b/ccpp/physics index d35b3d56a..60380d1ea 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d35b3d56ac9c07a9899ad78dac6e9f6a8c13c21b +Subproject commit 60380d1ea02bdda8e37f8eb956f295edf5027f86 From 398e9516df0e207190c3e29fac8409dcb0847a20 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 15 Jul 2021 11:46:21 -0600 Subject: [PATCH 040/115] Add missing metadata for new GF arrays --- ccpp/data/GFS_typedefs.meta | 8 ++++++++ ccpp/physics | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 3a0530207..e83a0e021 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -760,6 +760,14 @@ type = real kind = kind_phys active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) +[conv_act_m] + standard_name = gf_mid_memory_counter + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) [hice] standard_name = sea_ice_thickness long_name = sea ice thickness diff --git a/ccpp/physics b/ccpp/physics index 5ada9ed49..a786194c8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5ada9ed491c7d6809a40db00e810581bf13e00e5 +Subproject commit a786194c8bdc3089a0312f4748a500fcf82bdaa7 From a6933723d6bbffb48dbd3d2c243398c19ae0d3d1 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Jul 2021 10:21:39 -0600 Subject: [PATCH 041/115] Bug fix in ccpp/driver/GFS_restart.F90 for GF --- ccpp/driver/GFS_restart.F90 | 4 ++-- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index aa4a1a16d..726812a00 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -98,8 +98,8 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%num2d = 3 + Model%ntot2d + Model%nctp + ndiag_rst ! GF - if (Model%imfdeepcnv == 3) then - Restart%num2d = Restart%num2d + 1 + if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then + Restart%num2d = Restart%num2d + 3 endif ! NoahMP if (Model%lsm == Model%lsm_noahmp) then diff --git a/ccpp/physics b/ccpp/physics index a786194c8..eac0587da 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit a786194c8bdc3089a0312f4748a500fcf82bdaa7 +Subproject commit eac0587da61fbf6c207d8f2d504fd951f35ea1a0 From ce42a41f32ac18128aa37ff9c5af4f0c0d022320 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Jul 2021 13:25:43 -0600 Subject: [PATCH 042/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index eac0587da..88258273f 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit eac0587da61fbf6c207d8f2d504fd951f35ea1a0 +Subproject commit 88258273f7c0d86c6114696eaa79a62e88316a88 From dfa935dc7b3c208c66653e83df09fd31e71c09f0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 19 Jul 2021 10:18:20 -0600 Subject: [PATCH 043/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index dd1519254..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = gsl_develop_hannah_and_joe_changes_combined_20210712 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 88258273f..9edfe02b1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 88258273f7c0d86c6114696eaa79a62e88316a88 +Subproject commit 9edfe02b1154b47d7f708e223284440f481af018 From 4e144190a36b02145b52b1ea2781ab28905512d8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 19 Jul 2021 10:20:11 -0600 Subject: [PATCH 044/115] Add missing active attribute for aod_gf in ccpp/data/GFS_typedefs.meta --- ccpp/data/GFS_typedefs.meta | 1 + 1 file changed, 1 insertion(+) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index e83a0e021..c784d8de8 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5663,6 +5663,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) [imap] standard_name = map_of_block_column_number_to_global_i_index long_name = map of local index ix to global index i for this block From 9c98448934edb45efd35a2bf4eed8bfbffee9c4b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 21 Jul 2021 10:44:08 -0600 Subject: [PATCH 045/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 5e3cbf87e..c44fe3669 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5e3cbf87ef85525cdc171fe0de46d0450bf5812e +Subproject commit c44fe3669ed3ab43ac34ac3fa686122576740b7b From de2e423123e11ab663399069bf82087696638a86 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 21 Jul 2021 14:33:22 -0600 Subject: [PATCH 046/115] Update submodule pointer for ccpp-physocs --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index c44fe3669..0e0b7f1e8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c44fe3669ed3ab43ac34ac3fa686122576740b7b +Subproject commit 0e0b7f1e888cc250000f051252c41476859d7de3 From cf0969513e9a03a4c5f00166ee8d987201805041 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 24 Jul 2021 16:52:44 -0600 Subject: [PATCH 047/115] Change name of sfc_name2(39) from 'weasd' to 'weasdl' in io/FV3GFS_io.F90 --- ccpp/physics | 2 +- io/FV3GFS_io.F90 | 10 +++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 0e0b7f1e8..638b15998 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 0e0b7f1e888cc250000f051252c41476859d7de3 +Subproject commit 638b159989538b7c7af2c817b7d134434bb8895c diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 5e73ee1c7..ae1d7c72f 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -729,7 +729,11 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta !--- allocate the various containers needed for restarts allocate(sfc_name2(nvar_s2m+nvar_s2o+nvar_s2mp+nvar_s2r)) allocate(sfc_name3(0:nvar_s3+nvar_s3mp)) - allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp+nvar_s2r),sfc_var3ice(nx,ny,Model%kice)) + allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp+nvar_s2r)) + ! Note that this may cause problems with RUC LSM for coldstart runs from GFS data + ! if the initial conditions do contain this variable, because Model%kice is 9 for + ! RUC LSM, but tiice in the initial conditions will only have two vertical layers + allocate(sfc_var3ice(nx,ny,Model%kice)) if (Model%lsm == Model%lsm_noah .or. Model%lsm == Model%lsm_noahmp .or. Model%lsm == Model%lsm_noah_wrfv4 .or. (.not.warm_start)) then allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) @@ -1034,7 +1038,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta 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 - Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) + Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- tsfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) Sfcprop(nb)%zorli(ix) = sfc_var2(i,j,35) !--- zorli (zorl on ice portion of a cell) Sfcprop(nb)%snodl(ix) = sfc_var2(i,j,36) !--- snodl (snowd on land portion of a cell) @@ -1565,7 +1569,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(36) = 'snodl' !snowd on land portion of a cell sfc_name2(37) = 'tsfc' !tsfc composite sfc_name2(38) = 'zorl' !zorl composite - sfc_name2(39) = 'weasd' !weasd on land portion of a cell + sfc_name2(39) = 'weasdl' !weasd on land portion of a cell ! endif if (Model%cplwav) then sfc_name2(nvar2m) = 'zorlwav' !zorl on land portion of a cell From cf1ea3b37528504bf653cf1957db9a55faa841f8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 27 Jul 2021 12:41:46 -0600 Subject: [PATCH 048/115] Revert change to .gitmodules and update submodule pointers for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index b9027f094..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main_20210721 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20210721 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index bbfa67379..fc8b18605 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit bbfa6737924496fff4581e20d367cf3f4f8f1aa4 +Subproject commit fc8b18605e8b174c717f57f8dfb95ae5e48ed1e4 diff --git a/ccpp/physics b/ccpp/physics index 638b15998..ff1d96984 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 638b159989538b7c7af2c817b7d134434bb8895c +Subproject commit ff1d96984e2ad04b306d158773021cb1537af915 From 81c9a02b40d33aecaa0e03a6541e42696e30249a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 28 Jul 2021 16:36:12 -0600 Subject: [PATCH 049/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 6 ++++-- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..a62db12d3 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,7 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/hannahcbarnes/ccpp-physics + branch = GF_RadiationUpdate_RevertAerosols diff --git a/ccpp/physics b/ccpp/physics index ff1d96984..eb0efcaca 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ff1d96984e2ad04b306d158773021cb1537af915 +Subproject commit eb0efcaca497c02f3ab11fe5e7d4e9445bafd31d From 16c2b7c5736e10130b193f27d891da3642a2c021 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 4 Aug 2021 15:01:36 -0600 Subject: [PATCH 050/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 3 ++- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..e000fb498 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,6 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics + #url = https://github.com/NOAA-GSL/ccpp-physics + url = https://github.com/joeolson42/ccpp-physics branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index ff1d96984..13c0438b1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ff1d96984e2ad04b306d158773021cb1537af915 +Subproject commit 13c0438b15279e61a63cb2b9bc000ed824e202f2 From f6fbd77413572024ac0e6171a6bffb55f1d4e1e7 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 11 Aug 2021 12:25:13 -0600 Subject: [PATCH 051/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 3 +-- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index e000fb498..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,6 +8,5 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - url = https://github.com/joeolson42/ccpp-physics + url = https://github.com/NOAA-GSL/ccpp-physics branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 13c0438b1..d7289c4d7 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 13c0438b15279e61a63cb2b9bc000ed824e202f2 +Subproject commit d7289c4d7754ad7f914aa3744b056f38eee4e1ea From fd511428d35a12ee31a70fee43f49bce616625fe Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 12 Aug 2021 21:22:27 +0000 Subject: [PATCH 052/115] Changed dimensions of variables tsnow_land and sncovr_ice from horizontal_dimension to horizontal_loop_extent --- ccpp/data/GFS_typedefs.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index c9d340fc2..91c5d3fbc 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -631,7 +631,7 @@ standard_name = surface_snow_area_fraction_over_ice long_name = surface snow area fraction over ice units = frac - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) @@ -1460,7 +1460,7 @@ standard_name = snow_temperature_bottom_first_layer_over_land long_name = snow temperature at the bottom of the first snow layer over land units = K - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) From 37391a35331a34ce29db15c4d20e18ab77853522 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 16 Aug 2021 22:01:38 +0000 Subject: [PATCH 053/115] Added Flake to two suites: FV3_GSD_v0 and FV3_HRRR. --- ccpp/suites/suite_FV3_GSD_v0.xml | 1 + ccpp/suites/suite_FV3_HRRR.xml | 1 + 2 files changed, 2 insertions(+) diff --git a/ccpp/suites/suite_FV3_GSD_v0.xml b/ccpp/suites/suite_FV3_GSD_v0.xml index d1b76b3a8..d0b6a0383 100644 --- a/ccpp/suites/suite_FV3_GSD_v0.xml +++ b/ccpp/suites/suite_FV3_GSD_v0.xml @@ -46,6 +46,7 @@ sfc_nst sfc_nst_post lsm_ruc + flake_driver GFS_surface_loop_control_part2 diff --git a/ccpp/suites/suite_FV3_HRRR.xml b/ccpp/suites/suite_FV3_HRRR.xml index c7f76c274..5ba22a8f7 100644 --- a/ccpp/suites/suite_FV3_HRRR.xml +++ b/ccpp/suites/suite_FV3_HRRR.xml @@ -46,6 +46,7 @@ sfc_nst sfc_nst_post lsm_ruc + flake_driver GFS_surface_loop_control_part2 From 56ee817b4af52264decd69c26673d73102da1a1c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 18 Aug 2021 15:52:37 -0600 Subject: [PATCH 054/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 6 ++++-- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..a8018914d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,7 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/tanyasmirnova/ccpp-physics + branch = gsl_dev_11aug21_lake diff --git a/ccpp/physics b/ccpp/physics index d7289c4d7..28a920c57 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d7289c4d7754ad7f914aa3744b056f38eee4e1ea +Subproject commit 28a920c573b2ad476eefee06a78f18b9ab141e26 From cec7cc7e003b89defd2c7c43dfd8b05c3ed93eba Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 09:36:38 -0600 Subject: [PATCH 055/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 87eb895bd..2069121b8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 87eb895bd45687981be9cc858cc0bcebc5c0f04f +Subproject commit 2069121b832069783de0302e2b11875f1e541143 From 309a912cf734c70539d9fe10c8843188291e2a74 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 10:09:07 -0600 Subject: [PATCH 056/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index a8018914d..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/tanyasmirnova/ccpp-physics - branch = gsl_dev_11aug21_lake + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 28a920c57..8c0206785 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 28a920c573b2ad476eefee06a78f18b9ab141e26 +Subproject commit 8c0206785e57a386a4155531e8640eb423b3118e From ba66748b71b2522fb5ef547220b5e01ae9efc866 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 10:17:42 -0600 Subject: [PATCH 057/115] Update to ccpp/data/GFS_typedefs.meta following CCPP standard names update --- ccpp/data/GFS_typedefs.meta | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 8c9cc9c5b..f4e709757 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5738,7 +5738,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) + active = (control_for_deep_convection_scheme == identifier_for_grell_freitas_deep_convection) [imap] standard_name = map_of_block_column_number_to_global_i_index long_name = map of local index ix to global index i for this block diff --git a/ccpp/physics b/ccpp/physics index 4ec7d99a2..163f82d69 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4ec7d99a2e2a8b119019dba14cb71afe57425bf7 +Subproject commit 163f82d69d431a58f95d87e4f22af118bbeb12c2 From 57d535aef350e7f2297602aaf957814f89139624 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 10:57:37 -0600 Subject: [PATCH 058/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 2069121b8..5a7d77536 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 2069121b832069783de0302e2b11875f1e541143 +Subproject commit 5a7d77536025dcfd9a5626fa6466f8fe714341df From c2424dad351c4b020800be4b7b3f7e95c4e11360 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 20:13:24 -0600 Subject: [PATCH 059/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index a62db12d3..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/hannahcbarnes/ccpp-physics - branch = GF_RadiationUpdate_RevertAerosols + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 5a7d77536..3e06bed1a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5a7d77536025dcfd9a5626fa6466f8fe714341df +Subproject commit 3e06bed1a23b051e24c4164746978b4933896eab From ced5cde772a5e657110f30e3ff0d3aab33ef5b98 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 26 Aug 2021 15:40:19 -0600 Subject: [PATCH 060/115] Revert change to .gitmodules and update submodule pointers for ccpp-physics and ccpp-framework --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index 917c6bd3c..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main_20210819 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20210819 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index 3fb21e693..5e410f3c6 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 3fb21e693c278a4afdef74e2c7b0c8d11913e1f7 +Subproject commit 5e410f3c65e55172e4e18ac0f964bfd3bd54e27c diff --git a/ccpp/physics b/ccpp/physics index ab779649f..1263361ce 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ab779649f785f5298819601016d094c3113d3a99 +Subproject commit 1263361ce2411d5ff44910eb9666362a92db42f2 From 3dadef98fc0eb30692714a208e695db22f70d065 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 22 Sep 2021 15:16:45 -0600 Subject: [PATCH 061/115] Revert change to .gitmodules and update submodule pointers for ccpp-framework and ccpp-physics --- .gitmodules | 12 ++++-------- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index e83471c89..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,13 +4,9 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main_20210921 + url = https://github.com/NOAA-GSL/ccpp-framework + branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20210921 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/framework b/ccpp/framework index 1c09cc21e..e0e5a9c9b 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 1c09cc21e90587036503c16c7130a80ecd054ff9 +Subproject commit e0e5a9c9be891212df14d443260773b86a5cfe47 diff --git a/ccpp/physics b/ccpp/physics index 08cd1e2ce..097597ac2 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 08cd1e2cea3672239d3074d5c5046f3ee003f811 +Subproject commit 097597ac2d41657e27e65c380beb584522b16850 From 0f661ab07c2ccccec689ce4ec792642f27253a7e Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 14 Oct 2021 12:53:07 -0600 Subject: [PATCH 062/115] Turn on GF aerosol-awareness Tune clwdet (cloud water detrainment) Make evfact (evaporation factor) and radiation factor scale-aware --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 097597ac2..3a1f931d4 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 097597ac2d41657e27e65c380beb584522b16850 +Subproject commit 3a1f931d4f1f265b96b2128899ff0f580c1d4ab6 From f03f84a2a534bc6d95696d17c2ac8495ec2635f5 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 19 Oct 2021 14:37:24 -0600 Subject: [PATCH 063/115] Update .gitmodules and submodule pointers for ccpp-framework and ccpp-physics for code review and testing --- .gitmodules | 12 ++++++++---- ccpp/framework | 2 +- ccpp/physics | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..aed98d080 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,13 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NOAA-GSL/ccpp-framework - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-framework + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-framework + branch = update_gsl_develop_from_main_20211019 [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsl_develop_from_main_20211019 diff --git a/ccpp/framework b/ccpp/framework index e0e5a9c9b..88faa09f7 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit e0e5a9c9be891212df14d443260773b86a5cfe47 +Subproject commit 88faa09f7629776d7557c3b1a750789702d2aac8 diff --git a/ccpp/physics b/ccpp/physics index 097597ac2..33771449b 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 097597ac2d41657e27e65c380beb584522b16850 +Subproject commit 33771449b4f806a4c6934ad107ad407d12ddcc7a From 45910f095c3ab794ac504a82d065efa3098bb5e0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 19 Oct 2021 15:40:04 -0600 Subject: [PATCH 064/115] Switch back to NCAR ccpp-framework main, abandon NOAA-GSL fork --- .gitmodules | 6 ++---- ccpp/framework | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index d839e6986..1a97b27e0 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,10 +4,8 @@ branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSL/ccpp-framework - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsl_develop_from_main_20211019 + url = https://github.com/NCAR/ccpp-framework + branch = main [submodule "ccpp/physics"] path = ccpp/physics #url = https://github.com/NOAA-GSL/ccpp-physics diff --git a/ccpp/framework b/ccpp/framework index 88faa09f7..6874fc9b4 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 88faa09f7629776d7557c3b1a750789702d2aac8 +Subproject commit 6874fc9b49237b70df7af9b513ea10df697c27d6 From 98b920662fd845d2c9d70e7cd68b6751d3597027 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Wed, 20 Oct 2021 10:00:33 -0600 Subject: [PATCH 065/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 3a1f931d4..097597ac2 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3a1f931d4f1f265b96b2128899ff0f580c1d4ab6 +Subproject commit 097597ac2d41657e27e65c380beb584522b16850 From d87136631afd6c05c56bcfc3dbcacc05d9f5845f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 20 Oct 2021 10:05:24 -0600 Subject: [PATCH 066/115] Update submodule pointer for ccpp/physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 3a1f931d4..dd94d8d5a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3a1f931d4f1f265b96b2128899ff0f580c1d4ab6 +Subproject commit dd94d8d5ad92323e595a693ced8c2cd6d4a9dd41 From 8dbb5a748102076360688a52bd85c240701439ba Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 20 Oct 2021 11:26:53 -0600 Subject: [PATCH 067/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 5 +++-- ccpp/physics | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6d2d19bb4..a87d20d2a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,6 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + url = https://github.com/joeolson42/ccpp-physics + branch = gsl/develop \ No newline at end of file diff --git a/ccpp/physics b/ccpp/physics index dd94d8d5a..8c69c938d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit dd94d8d5ad92323e595a693ced8c2cd6d4a9dd41 +Subproject commit 8c69c938d2546772379b9aba8f6e07f0060854ce From fa64c2b751e11fe180d08f40826bbe6cdcd1ddea Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 20 Oct 2021 16:04:51 -0600 Subject: [PATCH 068/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 8c69c938d..670238119 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8c69c938d2546772379b9aba8f6e07f0060854ce +Subproject commit 6702381194529ba31c14adc5458b3797bf444705 From ef0c510521e9825f0228b1cd627a67d6ab6e1313 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 21 Oct 2021 07:53:09 -0600 Subject: [PATCH 069/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 5 ++--- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index a87d20d2a..6d2d19bb4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,6 +8,5 @@ branch = gsl/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - url = https://github.com/joeolson42/ccpp-physics - branch = gsl/develop \ No newline at end of file + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 670238119..fc43a68a3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 6702381194529ba31c14adc5458b3797bf444705 +Subproject commit fc43a68a3e4c5d37c407deac2898f19a9a2cc408 From 2ea026fc46633457f6e12c52a70f8068f1daae62 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 21 Oct 2021 10:07:43 -0600 Subject: [PATCH 070/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index d52f84bcd..b07a965ec 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d52f84bcd3e8ac1997bd43948c7c5e794f1dd53e +Subproject commit b07a965ecf5223f8e096b98546c86da9449aa120 From c8f3468b8108df2f5adff8f08b38db6bd80d03f3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 22 Oct 2021 14:20:55 -0600 Subject: [PATCH 071/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index 1a97b27e0..554de3eb7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20211019 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index b07a965ec..ba638fa83 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b07a965ecf5223f8e096b98546c86da9449aa120 +Subproject commit ba638fa8320e977bab8ea101407467b0a5684665 From 8423117aa8fbcd9f53be6735fc712603c0b823e3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 25 Oct 2021 16:00:34 -0600 Subject: [PATCH 072/115] Update .gitmodules and submodule pointer for ccpp-physics for code review aand testing --- .gitmodules | 6 ++++-- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 554de3eb7..dba6bff22 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,7 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = gsl_develop_update_from_main_20211025 \ No newline at end of file diff --git a/ccpp/physics b/ccpp/physics index ba638fa83..1fb46c54c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ba638fa8320e977bab8ea101407467b0a5684665 +Subproject commit 1fb46c54c253428b2c845f40c80f45a3499aecd7 From ce003b47ac3510983e3121e6f7e7b176130975f0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 26 Oct 2021 09:00:00 -0600 Subject: [PATCH 073/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 1fb46c54c..5e6eb79f0 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 1fb46c54c253428b2c845f40c80f45a3499aecd7 +Subproject commit 5e6eb79f01e6799d82c0573f322ca44f1469ba97 From 89c1f5086d29c8ad55bca3e309d6ba66bf03696a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 27 Oct 2021 10:38:46 -0600 Subject: [PATCH 074/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index dba6bff22..554de3eb7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = gsl_develop_update_from_main_20211025 \ No newline at end of file + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 5e6eb79f0..5badc29a2 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5e6eb79f01e6799d82c0573f322ca44f1469ba97 +Subproject commit 5badc29a2e7f91032b5df4b3e12cb7b591e9a1b9 From 9eaec467c876149ea04afcbdd036e298c31e3ba5 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 1 Nov 2021 17:25:28 -0600 Subject: [PATCH 075/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 6 ++++-- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 554de3eb7..04acb3d2e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,7 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/tanyasmirnova/ccpp-physics + branch = ruclsm_mynnsfclay diff --git a/ccpp/physics b/ccpp/physics index 5badc29a2..75ccdc03c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5badc29a2e7f91032b5df4b3e12cb7b591e9a1b9 +Subproject commit 75ccdc03c3b9e059505ed792b0b8387f9e569981 From e090b4d4fa268dd1bf57a1a349d5828d0660a3d2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 7 Nov 2021 17:22:50 -0700 Subject: [PATCH 076/115] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 75ccdc03c..3a037aec1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 75ccdc03c3b9e059505ed792b0b8387f9e569981 +Subproject commit 3a037aec11a3f5ce44bda80d5fc74f5430323b43 From af1aeab921d0abbab84a958167d34238f8c70356 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 8 Nov 2021 06:50:17 -0700 Subject: [PATCH 077/115] Revert .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index 04acb3d2e..554de3eb7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/tanyasmirnova/ccpp-physics - branch = ruclsm_mynnsfclay + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 3a037aec1..eb8157c8b 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3a037aec11a3f5ce44bda80d5fc74f5430323b43 +Subproject commit eb8157c8b05507ba737522f7a9a512eb6a1f8bbc From 43bb1bd0b22d5ff35ff92afb9e203517db599367 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 18 Nov 2021 09:48:30 -0700 Subject: [PATCH 078/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index a1d32b437..554de3eb7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,5 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20211116 \ No newline at end of file + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index 12b0f91f7..ce40f9517 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 12b0f91f76bbcbf2ba1a9a03abf0bc1abe20e89a +Subproject commit ce40f95170d2d2cf014011e2071654a131fc7225 From 01d9a8c02455c40d7087f682032e502370d44865 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 23 Nov 2021 15:22:04 -0700 Subject: [PATCH 079/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 7 +++++-- ccpp/physics | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 554de3eb7..7d57ebb18 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,8 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + #url = https://github.com/mdtoy/ccpp-physics + url = https://github.com/climbfuji/ccpp-physics + branch = gsl/develop_SSGWD_bugfix diff --git a/ccpp/physics b/ccpp/physics index ce40f9517..d94281a99 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ce40f95170d2d2cf014011e2071654a131fc7225 +Subproject commit d94281a99204874a5039f2dda9b1cac943e836a7 From c5d2aae164aa31c36fdc505102619cf51886a4d9 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 24 Nov 2021 07:17:16 -0700 Subject: [PATCH 080/115] Revert .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 7 ++----- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index 7d57ebb18..554de3eb7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,8 +8,5 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - #url = https://github.com/mdtoy/ccpp-physics - url = https://github.com/climbfuji/ccpp-physics - branch = gsl/develop_SSGWD_bugfix + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop diff --git a/ccpp/physics b/ccpp/physics index d94281a99..e9e5d08a2 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d94281a99204874a5039f2dda9b1cac943e836a7 +Subproject commit e9e5d08a24651c05312eccef5a5b18fa29b6947c From dd8b65d69a3896510aa1e4d0c1330da7171d8e77 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Dec 2021 10:57:25 -0700 Subject: [PATCH 081/115] Update .gitmodules and submodule pointer for ccpp-physics for code review and testing --- .gitmodules | 6 ++++-- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 554de3eb7..3e2178578 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,7 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + #url = https://github.com/NOAA-GSL/ccpp-physics + #branch = gsl/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsl_develop_from_main_20211215 diff --git a/ccpp/physics b/ccpp/physics index e9e5d08a2..cb5fd666c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e9e5d08a24651c05312eccef5a5b18fa29b6947c +Subproject commit cb5fd666cae8e0e6fdbdacd5143cbfc608760392 From ff7015289c6dcac2278e23ebde03b173d1500713 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Dec 2021 12:22:47 -0700 Subject: [PATCH 082/115] Fix merge conflicts --- ccpp/suites/suite_FV3_HRRR.xml | 2 -- ccpp/suites/suite_FV3_RAP.xml | 1 - ccpp/suites/suite_FV3_RRFS_v1beta.xml | 1 - 3 files changed, 4 deletions(-) diff --git a/ccpp/suites/suite_FV3_HRRR.xml b/ccpp/suites/suite_FV3_HRRR.xml index 4553d1e21..d3408f0ba 100644 --- a/ccpp/suites/suite_FV3_HRRR.xml +++ b/ccpp/suites/suite_FV3_HRRR.xml @@ -46,7 +46,6 @@ sfc_nst sfc_nst_post lsm_ruc - flake_driver GFS_surface_loop_control_part2 @@ -77,7 +76,6 @@ GFS_stochastics - phys_tend diff --git a/ccpp/suites/suite_FV3_RAP.xml b/ccpp/suites/suite_FV3_RAP.xml index d266c8100..66fab81d6 100644 --- a/ccpp/suites/suite_FV3_RAP.xml +++ b/ccpp/suites/suite_FV3_RAP.xml @@ -84,7 +84,6 @@ GFS_stochastics - phys_tend diff --git a/ccpp/suites/suite_FV3_RRFS_v1beta.xml b/ccpp/suites/suite_FV3_RRFS_v1beta.xml index d933ce524..51e0f03cb 100644 --- a/ccpp/suites/suite_FV3_RRFS_v1beta.xml +++ b/ccpp/suites/suite_FV3_RRFS_v1beta.xml @@ -78,7 +78,6 @@ GFS_stochastics - phys_tend From 2c2f799982bd96b0a86ff201e4cb76e5fa059f0a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Dec 2021 13:34:33 -0700 Subject: [PATCH 083/115] Revert change to .gitmodules and update submodule pointer for ccpp-physics --- .gitmodules | 6 ++---- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index 2a98c47c7..be0d808ba 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,10 +8,8 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSL/ccpp-physics - #branch = gsl/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsl_develop_from_main_20211215 + url = https://github.com/NOAA-GSL/ccpp-physics + branch = gsl/develop [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP diff --git a/ccpp/physics b/ccpp/physics index cb5fd666c..4530b2ce8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit cb5fd666cae8e0e6fdbdacd5143cbfc608760392 +Subproject commit 4530b2ce8eb5c764b11f8c8c00fe93f3e2d5fa3f From 1679dc03e65fad13a0bbad667a373a1b82433748 Mon Sep 17 00:00:00 2001 From: Joseph Olson Date: Tue, 15 Feb 2022 14:13:09 -0700 Subject: [PATCH 084/115] Updates to MYNN-EDMF, part II - goes with PR for ccpp-physics (#121) * Updates to MYNN-EDMF, part II - goes with mods for ccpp-physics * updating default mixing length option to 1 * Changing eq to eqv for logical if-then tests. * Removing .eq. and .eqv. from logical if-then tests. * point to top of gsl/develop for ccpp/physics Co-authored-by: Samuel Trahan --- ccpp/data/GFS_typedefs.F90 | 42 +++++++++++++++++------ ccpp/data/GFS_typedefs.meta | 67 ++++++++++++++++++++++++++++++------- ccpp/physics | 2 +- 3 files changed, 86 insertions(+), 25 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 3be66033f..ad47cece0 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1014,19 +1014,18 @@ module GFS_typedefs logical :: do_mynnedmf logical :: do_mynnsfclay ! DH* TODO - move this to MYNN namelist section - integer :: grav_settling !< flag for initalizing fist time step - integer :: bl_mynn_tkebudget !< flag for activating TKE budget + logical :: bl_mynn_tkebudget !< flag for activating TKE budget logical :: bl_mynn_tkeadvect !< activate computation of TKE advection (not yet in use for FV3) integer :: bl_mynn_cloudpdf !< flag to determine which cloud PDF to use integer :: bl_mynn_mixlength !< flag for different version of mixing length formulation integer :: bl_mynn_edmf !< flag to activate the mass-flux scheme integer :: bl_mynn_edmf_mom !< flag to activate the transport of momentum integer :: bl_mynn_edmf_tke !< flag to activate the transport of TKE - integer :: bl_mynn_edmf_part !< flag to partitioning og the MF and ED areas integer :: bl_mynn_cloudmix !< flag to activate mixing of cloud species integer :: bl_mynn_mixqt !< flag to mix total water or individual species integer :: bl_mynn_output !< flag to initialize and write out extra 3D arrays integer :: icloud_bl !< flag for coupling sgs clouds to radiation + real(kind=kind_phys) :: bl_mynn_closure !< flag to determine closure level of MYNN real(kind=kind_phys) :: var_ric real(kind=kind_phys) :: coef_ric_l real(kind=kind_phys) :: coef_ric_s @@ -1616,6 +1615,11 @@ module GFS_typedefs integer, pointer :: ktop_plume (:) => null() ! real (kind=kind_phys), pointer :: exch_h (:,:) => null() ! real (kind=kind_phys), pointer :: exch_m (:,:) => null() ! + real (kind=kind_phys), pointer :: dqke (:,:) => null() !< timestep change of tke + real (kind=kind_phys), pointer :: qwt (:,:) => null() !< vertical transport of tke + real (kind=kind_phys), pointer :: qshear (:,:) => null() !< shear production of tke + real (kind=kind_phys), pointer :: qbuoy (:,:) => null() !< buoyancy production of tke + real (kind=kind_phys), pointer :: qdiss (:,:) => null() !< dissipation of tke ! Output - only in physics real (kind=kind_phys), pointer :: u10m (:) => null() !< 10 meter u/v wind speed @@ -3352,19 +3356,20 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: do_mynnedmf = .false. !< flag for MYNN-EDMF logical :: do_mynnsfclay = .false. !< flag for MYNN Surface Layer Scheme ! DH* TODO - move to MYNN namelist section - integer :: grav_settling = 0 - integer :: bl_mynn_tkebudget = 0 + logical :: bl_mynn_tkebudget = .false. logical :: bl_mynn_tkeadvect = .false. integer :: bl_mynn_cloudpdf = 2 - integer :: bl_mynn_mixlength = 2 - integer :: bl_mynn_edmf = 0 + integer :: bl_mynn_mixlength = 1 + integer :: bl_mynn_edmf = 1 integer :: bl_mynn_edmf_mom = 1 integer :: bl_mynn_edmf_tke = 0 - integer :: bl_mynn_edmf_part = 0 integer :: bl_mynn_cloudmix = 1 integer :: bl_mynn_mixqt = 0 integer :: bl_mynn_output = 0 integer :: icloud_bl = 1 + real(kind=kind_phys) :: bl_mynn_closure = 2.6 !< <= 2.5 only prognose tke + !< 2.5 < and < 3.0, prognose tke and q'2 + !< >= 3.0, prognose tke, q'2, T'2, and T'q' real(kind=kind_phys) :: var_ric = 1.0 real(kind=kind_phys) :: coef_ric_l = 0.16 real(kind=kind_phys) :: coef_ric_s = 0.25 @@ -3608,8 +3613,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & do_mynnedmf, do_mynnsfclay, & ! DH* TODO - move to MYNN namelist section bl_mynn_cloudpdf, bl_mynn_edmf, bl_mynn_edmf_mom, & - bl_mynn_edmf_tke, bl_mynn_edmf_part, bl_mynn_cloudmix, & + bl_mynn_edmf_tke, bl_mynn_mixlength, bl_mynn_cloudmix, & bl_mynn_mixqt, bl_mynn_output, icloud_bl, bl_mynn_tkeadvect, & + bl_mynn_closure, bl_mynn_tkebudget, & ! *DH gwd_opt, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & @@ -4286,9 +4292,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%bl_mynn_cloudmix = bl_mynn_cloudmix Model%bl_mynn_mixqt = bl_mynn_mixqt Model%bl_mynn_output = bl_mynn_output - Model%bl_mynn_edmf_part = bl_mynn_edmf_part Model%bl_mynn_tkeadvect = bl_mynn_tkeadvect - Model%grav_settling = grav_settling + Model%bl_mynn_closure = bl_mynn_closure + Model%bl_mynn_tkebudget = bl_mynn_tkebudget Model%icloud_bl = icloud_bl Model%var_ric = var_ric Model%coef_ric_l = coef_ric_l @@ -6643,6 +6649,13 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%det_thl (IM,Model%levs)) allocate (Diag%det_sqv (IM,Model%levs)) endif + if (Model%bl_mynn_tkebudget) then + allocate (Diag%dqke (IM,Model%levs)) + allocate (Diag%qwt (IM,Model%levs)) + allocate (Diag%qshear (IM,Model%levs)) + allocate (Diag%qbuoy (IM,Model%levs)) + allocate (Diag%qdiss (IM,Model%levs)) + endif allocate (Diag%nupdraft (IM)) allocate (Diag%maxmf (IM)) allocate (Diag%ktop_plume(IM)) @@ -6660,6 +6673,13 @@ subroutine diag_create (Diag, IM, Model) Diag%det_thl = clear_val Diag%det_sqv = clear_val endif + if (Model%bl_mynn_tkebudget) then + Diag%dqke = clear_val + Diag%qwt = clear_val + Diag%qshear = clear_val + Diag%qbuoy = clear_val + Diag%qdiss = clear_val + endif Diag%nupdraft = 0 Diag%maxmf = clear_val Diag%ktop_plume = 0 diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index f95931c1b..5e4e03735 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5302,18 +5302,12 @@ units = flag dimensions = () type = logical -[grav_settling] - standard_name = control_for_gravitational_settling_of_cloud_droplets - long_name = flag to activate gravitational setting of fog - units = flag - dimensions = () - type = integer [bl_mynn_tkebudget] standard_name = control_for_tke_budget_output long_name = flag for activating TKE budget units = flag dimensions = () - type = integer + type = logical [bl_mynn_tkeadvect] standard_name = flag_for_tke_advection long_name = flag for activating TKE advection @@ -5350,12 +5344,6 @@ units = flag dimensions = () type = integer -[bl_mynn_edmf_part] - standard_name = control_for_edmf_partitioning_in_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to partitioning og the MF and ED areas - units = flag - dimensions = () - type = integer [bl_mynn_cloudmix] standard_name = control_for_cloud_species_mixing_in_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to activate mixing of cloud species @@ -5374,6 +5362,12 @@ units = flag dimensions = () type = integer +[bl_mynn_closure] + standard_name = control_for_closure_level_in_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to determine the closure level for the mynn + units = flag + dimensions = () + type = real [icloud_bl] standard_name = control_for_sgs_cloud_radiation_coupling_in_mellor_yamamda_nakanishi_niino_pbl_scheme long_name = flag for coupling sgs clouds to radiation @@ -7232,6 +7226,46 @@ type = real kind = kind_phys active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. (control_for_additional_diagnostics_in_mellor_yamada_nakanishi_niino_pbl_scheme .ne. 0)) +[dqke] + standard_name = total_time_rate_of_change_of_tke + long_name = total tke tendency + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. control_for_tke_budget_output) +[qwt] + standard_name = tke_tendency_due_to_vertical_transport + long_name = tke tendency due to vertical transport and diffusion + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. control_for_tke_budget_output) +[qshear] + standard_name = tke_tendency_due_to_shear + long_name = tke tendency due to shear + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. control_for_tke_budget_output) +[qbuoy] + standard_name = tke_tendency_due_to_buoyancy + long_name = tke tendency due to buoyancy production or consumption + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. control_for_tke_budget_output) +[qdiss] + standard_name = tke_tendency_due_to_dissipation + long_name = tke tendency due to the dissipation of tke + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme .and. control_for_tke_budget_output) [nupdraft] standard_name = number_of_plumes long_name = number of plumes per grid column @@ -9373,6 +9407,13 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys +[save_q(:,:,index_of_snow_mixing_ratio_in_tracer_concentration_array)] + standard_name = snow_mixing_ratio_save + long_name = cloud snow mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys [save_q(:,:,index_of_specific_humidity_in_tracer_concentration_array)] standard_name = water_vapor_specific_humidity_save long_name = water vapor specific humidity before entering a physics scheme diff --git a/ccpp/physics b/ccpp/physics index 4530b2ce8..7943b5b96 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4530b2ce8eb5c764b11f8c8c00fe93f3e2d5fa3f +Subproject commit 7943b5b968909a274322d8aadd6865eeba34b8ad From b76d1fbffe20f61ebf83adea1f0622e54b460570 Mon Sep 17 00:00:00 2001 From: Joseph Olson Date: Thu, 24 Feb 2022 13:56:53 -0700 Subject: [PATCH 085/115] Add a cloud fraction to GF scheme, and separate frozen subgrid clouds into snow and ice This modification adds: 1. A new cloud fraction (Chaboureau and Bechtold 2005) for the GF convection scheme 2. The capability to separate frozen subgrid clouds into both snow and ice (no longer just ice). --- ccpp/data/GFS_typedefs.F90 | 9 ++++++--- ccpp/data/GFS_typedefs.meta | 15 ++++++++------- ccpp/driver/GFS_restart.F90 | 14 +++++++++++++- ccpp/physics | 2 +- 4 files changed, 28 insertions(+), 12 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index ad47cece0..5190b7bc0 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1418,6 +1418,7 @@ module GFS_typedefs !--- Diagnostic that needs to be carried over to the next time step (removed from diag_type) real (kind=kind_phys), pointer :: hpbl (:) => null() !< Planetary boundary layer height + real (kind=kind_phys), pointer :: ud_mf (:,:) => null() !< updraft mass flux !--- dynamical forcing variables for Grell-Freitas convection real (kind=kind_phys), pointer :: forcet (:,:) => null() !< @@ -2072,7 +2073,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: tsurf_ice(:) => null() !< real (kind=kind_phys), pointer :: tsurf_land(:) => null() !< real (kind=kind_phys), pointer :: tsurf_water(:) => null() !< - real (kind=kind_phys), pointer :: ud_mf(:,:) => null() !< real (kind=kind_phys), pointer :: uustar_ice(:) => null() !< real (kind=kind_phys), pointer :: uustar_land(:) => null() !< real (kind=kind_phys), pointer :: uustar_water(:) => null() !< @@ -6045,6 +6045,11 @@ subroutine tbd_create (Tbd, IM, Model) allocate (Tbd%hpbl (IM)) Tbd%hpbl = clear_val + if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + allocate(Tbd%ud_mf(IM, Model%levs)) + Tbd%ud_mf = zero + endif + if (Model%imfdeepcnv == Model%imfdeepcnv_gf .or. Model%imfdeepcnv == Model%imfdeepcnv_ntiedtke) then allocate(Tbd%forcet(IM, Model%levs)) allocate(Tbd%forceq(IM, Model%levs)) @@ -7175,7 +7180,6 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%tsurf_ice (IM)) allocate (Interstitial%tsurf_land (IM)) allocate (Interstitial%tsurf_water (IM)) - allocate (Interstitial%ud_mf (IM,Model%levs)) allocate (Interstitial%uustar_ice (IM)) allocate (Interstitial%uustar_land (IM)) allocate (Interstitial%uustar_water (IM)) @@ -7860,7 +7864,6 @@ subroutine interstitial_phys_reset (Interstitial, Model) Interstitial%tsurf_ice = Model%huge Interstitial%tsurf_land = Model%huge Interstitial%tsurf_water = Model%huge - Interstitial%ud_mf = clear_val Interstitial%uustar_ice = Model%huge Interstitial%uustar_land = Model%huge Interstitial%uustar_water = Model%huge diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 5e4e03735..a45b55866 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5777,6 +5777,14 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[ud_mf] + standard_name = instantaneous_atmosphere_updraft_convective_mass_flux + long_name = (updraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = ( control_for_deep_convection_scheme .ge. 0 .or. control_for_shallow_convection_scheme .ge. 0 ) [in_nm] standard_name = ice_nucleation_number_from_climatology long_name = ice nucleation number in MG MP @@ -9739,13 +9747,6 @@ units = count dimensions = () type = integer -[ud_mf] - standard_name = instantaneous_atmosphere_updraft_convective_mass_flux - long_name = (updraft mass flux) * delt - units = kg m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys [uustar_water] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index e4c4061f1..07d52a8f0 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -126,6 +126,10 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & if(Model%lrefres) then Restart%num3d = Model%ntot3d+1 endif + ! General Convection + if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + Restart%num3d = Restart%num3d + 1 + endif ! GF if (Model%imfdeepcnv == 3) then Restart%num3d = Restart%num3d + 3 @@ -336,12 +340,20 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%data(nb,num)%var3p => IntDiag(nb)%refl_10cm(:,:) enddo endif - if (Model%lrefres) then num = Model%ntot3d+1 else num = Model%ntot3d endif + + !--Convection variable used in CB cloud fraction + if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + num = num + 1 + Restart%name3d(num) = 'cnv_3d_ud_mf' + do nb = 1,nblks + Restart%data(nb,num)%var3p => Tbd(nb)%ud_mf(:,:) + enddo + endif !--- RAP/HRRR-specific variables, 3D ! GF if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then diff --git a/ccpp/physics b/ccpp/physics index 7943b5b96..84b76468d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 7943b5b968909a274322d8aadd6865eeba34b8ad +Subproject commit 84b76468d8fced8fba8c7fa1593bfd0a25a11f15 From 03bfaee92db193d80e64f41abd5e6e1d5dd46667 Mon Sep 17 00:00:00 2001 From: Christina Holt <56881914+christinaholtNOAA@users.noreply.github.com> Date: Tue, 8 Mar 2022 10:32:07 -0600 Subject: [PATCH 086/115] Merge NOAA-EMC develop into gsl/develop (#126) * Feature/ccpp codeowners (#442) * Per-file CODEOWNERS in ccpp/physics to set up automatic review requests * Code cleanup. Remove used code/variables. Fix minor inconsistencies. (#440) * Remove ESMF Alarm and TimeInterval variables from module_fv3_config. * Variables nfhmax, nfhmax_hf are unused outside InitializeAdvertise. Declared them as local variables. * There is no need to keep duplicates of all time related variables in atm_int_state when we can easily access them from atm_int_state%Atm. * Remove redundant call to fms_init * Add few missing ESMF_LogFoundError checks in module_fcst_grid_comp.F90 * Delete time_utils.F90. Unused. * print only actual errors to stderr, everything else to stdout * Move realizeConnectedCplFields to module_cplfields from module_cap_cpl * Declare Atmos as module variable, and remove atmos_internalstate_wrapper * Move code from clock_cplIntval to InitializeAdvertise * Removed INTERNAL_FILE_NML from atmos_model.F90 * CCPP cloud cover change for Thompson MP associated with Xu Randall (#443) * Remove old comments from GFS_typedefs.F90. * Update logic that sets Model%cnvcld = .false. * Wrapper for ccpp-physics #806, #807, #813 (#447) * CCPP physics updates from PR #806(only diagnostic changes for RRTMGP - small diag-only RT impact for tests involving RRTMGP),#807 (only aborting model if sfc emis file not present when needed) ,#813(only SCM-specific physics changes) * Wrapper for ccpp-physics #808 and 816 (roughness length over ice and NoahMP tsurf bugfix) (#452) This PR contains the ccpp physics PR #808 and #816. 808 addresses an error in the momentum roughness length over tiles with ice. 816 fixes an occasional segfault bug related to the tsurf variable in NoahMP and updates to "improve snow simulation in NoahMP for P8". * Use 'model set run clock' routine in FV3 NUOPC cap. (#450) * Add 'SetRunClock' specialization routine to FV3 NUOPC cap, which sets fv3 model clock. FV3 cap does not keep local copy of clock (clock_fv3) as saved module variable anymore. * Minor code cleanup. * Clean up iovr=4 (exponential cloud overlapping method) in RRTMG (#445) Clean up the exponential cloud overlapping method in RRTMG, which reflects the practice of the pre-2018 operational HWRF model. * Bug fix for dimensions of eta level variables and WAM variables in Fortran code and CCPP metadata (#431) * Add additional diagnostic arrays for radiation-microphysics development * Bug fixes for WAM model runs with levr < levs * Update inline post with latest UPP release upp_v10.0.11 (#449) * Update UPP revision * Add foundation temperaure in GFS read interface for inline post. * Wrapper for ccpp-physics #812 (#453) * update submodule pointer for regression testing of ccpp-physics#812 * MYNN sfclay (RAP suite) restart reproducibility, P8 suite definition files (#455) * Fix uninitialized variable zmtnblck in ccpp/data/GFS_typedefs.F90 * Fix typo in CCPP standard name for ncnvwind in ccpp/data/GFS_typedefs.meta * Add ten 2d variables required for MYNNSFC restart reproducibility to ccpp/driver/GFS_restart.F90 * create initial p8 suites, P8 initial SDFs as copies of FV3_GFS_v16_coupled_nsstNoahmpUGWPv1 and FV3_GFS_v16_nsstNoahmpUGWPv1 Co-authored-by: Denise Worthen * Fixes on initializing snow depth over ice and changes z0ice (#461) * modify FV3GFS_io.F90 by fixing errors associated with initializing snow depth over ice in the case where both land and water coexist (i.e. fractional grid case) * z0ice is changed to 1.0 cm from 1.1cm in atmos_model.F90 * Radar-derived microphysics temperature tendencies similar to operational HRRR (#457) - implements a feature of the operational HRRR, radar-derived microphysics temperature tendencies applied in the first N minutes of the forecast to improve clouds in the first few hours. * HRRR-like radar-derived temperature tendencies * Give a warning when convection is enabled with radar tten * Fix uninitialized variable zmtnblck in ccpp/data/GFS_typedefs.F90 * Add ten 2d variables required for MYNNSFC restart reproducibility to ccpp/driver/GFS_restart.F90 * fixing snod bug in atmos_model.F90 (#465) * Thompson MP cloud tuning (#463) * Improve cloud fraction when using Thompson MP. See NCAR/ccpp-physics#809 for more details. * Feature/hwrf legacy (#459) * Added a new suite definition file: suite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml. This SDF is a legacy hwrf SDF but only the GFDL surface layer scheme and the Thompson scheme are kept. * CCPP: Update consistency checks and effective radii calculation for Thompson MP (#462) * This PR updates the submodule pointer for ccpp-physics for the changes described in NCAR/ccpp-physics#786 (Update consistency checks and effective radii calculation for Thompson MP) * Unified write_netcdf, add single file 'cubed_sphere_grid' output (#466) * Unify write_netcdf and write_netcdf_parallel modules. * Add support for writing 'cubed_sphere_grid' history files in a single netcdf file * Code refactoring and cleanup. * Change standard name and unit of CCPP error flag variable in CCPP framework and physics (#467) *Change standard name and unit of CCPP error flag variable in CCPP framework and physics. * Add code to enable ESMF managed threading (#469) * Implement ESMF-managed-threading for fcstComp and wrtComp's. * Revisions to repair iovr=5 cloud overlap option (#471) *This PR addresses part 2 of CCPP issue #748 to activate the exponential-random cloud overlap method (iovr=5) in RRTMG. * Add 2d decomposition on the write grid comp (#470) * update write grid comp to have 2D decomposition on output grid. * combine PR#468: Bug fix in FV3GFS_io.F90 for allocation of temp2d Co-authored-by: Ted Mansell * 4DIAU bug when iau_filter_increments=T (#458) * Add lsm_cold_start variable for RUC LSM SCM support and gwdps bugfix (combined) (#475) * add lsm_cold_start variable in GFS_typedefs.F90/meta and update ccpp/physics for testing * includes @SMoorthi-emc 's bugfix for gwdps.f. * add lon info in the write group (#476) * Multiple output grids (#480) Update fv3 cap and write grid component to enable outputting multiple domains. This is done be creating an array of fcstGrids, and array of rout handles where each element of these arrays correspond to one atm domain. In the write grid component updates were made to allow grid spec parameters for each output grid to be specified separately. Co-authored-by: Gerhard Theurich * GPU-enabled version of Grell-Freitas convection in ccpp-physics (#479) * Enable Thompson MP when coupling with UFS-Aerosols (#484) * Add support for Stochastically Perturbed Parameterizations (SPP) in FV3 and add the FV3_RRFS_v1alpha SDF. (#454) Adds the necessary code in fv3atm to allow for Stochastically Perturbed Parameterizations (SPP) in a set of RAP/HRRR-based physics parameterizations. Specific to the fv3atm repository, code in this PR defines the necessary variables associated with various SPP-related fields (e.g., logical to activate SPP, parameterization-specific SPP variables, etc.) that are then passed to ccpp-physics. * lateral boundary fix for regional runs (#482) * Updating pointer to ccpp/physics. * Point to Christina's branches. * Point to NOAA-GSL gsl/develop for ccpp/physics Co-authored-by: Samuel Trahan (NOAA contractor) <39415369+SamuelTrahanNOAA@users.noreply.github.com> Co-authored-by: Dusan Jovic <48258889+DusanJovic-NOAA@users.noreply.github.com> Co-authored-by: Dom Heinzeller Co-authored-by: Grant Firl Co-authored-by: mzhangw Co-authored-by: WenMeng-NOAA <48260754+WenMeng-NOAA@users.noreply.github.com> Co-authored-by: Denise Worthen Co-authored-by: SMoorthi-emc <47667426+SMoorthi-emc@users.noreply.github.com> Co-authored-by: ChunxiZhang-NOAA <49283036+ChunxiZhang-NOAA@users.noreply.github.com> Co-authored-by: Jun Wang <37633869+junwang-noaa@users.noreply.github.com> Co-authored-by: Ted Mansell Co-authored-by: Jeff Whitaker Co-authored-by: Gerhard Theurich Co-authored-by: DomHeinzeller <58610420+DomHeinzeller@users.noreply.github.com> Co-authored-by: Raffaele Montuoro Co-authored-by: JeffBeck-NOAA <55201531+JeffBeck-NOAA@users.noreply.github.com> Co-authored-by: MatthewPyle-NOAA <48285220+MatthewPyle-NOAA@users.noreply.github.com> Co-authored-by: samuel.trahan --- CMakeLists.txt | 1 - atmos_cubed_sphere | 2 +- atmos_model.F90 | 123 +- ccpp/data/CCPP_typedefs.F90 | 4 +- ccpp/data/GFS_typedefs.F90 | 262 +++- ccpp/data/GFS_typedefs.meta | 182 ++- ccpp/driver/GFS_diagnostics.F90 | 152 ++- ccpp/driver/GFS_restart.F90 | 107 +- ccpp/framework | 2 +- ccpp/physics | 2 +- ccpp/suites/suite_FV3_GFS_v16_coupled_p8.xml | 95 ++ ccpp/suites/suite_FV3_GFS_v16_p8.xml | 28 +- ...ite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml} | 20 +- ccpp/suites/suite_FV3_RRFS_v1alpha.xml | 84 ++ cpl/module_block_data.F90 | 13 + cpl/module_cap_cpl.F90 | 337 +---- cpl/module_cplfields.F90 | 165 ++- fv3_cap.F90 | 499 +++---- io/FV3GFS_io.F90 | 89 +- io/inline_post.F90 | 30 +- io/module_fv3_io_def.F90 | 26 +- io/module_write_internal_state.F90 | 4 +- io/module_write_netcdf.F90 | 1019 ++++++++++----- io/module_write_netcdf_parallel.F90 | 627 --------- io/module_wrt_grid_comp.F90 | 1154 ++++++++--------- io/post_gfs.F90 | 17 +- io/post_regional.F90 | 87 +- module_fcst_grid_comp.F90 | 983 +++++++------- module_fv3_config.F90 | 10 +- .../stochastic_physics_wrapper.F90 | 61 +- time_utils.F90 | 170 --- upp | 2 +- 32 files changed, 3202 insertions(+), 3155 deletions(-) create mode 100644 ccpp/suites/suite_FV3_GFS_v16_coupled_p8.xml rename ccpp/suites/{suite_FV3_HAFS_v0_hwrf_thompson.xml => suite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml} (93%) create mode 100644 ccpp/suites/suite_FV3_RRFS_v1alpha.xml delete mode 100644 io/module_write_netcdf_parallel.F90 delete mode 100644 time_utils.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index ec9721ba6..718ba11b4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -43,7 +43,6 @@ add_library(fv3atm cpl/module_cap_cpl.F90 io/FV3GFS_io.F90 io/module_write_netcdf.F90 - io/module_write_netcdf_parallel.F90 io/module_fv3_io_def.F90 io/module_write_internal_state.F90 io/module_wrt_grid_comp.F90 diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index fa86482e4..7ce7aa94b 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit fa86482e48f1d5b594acb369e68b8488de84dc66 +Subproject commit 7ce7aa94b33b5f3cb351867df50a2ad624bb405f diff --git a/atmos_model.F90 b/atmos_model.F90 index 3ac2555e9..291c2bf69 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -74,7 +74,7 @@ module atmos_model_mod use atmosphere_mod, only: atmosphere_scalar_field_halo use atmosphere_mod, only: atmosphere_get_bottom_layer use atmosphere_mod, only: set_atmosphere_pelist -use atmosphere_mod, only: Atm, mygrid +use atmosphere_mod, only: Atm, mygrid, get_nth_domain_info use block_control_mod, only: block_control_type, define_blocks_packed use DYCORE_typedefs, only: DYCORE_data_type, DYCORE_diag_type @@ -113,6 +113,7 @@ module atmos_model_mod public atmos_model_exchange_phase_1, atmos_model_exchange_phase_2 public atmos_model_restart public get_atmos_model_ungridded_dim +public atmos_model_get_nth_domain_info public addLsmask2grid public setup_exportdata !----------------------------------------------------------------------- @@ -125,6 +126,8 @@ module atmos_model_mod integer :: layout(2) ! computer task laytout logical :: regional ! true if domain is regional logical :: nested ! true if there is a nest + integer :: ngrids ! + integer :: mygrid ! integer :: mlon, mlat integer :: iau_offset ! iau running window length logical :: pe ! current pe. @@ -165,7 +168,6 @@ module atmos_model_mod ! DYCORE containers !------------------- type(DYCORE_data_type), allocatable :: DYCORE_Data(:) ! number of blocks -type(DYCORE_diag_type) :: DYCORE_Diag(25) !---------------- ! GFS containers @@ -262,7 +264,7 @@ subroutine update_atmos_radiation_physics (Atmos) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_init step failed') if (GFS_Control%do_sppt .or. GFS_Control%do_shum .or. GFS_Control%do_skeb .or. & - GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca ) then + GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca .or. GFS_Control%do_spp) then !--- call stochastic physics pattern generation / cellular automata call stochastic_physics_wrapper(GFS_control, GFS_data, Atm_block, ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') @@ -380,7 +382,7 @@ subroutine update_atmos_radiation_physics (Atmos) if(GFS_control%print_diff_pgr) then call atmos_timestep_diagnostics(Atmos) endif - + ! Update flag for first time step of time integration GFS_control%first_time_step = .false. @@ -444,7 +446,7 @@ subroutine atmos_timestep_diagnostics(Atmos) enddo pcount = pcount+count enddo - + ! Sum pgr stats from psum/pcount and convert to hPa/hour global avg: sendbuf(1:2) = (/ psum, pcount /) call MPI_Allreduce(sendbuf,recvbuf,2,MPI_DOUBLE_PRECISION,MPI_SUM,GFS_Control%communicator,ierror) @@ -454,7 +456,7 @@ subroutine atmos_timestep_diagnostics(Atmos) sendbuf(1:2) = (/ maxabs, dble(GFS_Control%me) /) call MPI_Allreduce(sendbuf,recvbuf,1,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,GFS_Control%communicator,ierror) call MPI_Bcast(pmaxloc,size(pmaxloc),MPI_DOUBLE_PRECISION,nint(recvbuf(2)),GFS_Control%communicator,ierror) - + if(GFS_Control%me == GFS_Control%master) then 2933 format('At forecast hour ',F9.3,' mean abs pgr change is ',F16.8,' hPa/hr') 2934 format(' max abs change ',F15.10,' bar at tile=',I0,' i=',I0,' j=',I0) @@ -491,23 +493,17 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) type (atmos_data_type), intent(inout) :: Atmos type (time_type), intent(in) :: Time_init, Time, Time_step !--- local variables --- - integer :: unit, ntdiag, ntfamily, i, j, k - integer :: mlon, mlat, nlon, nlat, nlev, sec, dt + integer :: unit, i + integer :: mlon, mlat, nlon, nlat, nlev, sec integer :: ierr, io, logunit - integer :: idx, tile_num + integer :: tile_num integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed - integer :: blk, ibs, ibe, jbs, jbe real(kind=GFS_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 :: p_hydro, hydro logical, save :: block_message = .true. type(GFS_init_type) :: Init_parm integer :: bdat(8), cdat(8) - integer :: ntracers, maxhf, maxh + integer :: ntracers character(len=32), allocatable, target :: tracer_names(:) integer, allocatable, target :: tracer_types(:) integer :: nthrds, nb @@ -533,7 +529,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) 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%nested, Atmos%pelist) + call atmosphere_domain (Atmos%domain, Atmos%layout, Atmos%regional, Atmos%nested, Atmos%ngrids, Atmos%mygrid, Atmos%pelist) call atmosphere_diag_axes (Atmos%axes) call atmosphere_etalvls (Atmos%ak, Atmos%bk, flip=flip_vc) call atmosphere_grid_bdry (Atmos%lon_bnd, Atmos%lat_bnd, global=.false.) @@ -547,7 +543,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) !---------------------------------------------------------------------------------------------- ! initialize atmospheric model - must happen AFTER atmosphere_init so that nests work correctly - IF ( file_exists('input.nml')) THEN + if (file_exists('input.nml')) then read(input_nml_file, nml=atmos_model_nml, iostat=io) ierr = check_nml_error(io, 'atmos_model_nml') endif @@ -635,19 +631,10 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) Init_parm%restart = Atm(mygrid)%flagstruct%warm_start Init_parm%hydrostatic = Atm(mygrid)%flagstruct%hydrostatic -#ifdef INTERNAL_FILE_NML ! allocate required to work around GNU compiler bug 100886 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100886 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 GFS_initialize (GFS_control, GFS_data%Statein, GFS_data%Stateout, GFS_data%Sfcprop, & GFS_data%Coupling, GFS_data%Grid, GFS_data%Tbd, GFS_data%Cldprop, GFS_data%Radtend, & @@ -711,7 +698,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_init step failed') if (GFS_Control%do_sppt .or. GFS_Control%do_shum .or. GFS_Control%do_skeb .or. & - GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca) then + GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca .or. GFS_Control%do_spp) then !--- Initialize stochastic physics pattern generation / cellular automata for first time step call stochastic_physics_wrapper(GFS_control, GFS_data, Atm_block, ierr) @@ -964,7 +951,7 @@ subroutine atmos_model_end (Atmos) use update_ca, only: write_ca_restart type (atmos_data_type), intent(inout) :: Atmos !---local variables - integer :: idx, seconds, ierr + integer :: ierr !----------------------------------------------------------------------- !---- termination routine for atmospheric model ---- @@ -977,7 +964,7 @@ subroutine atmos_model_end (Atmos) ! call write_stoch_restart_atm('RESTART/atm_stoch.res.nc') endif if (GFS_Control%do_sppt .or. GFS_Control%do_shum .or. GFS_Control%do_skeb .or. & - GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca ) then + GFS_Control%lndp_type > 0 .or. GFS_Control%do_ca .or. GFS_Control%do_spp) then if(restart_endfcst) then call write_stoch_restart_atm('RESTART/atm_stoch.res.nc') if (GFS_control%do_ca)then @@ -993,6 +980,8 @@ subroutine atmos_model_end (Atmos) call CCPP_step (step="finalize", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP finalize step failed') + call dealloc_atmos_data_type (Atmos) + end subroutine atmos_model_end ! @@ -1541,53 +1530,6 @@ subroutine update_atmos_chemistry(state, rc) end select end subroutine update_atmos_chemistry -! - -!####################################################################### -! -! -! -! 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) @@ -1623,7 +1565,6 @@ subroutine assign_importdata(jdat, rc) integer :: sphum, liq_wat, ice_wat, o3mr character(len=128) :: impfield_name, fldname type(ESMF_TypeKind_Flag) :: datatype - real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d real(kind=ESMF_KIND_R8), dimension(:,:,:), pointer:: datar83d real(kind=GFS_kind_phys), dimension(:,:), pointer :: datar8 @@ -1634,7 +1575,7 @@ subroutine assign_importdata(jdat, rc) type(ESMF_Grid) :: grid type(ESMF_Field) :: dbgField character(19) :: currtimestring - real (kind=GFS_kind_phys), parameter :: z0ice=1.1 ! (in cm) + real (kind=GFS_kind_phys), parameter :: z0ice=1.0 ! (in cm) ! ! real(kind=GFS_kind_phys), parameter :: himax = 8.0 !< maximum ice thickness allowed @@ -1690,10 +1631,6 @@ subroutine assign_importdata(jdat, rc) if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplIMP,atmos gets ',trim(impfield_name),' datar8=', & datar8(isc,jsc), maxval(datar8), minval(datar8) found = .true. -! gfs physics runs with r8 -! else -! call ESMF_FieldGet(importFields(n),farrayPtr=datar42d,localDE=0, rc=rc) -! datar8 = datar42d endif else if( dimCount == 3) then @@ -2489,7 +2426,7 @@ subroutine assign_importdata(jdat, rc) if (GFS_data(nb)%Sfcprop%fice(ix) >= GFS_control%min_seaice) then GFS_data(nb)%Coupling%hsnoin_cpl(ix) = min(hsmax, GFS_data(nb)%Coupling%hsnoin_cpl(ix) & - / (GFS_data(nb)%Sfcprop%fice(ix)*GFS_data(nb)%Sfcprop%oceanfrac(ix))) + / GFS_data(nb)%Sfcprop%fice(ix)) GFS_data(nb)%Sfcprop%zorli(ix) = z0ice tem = GFS_data(nb)%Sfcprop%tisfc(ix) * GFS_data(nb)%Sfcprop%tisfc(ix) tem = con_sbc * tem * tem @@ -2546,7 +2483,6 @@ subroutine assign_importdata(jdat, rc) rc=0 ! - if (mpp_pe() == mpp_root_pe()) print *,'end of assign_importdata' end subroutine assign_importdata ! @@ -2560,9 +2496,9 @@ subroutine setup_exportdata(rc) integer, optional, intent(out) :: rc !--- local variables - integer :: i, j, k, idx, ix + integer :: i, j, ix integer :: isc, iec, jsc, jec - integer :: ib, jb, nb, nsb, nk + integer :: nb, nk integer :: sphum, liq_wat, ice_wat, o3mr real(GFS_kind_phys) :: rtime, rtimek @@ -2586,7 +2522,6 @@ subroutine setup_exportdata(rc) jsc = Atm_block%jsc jec = Atm_block%jec nk = Atm_block%npz - nsb = Atm_block%blkno(isc,jsc) rtime = one / GFS_control%dtp rtimek = GFS_control%rho_h2o * rtime @@ -2895,7 +2830,6 @@ subroutine addLsmask2grid(fcstGrid, rc) integer isc, iec, jsc, jec integer i, j, nb, ix ! integer CLbnd(2), CUbnd(2), CCount(2), TLbnd(2), TUbnd(2), TCount(2) - type(ESMF_StaggerLoc) :: staggerloc integer, allocatable :: lsmask(:,:) integer(kind=ESMF_KIND_I4), pointer :: maskPtr(:,:) ! @@ -2947,5 +2881,14 @@ subroutine addLsmask2grid(fcstGrid, rc) end subroutine addLsmask2grid !------------------------------------------------------------------------------ + subroutine atmos_model_get_nth_domain_info(n, layout, nx, ny, pelist) + integer, intent(in) :: n + integer, intent(out) :: layout(2) + integer, intent(out) :: nx, ny + integer, pointer, intent(out) :: pelist(:) + + call get_nth_domain_info(n, layout, nx, ny, pelist) + + end subroutine atmos_model_get_nth_domain_info end module atmos_model_mod diff --git a/ccpp/data/CCPP_typedefs.F90 b/ccpp/data/CCPP_typedefs.F90 index 01695bc4a..1e2171838 100644 --- a/ccpp/data/CCPP_typedefs.F90 +++ b/ccpp/data/CCPP_typedefs.F90 @@ -141,8 +141,8 @@ subroutine interstitial_create (Interstitial, is, ie, isd, ied, js, je, jsd, jed ! For multi-gases physics integer, intent(in) :: nwat integer, intent(in), optional :: ngas - real(kind_dyn), intent(in), optional :: rilist(:) - real(kind_dyn), intent(in), optional :: cpilist(:) + real(kind_dyn), intent(in), optional :: rilist(0:) + real(kind_dyn), intent(in), optional :: cpilist(0:) integer, intent(in) :: mpirank integer, intent(in) :: mpiroot ! diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 5190b7bc0..1dd3a1cc3 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -48,6 +48,10 @@ module GFS_typedefs integer, parameter :: naux2dmax = 20 !< maximum number of auxiliary 2d arrays in output (for debugging) integer, parameter :: naux3dmax = 20 !< maximum number of auxiliary 3d arrays in output (for debugging) + integer, parameter :: dfi_radar_max_intervals = 4 !< Number of radar-derived temperature tendency and/or convection suppression intervals. Do not change. + + real(kind=kind_phys), parameter :: limit_unspecified = 1e12 !< special constant for "namelist value was not provided" in radar-derived temperature tendency limit range + !> \section arg_table_GFS_typedefs !! \htmlinclude GFS_typedefs.html !! @@ -537,6 +541,11 @@ module GFS_typedefs 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 + real (kind=kind_phys), pointer :: spp_wts_pbl (:,:) => null() ! spp-pbl-perts + real (kind=kind_phys), pointer :: spp_wts_sfc (:,:) => null() ! spp-sfc-perts + real (kind=kind_phys), pointer :: spp_wts_mp (:,:) => null() ! spp-mp-perts + real (kind=kind_phys), pointer :: spp_wts_gwd (:,:) => null() ! spp-gwd-perts + real (kind=kind_phys), pointer :: spp_wts_rad (:,:) => null() ! spp-rad-perts !--- aerosol surface emissions for Thompson microphysics real (kind=kind_phys), pointer :: nwfa2d (:) => null() !< instantaneous water-friendly sfc aerosol source @@ -802,6 +811,15 @@ module GFS_typedefs real(kind=kind_phys) :: tcr real(kind=kind_phys) :: tcrf ! + integer :: num_dfi_radar !< number of timespans with radar-prescribed temperature tendencies + real (kind=kind_phys) :: fh_dfi_radar(1+dfi_radar_max_intervals) !< begin+end of timespans to receive radar-prescribed temperature tendencies + logical :: do_cap_suppress !< enable convection suppression in GF scheme if fh_dfi_radar is specified + real (kind=kind_phys) :: radar_tten_limits(2) !< radar_tten values outside this range (min,max) are discarded + integer :: ix_dfi_radar(dfi_radar_max_intervals) = -1 !< Index within dfi_radar_tten of each timespan (-1 means "none") + integer :: dfi_radar_max_intervals + integer :: dfi_radar_max_intervals_plus_one + + ! logical :: effr_in !< eg to turn on ffective radii for MG logical :: microp_uniform logical :: do_cldliq @@ -1160,6 +1178,16 @@ module GFS_typedefs ! multiple patterns. It wasn't fully coded (and wouldn't have worked ! with nlndp>1, so I just dropped it). If we want to code it properly, ! we'd need to make this dim(6,5). + logical :: do_spp ! Overall flag to turn on SPP or not + integer :: spp_pbl + integer :: spp_sfc + integer :: spp_mp + integer :: spp_rad + integer :: spp_gwd + integer :: n_var_spp + character(len=3) , pointer :: spp_var_list(:) ! dimension here must match n_var_spp in stochy_nml_def + real(kind=kind_phys), pointer :: spp_prt_list(:) ! dimension here must match n_var_spp in stochy_nml_def + !--- tracer handling character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core integer :: ntrac !< number of tracers @@ -1196,6 +1224,7 @@ module GFS_typedefs integer :: index_of_process_conv_trans !< tracer changes caused by convective transport integer :: index_of_process_physics !< tracer changes caused by physics schemes integer :: index_of_process_non_physics !< tracer changes caused by everything except physics schemes + integer :: index_of_process_dfi_radar !< tracer changes caused by radar mp temperature tendency forcing integer :: index_of_process_photochem !< all changes to ozone logical, pointer :: is_photochem(:) => null()!< flags for which processes should be summed as photochemical @@ -1278,6 +1307,7 @@ module GFS_typedefs integer :: kdt !< current forecast iteration logical :: first_time_step !< flag signaling first time step for time integration routine logical :: restart !< flag whether this is a coldstart (.false.) or a warmstart/restart (.true.) + logical :: lsm_cold_start logical :: hydrostatic !< flag whether this is a hydrostatic or non-hydrostatic run integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) @@ -1454,6 +1484,10 @@ module GFS_typedefs real (kind=kind_phys), pointer :: phy_myj_a1t(:) => null() ! real (kind=kind_phys), pointer :: phy_myj_a1q(:) => null() ! + !--- DFI Radar + real (kind=kind_phys), pointer :: dfi_radar_tten(:,:,:) => null() ! + real (kind=kind_phys), pointer :: cap_suppress(:,:) => null() ! + contains procedure :: create => tbd_create !< allocate array data end type GFS_tbd_type @@ -1655,8 +1689,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: tdomzr (:) => null() !< dominant accumulated freezing rain type real (kind=kind_phys), pointer :: tdomip (:) => null() !< dominant accumulated sleet type real (kind=kind_phys), pointer :: tdoms (:) => null() !< dominant accumulated snow type - - real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() ! levs) then + write(0,*) "Logic error, number of radiation levels (levr) cannot exceed number of model levels (levs)" + stop else Model%levr = levr endif @@ -4408,12 +4481,23 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%lndp_type = lndp_type Model%n_var_lndp = n_var_lndp Model%lndp_each_step = lndp_each_step + Model%do_spp = do_spp + Model%n_var_spp = n_var_spp + if (Model%lndp_type/=0) then allocate(Model%lndp_var_list(Model%n_var_lndp)) allocate(Model%lndp_prt_list(Model%n_var_lndp)) Model%lndp_var_list(:) = '' Model%lndp_prt_list(:) = clear_val end if + + if (Model%do_spp) then + allocate(Model%spp_var_list(Model%n_var_spp)) + allocate(Model%spp_prt_list(Model%n_var_spp)) + Model%spp_var_list(:) = '' + Model%spp_prt_list(:) = clear_val + end if + !--- cellular automata options ! force namelist constsitency allocate(Model%vfact_ca(levs)) @@ -4512,17 +4596,18 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%index_of_process_rayleigh_damping = 12 Model%index_of_process_nonorographic_gwd = 13 Model%index_of_process_conv_trans = 14 + Model%index_of_process_dfi_radar = 15 ! Number of processes to sum (last index of prior set) - Model%nprocess_summed = 14 + Model%nprocess_summed = Model%index_of_process_dfi_radar ! Sums of other processes, which must be after nprocess_summed: - Model%index_of_process_physics = 15 - Model%index_of_process_non_physics = 16 - Model%index_of_process_photochem = 17 + Model%index_of_process_physics = Model%nprocess_summed+1 + Model%index_of_process_non_physics = Model%nprocess_summed+2 + Model%index_of_process_photochem = Model%nprocess_summed+3 ! Total number of processes (last index of prior set) - Model%nprocess = 17 + Model%nprocess = Model%index_of_process_photochem ! List which processes should be summed as photochemical: allocate(Model%is_photochem(Model%nprocess)) @@ -4637,6 +4722,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call label_dtend_cause(Model,Model%index_of_process_ozmix,'o3mix','tendency due to ozone mixing ratio') call label_dtend_cause(Model,Model%index_of_process_temp,'temp','tendency due to temperature') call label_dtend_cause(Model,Model%index_of_process_overhead_ozone,'o3column','tendency due to overhead ozone column') + call label_dtend_cause(Model,Model%index_of_process_dfi_radar,'dfi_radar','tendency due to dfi radar mp temperature forcing') call label_dtend_cause(Model,Model%index_of_process_photochem,'photochem','tendency due to photochemical processes') call label_dtend_cause(Model,Model%index_of_process_physics,'phys','tendency due to physics') call label_dtend_cause(Model,Model%index_of_process_non_physics,'nophys','tendency due to non-physics processes', & @@ -4654,6 +4740,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_dcnv,have_dcnv) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_scnv,have_scnv) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_mp,have_mp) + call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_dfi_radar,have_mp .and. Model%num_dfi_radar>0) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_orographic_gwd) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_rayleigh_damping,have_rdamp) call fill_dtidx(Model,dtend_select,Model%index_of_temperature,Model%index_of_process_nonorographic_gwd) @@ -4787,14 +4874,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%kdt = nint(Model%fhour*con_hr/Model%dtp) Model%first_time_step = .true. Model%restart = restart + Model%lsm_cold_start = .not. restart Model%hydrostatic = hydrostatic Model%jdat(1:8) = jdat(1:8) - allocate(Model%si(Model%levr+1)) + allocate(Model%si(Model%levs+1)) !--- 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 - Model%si = (ak + bk * con_p0 - ak(Model%levr+1)) / (con_p0 - ak(Model%levr+1)) + Model%si(1:Model%levs+1) = (ak(1:Model%levs+1) + bk(1:Model%levs+1) * con_p0 - ak(Model%levs+1)) / (con_p0 - ak(Model%levs+1)) Model%sec = 0 Model%yearlen = 365 Model%julian = -9999. @@ -5069,7 +5157,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%num_p3d = 4 Model%num_p2d = 3 Model%shcnvcw = .false. -! Model%ncnd = 1 ! ncnd is the number of cloud condensate types Model%nT2delt = 1 Model%nqv2delt = 2 Model%nTdelt = 3 @@ -5086,7 +5173,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%npdf3d = 3 Model%num_p3d = 4 Model%num_p2d = 3 -! Model%ncnd = 1 if (Model%me == Model%master) print *,'Using Zhao/Carr/Sundqvist Microphysics with PDF Cloud' else if (Model%imp_physics == Model%imp_physics_fer_hires) then ! Ferrier-Aligo scheme @@ -5095,8 +5181,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. - ! DH* REALLY ? -! Model%ncnd = 3 !???????? need to clarify this - Moorthi Model%nleffr = 1 Model%nieffr = 2 Model%nseffr = 3 @@ -5116,7 +5200,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !Model%num_p2d = 1 !Model%pdfcld = .false. !Model%shcnvcw = .false. -! !Model%ncnd = 5 !Model%nleffr = 1 !Model%nieffr = 2 !Model%nseffr = 3 @@ -5128,7 +5211,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. -! Model%ncnd = 5 Model%nleffr = 1 Model%nieffr = 2 Model%nseffr = 3 @@ -5159,7 +5241,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. -! Model%ncnd = 2 Model%nleffr = 2 Model%nieffr = 3 Model%nreffr = 4 @@ -5172,16 +5253,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' Morrison-Gettelman MP requires nwat to be set to 6 - job aborted' stop end if -! if (abs(Model%fprcp) == 1) then -! Model%ncnd = 4 -! elseif (Model%fprcp >= 2) then -! Model%ncnd = 4 -! if (Model%mg_do_graupel .or. Model%mg_do_hail) then -! Model%ncnd = 5 -! endif -! Model%num_p3d = 6 -! Model%ngeffr = 6 -! endif if (Model%me == Model%master) & print *,' Using Morrison-Gettelman double moment microphysics', & ' iaerclm=', Model%iaerclm, ' iccn=', Model%iccn, & @@ -5218,7 +5289,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. -! Model%ncnd = 5 if (nwat /= 6) then print *,' GFDL MP requires nwat to be set to 6 - job aborted' stop @@ -5232,7 +5302,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. - if(Model%do_shoc .or. Model%pdfcld .or. Model%do_mynnedmf) Model%cnvcld = .false. + if(Model%do_shoc .or. Model%pdfcld .or. Model%do_mynnedmf .or. Model%imfdeepcnv == Model%imfdeepcnv_gf) Model%cnvcld = .false. if(Model%cnvcld) Model%ncnvcld3d = 1 !--- get cnvwind index in phy_f2d; last entry in phy_f2d array @@ -5274,7 +5344,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif if (me == Model%master) & - write(0,*) ' num_p3d=', Model%num_p3d, ' num_p2d=', Model%num_p2d, & + write(*,*) ' 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, & @@ -5318,6 +5388,68 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & end subroutine control_initialize + subroutine control_initialize_radar_tten(Model, radar_tten_limits) + implicit none + + ! Helper subroutine for initializing variables for radar-derived + ! temperature tendency or convection suppression. + + class(GFS_control_type) :: Model + real(kind_phys) :: radar_tten_limits(2) + integer :: i + + Model%num_dfi_radar = 0 + do i=1,dfi_radar_max_intervals + if(Model%fh_dfi_radar(i)>-1e10 .and. Model%fh_dfi_radar(i+1)>-1e10) then + Model%num_dfi_radar = Model%num_dfi_radar+1 + Model%ix_dfi_radar(i) = Model%num_dfi_radar + else + Model%ix_dfi_radar(i) = -1 + endif + enddo + + if(Model%num_dfi_radar>0) then + if(radar_tten_limits(1)==limit_unspecified) then + if(radar_tten_limits(2)==limit_unspecified) then + radar_tten_limits(1) = -19 + radar_tten_limits(2) = 19 + if(Model%me==Model%master) then + write(0,*) 'Warning: using internal defaults for radar_tten_limits. If the oceans boil, try different values.' + write(0,'(A,F12.4,A)') 'radar_tten_limits(1) = ',radar_tten_limits(1),' <-- lower limit' + write(0,'(A,F12.4,A)') 'radar_tten_limits(2) = ',radar_tten_limits(2),' <-- upper limit' + endif + else + radar_tten_limits(1) = -abs(radar_tten_limits(2)) + radar_tten_limits(2) = abs(radar_tten_limits(2)) + endif + else if(radar_tten_limits(2)==limit_unspecified) then + radar_tten_limits(1) = -abs(radar_tten_limits(1)) + radar_tten_limits(2) = abs(radar_tten_limits(1)) + else if(radar_tten_limits(1)>radar_tten_limits(2)) then + if(Model%me==Model%master) then + write(0,*) 'Error: radar_tten_limits lower limit is higher than upper!' + write(0,'(A,F12.4,A)') 'radar_tten_limits(1) = ',radar_tten_limits(1),' <-- lower limit' + write(0,'(A,F12.4,A)') 'radar_tten_limits(2) = ',radar_tten_limits(2),' <-- upper limit' + write(0,*) "If you do not want me to apply the prescribed tendencies, just say so! Remove fh_dfi_radar from your namelist." + stop + endif + else + !o! Rejoice !o! Radar_tten_limits had lower and upper bounds. + endif + Model%radar_tten_limits = radar_tten_limits + + if(Model%do_cap_suppress) then + if(Model%me==Model%master .and. Model%imfdeepcnv>=0) then + if(Model%imfdeepcnv/=3) then + write(0,*) 'Warning: untested configuration in use! Radar-derived convection suppression is only supported for the GF deep scheme. That feature will be inactive, but microphysics tendencies will still be enabled. This combination is untested. Beware!' + else + write(0,*) 'Warning: experimental configuration in use! Radar-derived convection suppression is experimental (GF deep scheme with fh_dfi_radar).' + endif + endif + endif + endif + + end subroutine control_initialize_radar_tten !--------------------------- ! GFS_control%init_chemistry @@ -5426,6 +5558,9 @@ subroutine control_print(Model) !--- interface variables class(GFS_control_type) :: Model +!--- local variables + integer :: i + if (Model%me == Model%master) then print *, ' ' print *, 'basic control parameters' @@ -5593,6 +5728,18 @@ subroutine control_print(Model) print *, ' icloud : ', Model%icloud print *, ' ' endif + if (Model%num_dfi_radar>0) then + print *, ' num_dfi_radar : ', Model%num_dfi_radar + print *, ' do_cap_suppress : ', Model%do_cap_suppress + do i = 1, dfi_radar_max_intervals+1 +8888 format(' fh_dfi_radar(',I0,') :',F12.4) + if(Model%fh_dfi_radar(i)>-1e10) then + print 8888,i,Model%fh_dfi_radar(i) + endif + enddo +9999 format(' radar_tten_limits: ', F12.4, ' ... ',F12.4) + print 9999,Model%radar_tten_limits(1),Model%radar_tten_limits(2) + endif print *, 'land/surface model parameters' print *, ' lsm : ', Model%lsm print *, ' lsoil : ', Model%lsoil @@ -5780,6 +5927,8 @@ subroutine control_print(Model) print *, ' lndp_type : ', Model%lndp_type print *, ' n_var_lndp : ', Model%n_var_lndp print *, ' lndp_each_step : ', Model%lndp_each_step + print *, ' do_spp : ', Model%do_spp + print *, ' n_var_spp : ', Model%n_var_spp print *, ' ' print *, 'cellular automata' print *, ' nca : ', Model%nca @@ -5872,6 +6021,7 @@ subroutine control_print(Model) print *, ' sec : ', Model%sec print *, ' first_time_step : ', Model%first_time_step print *, ' restart : ', Model%restart + print *, ' lsm_cold_start : ', Model%lsm_cold_start print *, ' hydrostatic : ', Model%hydrostatic endif @@ -5972,6 +6122,19 @@ subroutine tbd_create (Tbd, IM, Model) Tbd%icsdlw = zero endif +!--- DFI radar forcing + nullify(Tbd%dfi_radar_tten) + nullify(Tbd%cap_suppress) + if(Model%num_dfi_radar>0) then + allocate(Tbd%dfi_radar_tten(IM,Model%levs,Model%num_dfi_radar)) + Tbd%dfi_radar_tten = -20.0 + Tbd%dfi_radar_tten(:,1,:) = zero + if(Model%do_cap_suppress) then + allocate(Tbd%cap_suppress(IM,Model%num_dfi_radar)) + Tbd%cap_suppress(:,:) = zero + endif + endif + !--- ozone and stratosphere h2o needs allocate (Tbd%ozpl (IM,levozp,oz_coeff)) allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) @@ -6819,6 +6982,7 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%tdomzr = zero Diag%tdomip = zero Diag%tdoms = zero + Diag%zmtnblck = zero if(Model%lsm == Model%lsm_noahmp)then Diag%paha = zero @@ -7499,9 +7663,7 @@ subroutine interstitial_setup_tracers(Interstitial, Model) endif if (Model%cplchm) then - ! Only Zhao/Carr/Sundqvist and GFDL microphysics schemes are supported - ! when coupling with chemistry. PBL diffusion of aerosols is only supported - ! for GFDL microphysics and MG microphysics. + ! Only the following microphysics schemes are supported with coupled chemistry if (Model%imp_physics == Model%imp_physics_zhao_carr) then Interstitial%nvdiff = 3 elseif (Model%imp_physics == Model%imp_physics_mg) then @@ -7512,8 +7674,14 @@ subroutine interstitial_setup_tracers(Interstitial, Model) endif elseif (Model%imp_physics == Model%imp_physics_gfdl) then Interstitial%nvdiff = 7 + elseif (Model%imp_physics == Model%imp_physics_thompson) then + if (Model%ltaerosol) then + Interstitial%nvdiff = 12 + else + Interstitial%nvdiff = 9 + endif else - write(0,*) "Only Zhao/Carr/Sundqvist and GFDL microphysics schemes are supported when coupling with chemistry" + write(0,*) "Selected microphysics scheme is not supported when coupling with chemistry" stop endif if (Interstitial%trans_aero) Interstitial%nvdiff = Interstitial%nvdiff + Model%ntchm diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index a45b55866..3c3b31c0c 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -2244,10 +2244,50 @@ type = real kind = kind_phys active = (flag_for_stochastic_skeb_option) +[spp_wts_pbl] + standard_name = spp_weights_for_pbl_scheme + long_name = spp weights for pbl scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (do_stochastically_perturbed_parameterizations) +[spp_wts_sfc] + standard_name = spp_weights_for_surface_layer_scheme + long_name = spp weights for surface layer scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (do_stochastically_perturbed_parameterizations) +[spp_wts_mp] + standard_name = spp_weights_for_microphysics_scheme + long_name = spp weights for microphysics scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (do_stochastically_perturbed_parameterizations) +[spp_wts_gwd] + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (do_stochastically_perturbed_parameterizations) +[spp_wts_rad] + standard_name = spp_weights_for_radiation_scheme + long_name = spp weights for radiation scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (do_stochastically_perturbed_parameterizations) [sfc_wts] standard_name = surface_stochastic_weights_from_coupled_process long_name = weights for stochastic surface physics perturbation - units = none + units = 1 dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) type = real kind = kind_phys @@ -2519,13 +2559,13 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real [bk] standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real [levsp1] standard_name = vertical_interface_dimension @@ -3381,6 +3421,24 @@ dimensions = () type = real kind = kind_phys +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer +[dfi_radar_max_intervals] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer +[dfi_radar_max_intervals_plus_one] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one + long_name = one more than the maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer [effr_in] standard_name = flag_for_cloud_effective_radii long_name = flag for cloud effective radii calculations in GFDL microphysics @@ -3459,6 +3517,32 @@ units = flag dimensions = () type = logical +[radar_tten_limits] + standard_name = allowed_bounds_of_radar_prescribed_tendencies + long_name = allowed bounds of prescribed microphysics temperature tendencies + units = K s-1 + dimensions = (2) + type = real + kind = kind_phys +[do_cap_suppress] + standard_name = flag_for_radar_derived_convection_suppression + long_name = flag for radar-derived convection suppression + units = flag + dimensions = () + type = logical +[fh_dfi_radar] + standard_name = forecast_lead_times_bounding_radar_derived_temperature_or_convection_suppression_intervals + long_name = forecast lead times bounding radar derived temperature or convection suppression intervals + units = h + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one) + type = real + kind = kind_phys +[ix_dfi_radar] + standard_name = indices_with_radar_derived_temperature_or_convection_suppression_data + long_name = indices with radar derived temperature or convection suppression data + units = index + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = integer [shoc_parm(1)] standard_name = pressure_threshold_for_increased_tke_dissipation long_name = pressure below which extra TKE diss. is applied in SHOC @@ -4566,6 +4650,12 @@ units = flag dimensions = () type = logical +[do_spp] + standard_name = do_stochastically_perturbed_parameterizations + long_name = flag for stochastic spp option + units = flag + dimensions = () + type = logical [lndp_type] standard_name = control_for_stochastic_land_surface_perturbation long_name = index for stochastic land surface perturbations type @@ -4594,6 +4684,56 @@ type = character kind = len=3 active = (control_for_stochastic_land_surface_perturbation /= 0) +[n_var_spp] + standard_name = number_of_perturbed_spp_schemes + long_name = number of perturbed spp schemes + units = count + dimensions = () + type = integer +[spp_prt_list] + standard_name =magnitude_of_spp_perturbations + long_name = magnitude of spp perturbations + units = 1 + dimensions = (number_of_spp_schemes_perturbed) + type = real + kind = kind_phys +[spp_var_list] + standard_name = perturbed_spp_schemes + long_name = perturbed spp schemes + units = none + dimensions = (number_of_spp_schemes_perturbed) + type = character + kind = len=3 +[spp_pbl] + standard_name = control_for_pbl_spp_perturbations + long_name = control for pbl spp perturbations + units = count + dimensions = () + type = integer +[spp_sfc] + standard_name = control_for_surface_layer_spp_perturbations + long_name = control for surface layer spp perturbations + units = count + dimensions = () + type = integer +[spp_mp] + standard_name = control_for_microphysics_spp_perturbations + long_name = control for microphysics spp perturbations + units = count + dimensions = () + type = integer +[spp_rad] + standard_name = control_for_radiation_spp_perturbations + long_name = control for radiation spp perturbations + units = count + dimensions = () + type = integer +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count + dimensions = () + type = integer [ntrac] standard_name = number_of_tracers long_name = number of tracers @@ -4720,6 +4860,12 @@ units = index dimensions = () type = integer +[index_of_process_dfi_radar] + standard_name = index_of_radar_derived_microphysics_temperature_forcing_in_cumulative_change_index + long_name = index of radar-derived microphysics temperature forcing in second dimension of array cumulative change index + units = index + dimensions = () + type = integer [index_of_process_physics] standard_name = index_of_all_physics_process_in_cumulative_change_index long_name = index of all physics transport process in second dimension of array cumulative change index @@ -5058,7 +5204,7 @@ dimensions = () type = integer [ncnvwind] - standard_name = index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convectionin_in_xy_dimensioned_restart_array + standard_name = index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection_in_xy_dimensioned_restart_array long_name = the index of surface wind enhancement due to convection in phy f2d units = dimensions = () @@ -5180,6 +5326,12 @@ units = flag dimensions = () type = logical +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started + units = flag + dimensions = () + type = logical [hydrostatic] standard_name = flag_for_hydrostatic_solver long_name = flag for hydrostatic solver from dynamics @@ -5228,7 +5380,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys [dxinv] @@ -5902,14 +6054,14 @@ type = real kind = kind_phys active = (index_of_surface_air_pressure_on_previous_timestep_in_xyz_dimensioned_restart_array > 0) -[phy_f2d(:,index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convectionin_in_xy_dimensioned_restart_array)] +[phy_f2d(:,index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection_in_xy_dimensioned_restart_array)] standard_name = enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection long_name = surface wind enhancement due to convection units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convectionin_in_xy_dimensioned_restart_array > 0) + active = (index_of_enhancement_to_wind_speed_at_surface_adjacent_layer_due_to_convection_in_xy_dimensioned_restart_array > 0) [phy_f3d(:,:,index_of_air_temperature_two_timesteps_back_in_xyz_dimensioned_restart_array)] standard_name = air_temperature_two_timesteps_back long_name = air temperature two timesteps back @@ -6244,6 +6396,22 @@ type = real kind = kind_phys active = (flag_for_mellor_yamada_janjic_surface_layer_scheme .or. flag_for_mellor_yamada_janjic_pbl_scheme) +[dfi_radar_tten] + standard_name = radar_derived_microphysics_temperature_tendency + long_name = radar-derived microphysics temperature tendency + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + active = (number_of_radar_derived_temperature_or_convection_suppression_intervals>0) +[cap_suppress] + standard_name = radar_derived_convection_suppression + long_name = radar-derived convection suppression + units = unitless + dimensions = (horizontal_loop_extent,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + active = (number_of_radar_derived_temperature_or_convection_suppression_intervals>0 .and. flag_for_radar_derived_convection_suppression) ######################################################################## [ccpp-table-properties] diff --git a/ccpp/driver/GFS_diagnostics.F90 b/ccpp/driver/GFS_diagnostics.F90 index 8d9e67cdb..6e4b62337 100644 --- a/ccpp/driver/GFS_diagnostics.F90 +++ b/ccpp/driver/GFS_diagnostics.F90 @@ -138,7 +138,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop type(GFS_init_type), intent(in) :: Init_parm !--- local variables - integer :: idt, idx, num, nb, nblks, NFXR, idtend, ichem, itrac, iprocess + integer :: idt, idx, num, nb, nblks, NFXR, idtend, ichem, itrac, iprocess, i character(len=2) :: xtra real(kind=kind_phys), parameter :: cn_one = 1._kind_phys real(kind=kind_phys), parameter :: cn_100 = 100._kind_phys @@ -2296,6 +2296,71 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo endif + if (Model%do_spp) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'spp_wts_pbl' + ExtDiag(idx)%desc = 'spp pbl perturbation wts' + ExtDiag(idx)%unit = 'm/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%spp_wts_pbl(:,:) + enddo + endif + + if (Model%do_spp) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'spp_wts_sfc' + ExtDiag(idx)%desc = 'spp sfc perturbation wts' + ExtDiag(idx)%unit = 'm/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%spp_wts_sfc(:,:) + enddo + endif + + if (Model%do_spp) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'spp_wts_mp' + ExtDiag(idx)%desc = 'spp mp perturbation wts' + ExtDiag(idx)%unit = 'm/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%spp_wts_mp(:,:) + enddo + endif + + if (Model%do_spp) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'spp_wts_gwd' + ExtDiag(idx)%desc = 'spp gwd perturbation wts' + ExtDiag(idx)%unit = 'm/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%spp_wts_gwd(:,:) + enddo + endif + + if (Model%do_spp) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'spp_wts_rad' + ExtDiag(idx)%desc = 'spp rad perturbation wts' + ExtDiag(idx)%unit = 'm/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%spp_wts_rad(:,:) + enddo + endif + if (Model%lndp_type /= 0) then idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -3476,39 +3541,58 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo end if thompson_extended_diagnostics - !! Cloud effective radii from Microphysics - !if (Model%imp_physics == Model%imp_physics_thompson .or. Model%imp_physics == Model%imp_physics_wsm6 .or. Model%imp_physics == Model%imp_physics_fer_hires) then - ! idx = idx + 1 - ! ExtDiag(idx)%axes = 3 - ! ExtDiag(idx)%name = 'cleffr' - ! ExtDiag(idx)%desc = 'effective radius of cloud liquid water particle' - ! ExtDiag(idx)%unit = 'um' - ! ExtDiag(idx)%mod_name = 'gfs_phys' - ! allocate (ExtDiag(idx)%data(nblks)) - ! do nb = 1,nblks - ! ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nleffr) - ! enddo - ! idx = idx + 1 - ! ExtDiag(idx)%axes = 3 - ! ExtDiag(idx)%name = 'cieffr' - ! ExtDiag(idx)%desc = 'effective radius of stratiform cloud ice particle in um' - ! ExtDiag(idx)%unit = 'um' - ! ExtDiag(idx)%mod_name = 'gfs_phys' - ! allocate (ExtDiag(idx)%data(nblks)) - ! do nb = 1,nblks - ! ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nieffr) - ! enddo - ! idx = idx + 1 - ! ExtDiag(idx)%axes = 3 - ! ExtDiag(idx)%name = 'cseffr' - ! ExtDiag(idx)%desc = 'effective radius of stratiform cloud snow particle in um' - ! ExtDiag(idx)%unit = 'um' - ! ExtDiag(idx)%mod_name = 'gfs_phys' - ! allocate (ExtDiag(idx)%data(nblks)) - ! do nb = 1,nblks - ! ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nseffr) - ! enddo - !endif + do i=1,Model%num_dfi_radar + idx = idx + 1 + ExtDiag(idx)%axes = 3 + if(i>1) then + write(ExtDiag(idx)%name,'(A,I0)') 'radar_tten_',i + else + ExtDiag(idx)%name = 'radar_tten' + endif + write(ExtDiag(idx)%desc,'(A,I0,A,I0)') 'temperature tendency due to dfi radar tendencies ',i,' of ',Model%num_dfi_radar + ExtDiag(idx)%unit = 'K s-1' + ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%time_avg = .FALSE. + + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%dfi_radar_tten(:,:,i) + enddo + enddo + + ! Cloud effective radii from Microphysics + if (Model%imp_physics == Model%imp_physics_thompson .or. Model%imp_physics == Model%imp_physics_fer_hires) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'cleffr' + ExtDiag(idx)%desc = 'effective radius of cloud liquid water particle' + ExtDiag(idx)%unit = 'um' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nleffr) + enddo + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'cieffr' + ExtDiag(idx)%desc = 'effective radius of stratiform cloud ice particle in um' + ExtDiag(idx)%unit = 'um' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nieffr) + enddo + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'cseffr' + ExtDiag(idx)%desc = 'effective radius of stratiform cloud snow particle in um' + ExtDiag(idx)%unit = 'um' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%nseffr) + enddo + endif !MYNN if (Model%do_mynnedmf) then diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index 07d52a8f0..1ffaed4dc 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -60,7 +60,7 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & !--- local variables integer :: idx, ndiag_rst - integer :: ndiag_idx(20) + integer :: ndiag_idx(20), itime integer :: nblks, num, nb, max_rstrt, offset character(len=2) :: c2 = '' @@ -115,14 +115,20 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & endif ! MYNN SFC if (Model%do_mynnsfclay) then - Restart%num2d = Restart%num2d + 1 + Restart%num2d = Restart%num2d + 13 endif ! Thompson aerosol-aware if (Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then Restart%num2d = Restart%num2d + 2 endif + if (Model%do_cap_suppress .and. Model%num_dfi_radar>0) then + Restart%num2d = Restart%num2d + Model%num_dfi_radar + endif Restart%num3d = Model%ntot3d + if (Model%num_dfi_radar>0) then + Restart%num3d = Restart%num3d + Model%num_dfi_radar + endif if(Model%lrefres) then Restart%num3d = Model%ntot3d+1 endif @@ -134,7 +140,7 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & if (Model%imfdeepcnv == 3) then Restart%num3d = Restart%num3d + 3 endif - ! MYNN PBL + ! MYNN PBL if (Model%do_mynnedmf) then Restart%num3d = Restart%num3d + 9 endif @@ -309,6 +315,66 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & do nb = 1,nblks Restart%data(nb,num)%var2p => Sfcprop(nb)%uustar(:) enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_hpbl' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Tbd(nb)%hpbl(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_ustm' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%ustm(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_zol' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%zol(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_mol' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%mol(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_flhc' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%flhc(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_flqc' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%flqc(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_chs2' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%chs2(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_cqs2' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%cqs2(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_lh' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%lh(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_hflx' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%hflx(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_evap' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%evap(:) + enddo + num = num + 1 + Restart%name2d(num) = 'mynn_2d_qss' + do nb = 1,nblks + Restart%data(nb,num)%var2p => Sfcprop(nb)%qss(:) + enddo endif ! Thompson aerosol-aware if (Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then @@ -324,6 +390,23 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & enddo endif + ! Convection suppression + if (Model%do_cap_suppress .and. Model%num_dfi_radar > 0) then + do itime=1,Model%dfi_radar_max_intervals + if(Model%ix_dfi_radar(itime)>0) then + num = num + 1 + if(itime==1) then + Restart%name2d(num) = 'cap_suppress' + else + write(Restart%name2d(num),'("cap_suppress_",I0)') itime + endif + do nb = 1,nblks + Restart%data(nb,num)%var2p => Tbd(nb)%cap_suppress(:,Model%ix_dfi_radar(itime)) + enddo + endif + enddo + endif + !--- phy_f3d variables do num = 1,Model%ntot3d !--- set the variable name @@ -422,6 +505,24 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & enddo endif + ! Radar-derived microphysics temperature tendencies + if (Model%num_dfi_radar > 0) then + do itime=1,Model%dfi_radar_max_intervals + if(Model%ix_dfi_radar(itime)>0) then + num = num + 1 + if(itime==1) then + Restart%name3d(num) = 'radar_tten' + else + write(Restart%name3d(num),'("radar_tten_",I0)') itime + endif + do nb = 1,nblks + Restart%data(nb,num)%var3p => Tbd(nb)%dfi_radar_tten( & + :,:,Model%ix_dfi_radar(itime)) + enddo + endif + enddo + endif + end subroutine GFS_restart_populate end module GFS_restart diff --git a/ccpp/framework b/ccpp/framework index 64b5afd13..a55457fe3 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 64b5afd1352d709f3b72734bf960e36024a838d3 +Subproject commit a55457fe3ef66e1651c94f99e72aba3362b105a2 diff --git a/ccpp/physics b/ccpp/physics index 84b76468d..8c2450b4c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 84b76468d8fced8fba8c7fa1593bfd0a25a11f15 +Subproject commit 8c2450b4c7d2791f80128538bdb18940b3c40b9b diff --git a/ccpp/suites/suite_FV3_GFS_v16_coupled_p8.xml b/ccpp/suites/suite_FV3_GFS_v16_coupled_p8.xml new file mode 100644 index 000000000..423d37f6d --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v16_coupled_p8.xml @@ -0,0 +1,95 @@ + + + + + + + fv_sat_adj + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + GFS_radiation_surface + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + noahmpdrv + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + ugwpv1_gsldrag + ugwpv1_gsldrag_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + gfdl_cloud_microphys + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_v16_p8.xml b/ccpp/suites/suite_FV3_GFS_v16_p8.xml index ef860e66d..8828f503a 100644 --- a/ccpp/suites/suite_FV3_GFS_v16_p8.xml +++ b/ccpp/suites/suite_FV3_GFS_v16_p8.xml @@ -10,7 +10,7 @@ GFS_time_vary_pre - GFS_rrtmgp_setup + GFS_rrtmg_setup GFS_rad_time_vary GFS_phys_time_vary @@ -18,25 +18,15 @@ GFS_suite_interstitial_rad_reset - GFS_rrtmgp_pre + GFS_rrtmg_pre GFS_radiation_surface - GFS_rrtmgp_gfdlmp_pre - GFS_rrtmgp_cloud_overlap_pre - GFS_cloud_diagnostics - GFS_rrtmgp_sw_pre - rrtmgp_sw_gas_optics - rrtmgp_sw_aerosol_optics - rrtmgp_sw_cloud_optics - rrtmgp_sw_cloud_sampling - rrtmgp_sw_rte - GFS_rrtmgp_sw_post - rrtmgp_lw_pre - rrtmgp_lw_gas_optics - rrtmgp_lw_aerosol_optics - rrtmgp_lw_cloud_optics - rrtmgp_lw_cloud_sampling - rrtmgp_lw_rte - GFS_rrtmgp_lw_post + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post diff --git a/ccpp/suites/suite_FV3_HAFS_v0_hwrf_thompson.xml b/ccpp/suites/suite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml similarity index 93% rename from ccpp/suites/suite_FV3_HAFS_v0_hwrf_thompson.xml rename to ccpp/suites/suite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml index 2bc2f8592..652c5eabb 100644 --- a/ccpp/suites/suite_FV3_HAFS_v0_hwrf_thompson.xml +++ b/ccpp/suites/suite_FV3_HAFS_v0_thompson_tedmf_gfdlsf.xml @@ -1,6 +1,6 @@ - + @@ -13,17 +13,15 @@ GFS_suite_interstitial_rad_reset - GFS_rrtmg_pre GFS_radiation_surface - rrtmg_lw_pre - rrtmg_lw - rrtmg_lw_post rrtmg_sw_pre rrtmg_sw rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post GFS_rrtmg_post - @@ -45,7 +43,7 @@ sfc_nst_pre sfc_nst sfc_nst_post - noahmpdrv + lsm_noah sfc_sice GFS_surface_loop_control_part2 @@ -56,7 +54,7 @@ sfc_diag_post GFS_surface_generic_post GFS_PBL_generic_pre - hedmf + satmedmfvdifq GFS_PBL_generic_post GFS_GWD_generic_pre cires_ugwp @@ -65,9 +63,9 @@ GFS_suite_stateout_update ozphys_2015 h2ophys - GFS_DCNV_generic_pre get_phi_fv3 GFS_suite_interstitial_3 + GFS_DCNV_generic_pre samfdeepcnv GFS_DCNV_generic_post GFS_SCNV_generic_pre @@ -77,7 +75,11 @@ cnvc90 GFS_MP_generic_pre mp_thompson_pre + + mp_thompson + + mp_thompson_post GFS_MP_generic_post maximum_hourly_diagnostics diff --git a/ccpp/suites/suite_FV3_RRFS_v1alpha.xml b/ccpp/suites/suite_FV3_RRFS_v1alpha.xml new file mode 100644 index 000000000..b3622828e --- /dev/null +++ b/ccpp/suites/suite_FV3_RRFS_v1alpha.xml @@ -0,0 +1,84 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + noahmpdrv + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_suite_interstitial_4 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/cpl/module_block_data.F90 b/cpl/module_block_data.F90 index 02ef0ebc8..9d2cc9192 100644 --- a/cpl/module_block_data.F90 +++ b/cpl/module_block_data.F90 @@ -71,6 +71,7 @@ subroutine block_copy_1d_i4_to_2d_r8(destin_ptr, source_ptr, block, block_index, if (associated(destin_ptr) .and. associated(source_ptr)) then factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -105,6 +106,7 @@ subroutine block_copy_1d_to_2d_r8(destin_ptr, source_ptr, block, block_index, sc if (associated(destin_ptr) .and. associated(source_ptr)) then factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -144,6 +146,7 @@ subroutine block_copy_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, block, blo if (slice > 0 .and. slice <= size(source_ptr, dim=2)) then factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -182,6 +185,7 @@ subroutine block_copy_2d_to_3d_r8(destin_ptr, source_ptr, block, block_index, sc factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=2) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -219,6 +223,7 @@ subroutine block_copy_2d_to_2d_r8(destin_ptr, source_ptr, block, block_index, sc if (associated(destin_ptr) .and. associated(source_ptr)) then factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -253,6 +258,7 @@ subroutine block_array_copy_2d_to_2d_r8(destin_ptr, source_arr, block, block_ind if (associated(destin_ptr)) then factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -290,6 +296,7 @@ subroutine block_copy_3d_to_3d_r8(destin_ptr, source_ptr, block, block_index, sc factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -326,6 +333,7 @@ subroutine block_array_copy_3d_to_3d_r8(destin_ptr, source_arr, block, block_ind factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor do k = 1, size(source_arr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -367,6 +375,7 @@ subroutine block_copy_3dslice_to_3d_r8(destin_ptr, source_ptr, slice, block, blo factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -407,6 +416,7 @@ subroutine block_array_copy_3dslice_to_3d_r8(destin_ptr, source_arr, slice, bloc factor = 1._kind_phys if (present(scale_factor)) factor = scale_factor do k = 1, size(source_arr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -441,6 +451,7 @@ subroutine block_fill_2d_r8(destin_ptr, fill_value, block, block_index, rc) ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr)) then +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -474,6 +485,7 @@ subroutine block_fill_3d_r8(destin_ptr, fill_value, block, block_index, rc) localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr)) then do k = 1, size(destin_ptr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) @@ -586,6 +598,7 @@ subroutine block_combine_frac_1d_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, bl localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. & associated(fract1_ptr) .and. associated(fract2_ptr)) then +!$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) ib = block%index(block_index)%ii(ix) jb = block%index(block_index)%jj(ix) diff --git a/cpl/module_cap_cpl.F90 b/cpl/module_cap_cpl.F90 index 47f48ce4d..d69f6c989 100644 --- a/cpl/module_cap_cpl.F90 +++ b/cpl/module_cap_cpl.F90 @@ -6,253 +6,15 @@ module module_cap_cpl ! 12 Mar 2018: J. Wang Pull coupled subroutines from fv3_cap.F90 to this module ! use ESMF - use NUOPC - use module_cplfields, only : FieldInfo -! implicit none + private - public clock_cplIntval - ! public realizeConnectedInternCplField - public realizeConnectedCplFields public diagnose_cplFields ! contains !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - subroutine clock_cplIntval(gcomp, CF) - - type(ESMF_GridComp) :: gcomp - type(ESMF_Config) :: CF -! - real(ESMF_KIND_R8) :: medAtmCouplingIntervalSec - type(ESMF_Clock) :: fv3Clock - type(ESMF_TimeInterval) :: fv3Step - integer :: rc -! - call ESMF_ConfigGetAttribute(config=CF, value=medAtmCouplingIntervalSec, & - label="atm_coupling_interval_sec:", default=-1.0_ESMF_KIND_R8, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) - - if (medAtmCouplingIntervalSec > 0._ESMF_KIND_R8) then ! The coupling time step is provided - call ESMF_TimeIntervalSet(fv3Step, s_r8=medAtmCouplingIntervalSec, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) - call ESMF_GridCompGet(gcomp, clock=fv3Clock, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) - call ESMF_ClockSet(fv3Clock, timestep=fv3Step, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif - - end subroutine clock_cplIntval - - !----------------------------------------------------------------------------- - - subroutine addFieldMetadata(field, key, values, rc) - - ! This subroutine implements a preliminary method to provide metadata to - ! a coupled model that is accessing the field via reference sharing - ! (NUOPC SharedStatusField=.true.). The method sets a (key, values) pair - ! in the field's array ESMF_Info object to retrieve an array of strings - ! encoding metadata. - ! - ! Such a capability should be implemented in the standard NUOPC connector - ! for more general applications, possibly providing access to the field's - ! ESMF_Info object. - - type(ESMF_Field) :: field - character(len=*), intent(in) :: key - character(len=*), intent(in) :: values(:) - integer, optional, intent(out) :: rc - - ! local variable - integer :: localrc - type(ESMF_Array) :: array - type(ESMF_Info) :: info - - ! begin - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field, array=array, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - call ESMF_InfoGetFromHost(array, info, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - call ESMF_InfoSet(info, key, values, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - - end subroutine addFieldMetadata - - !----------------------------------------------------------------------------- - -#if 0 - subroutine realizeConnectedInternCplField(state, field, standardName, grid, rc) - - type(ESMF_State) :: state - type(ESMF_Field), optional :: field - character(len=*), optional :: standardName - type(ESMF_Grid), optional :: grid - integer, intent(out), optional :: rc - - ! local variables - character(len=80) :: fieldName - type(ESMF_ArraySpec) :: arrayspec - integer :: i, localrc - logical :: isConnected - real(ESMF_KIND_R8), pointer :: fptr(:,:) - - if (present(rc)) rc = ESMF_SUCCESS - - fieldName = standardName ! use standard name as field name - - !! Create fields using wam2dmesh if they are WAM fields - isConnected = NUOPC_IsConnected(state, fieldName=fieldName, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - - if (isConnected) then - - field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, name=fieldName, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - call NUOPC_Realize(state, field=field, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - - call ESMF_FieldGet(field, farrayPtr=fptr, rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - - fptr=0._ESMF_KIND_R8 ! zero out the entire field - call NUOPC_SetAttribute(field, name="Updated", value="true", rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - - else - ! remove a not connected Field from State - call ESMF_StateRemove(state, (/fieldName/), rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - endif - - end subroutine realizeConnectedInternCplField -#endif - !----------------------------------------------------------------------------- - - subroutine realizeConnectedCplFields(state, grid, & - numLevels, numSoilLayers, numTracers, & - fields_info, state_tag, fieldList, fill_value, rc) - - use field_manager_mod, only: MODEL_ATMOS - use tracer_manager_mod, only: get_number_tracers, get_tracer_names - - type(ESMF_State), intent(inout) :: state - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: numLevels - integer, intent(in) :: numSoilLayers - integer, intent(in) :: numTracers - type(FieldInfo), dimension(:), intent(in) :: fields_info - character(len=*), intent(in) :: state_tag !< Import or export. - type(ESMF_Field), dimension(:), intent(out) :: fieldList - real(ESMF_KIND_R8), optional , intent(in) :: fill_value - integer, intent(out) :: rc - - ! local variables - - integer :: item, pos, tracerCount - logical :: isConnected - type(ESMF_Field) :: field - real(ESMF_KIND_R8) :: l_fill_value - real(ESMF_KIND_R8), parameter :: d_fill_value = 0._ESMF_KIND_R8 - type(ESMF_StateIntent_Flag) :: stateintent - character(len=32), allocatable, dimension(:) :: tracerNames, tracerUnits - - ! begin - rc = ESMF_SUCCESS - - if (present(fill_value)) then - l_fill_value = fill_value - else - l_fill_value = d_fill_value - end if - - ! attach list of tracer names to exported tracer field as metadata - call ESMF_StateGet(state, stateintent=stateintent, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - if (stateintent == ESMF_STATEINTENT_EXPORT) then - call get_number_tracers(MODEL_ATMOS, num_tracers=tracerCount) - allocate(tracerNames(tracerCount), tracerUnits(tracerCount)) - do item = 1, tracerCount - call get_tracer_names(MODEL_ATMOS, item, tracerNames(item), units=tracerUnits(item)) - end do - end if - - do item = 1, size(fields_info) - isConnected = NUOPC_IsConnected(state, fieldName=trim(fields_info(item)%name), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (isConnected) then - call ESMF_StateGet(state, field=field, itemName=trim(fields_info(item)%name), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_FieldEmptySet(field, grid=grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - select case (fields_info(item)%type) - case ('l','layer') - call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1/), ungriddedUBound=(/numLevels/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - case ('i','interface') - call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1/), ungriddedUBound=(/numLevels+1/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - case ('t','tracer') - call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1, 1/), ungriddedUBound=(/numLevels, numTracers/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (allocated(tracerNames)) then - call addFieldMetadata(field, 'tracerNames', tracerNames, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - end if - if (allocated(tracerUnits)) then - call addFieldMetadata(field, 'tracerUnits', tracerUnits, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - end if - case ('s','surface') - call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - case ('g','soil') - call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1/), ungriddedUBound=(/numSoilLayers/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - case default - call ESMF_LogSetError(ESMF_RC_NOT_VALID, & - msg="exportFieldType = '"//trim(fields_info(item)%type)//"' not recognized", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - end select - call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! -- initialize field value - call ESMF_FieldFill(field, dataFillScheme="const", const1=l_fill_value, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! -- save field - fieldList(item) = field - call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fields_info(item)%name) & - // ' is connected ', ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) - else - ! remove a not connected Field from State - call ESMF_StateRemove(state, (/trim(fields_info(item)%name)/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fields_info(item)%name) & - // ' is not connected ', ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) - end if - end do - - if (allocated(tracerNames)) deallocate(tracerNames) - if (allocated(tracerUnits)) deallocate(tracerUnits) - - end subroutine realizeConnectedCplFields - !----------------------------------------------------------------------------- subroutine diagnose_cplFields(gcomp, clock_fv3, fcstpe, & @@ -316,103 +78,6 @@ subroutine diagnose_cplFields(gcomp, clock_fv3, fcstpe, & end subroutine diagnose_cplFields - !----------------------------------------------------------------------------- - - subroutine ESMFPP_RegridWriteState(state, fileName, timeslice, rc) - - type(ESMF_State), intent(in) :: state - character(len=*), intent(in) :: fileName - integer, intent(in) :: timeslice - integer, intent(out) :: rc - - ! local - type(ESMF_Field) :: field - type(ESMF_Grid) :: outGrid - integer :: i, icount - character(64), allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: typeList(:) - - rc = ESMF_SUCCESS - - ! 1degx1deg - outGrid = ESMF_GridCreate1PeriDimUfrm(maxIndex=(/360,180/), & - minCornerCoord=(/0.0_ESMF_KIND_R8,-90.0_ESMF_KIND_R8/), & - maxCornerCoord=(/360.0_ESMF_KIND_R8,90.0_ESMF_KIND_R8/), & - staggerLocList=(/ESMF_STAGGERLOC_CORNER, ESMF_STAGGERLOC_CENTER/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_StateGet(state, itemCount=icount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - allocate(typeList(icount), itemNameList(icount)) - call ESMF_StateGet(state, itemTypeList=typeList, itemNameList=itemNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - do i = 1, icount - if(typeList(i) == ESMF_STATEITEM_FIELD) then - call ESMF_LogWrite("RegridWrite Field Name Initiated: "//trim(itemNameList(i)), ESMF_LOGMSG_INFO) - call ESMF_StateGet(state, itemName=itemNameList(i), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMFPP_RegridWrite(field, outGrid, ESMF_REGRIDMETHOD_BILINEAR, & - fileName//trim(itemNameList(i))//'.nc', trim(itemNameList(i)), timeslice, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_LogWrite("RegridWrite Field Name done: "//trim(itemNameList(i)), ESMF_LOGMSG_INFO) - endif - enddo - - deallocate(typeList, itemNameList) - - call ESMF_GridDestroy(outGrid,noGarbage=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - end subroutine ESMFPP_RegridWriteState - - subroutine ESMFPP_RegridWrite(inField, outGrid, regridMethod, fileName, fieldName, timeslice, rc) - - ! input arguments - type(ESMF_Field), intent(in) :: inField - type(ESMF_Grid), intent(in) :: outGrid - type(ESMF_RegridMethod_Flag), intent(in) :: regridMethod - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: fieldName - integer, intent(in) :: timeslice - integer, intent(inout) :: rc - - ! local variables - integer :: srcTermProcessing - type(ESMF_Routehandle) :: rh - type(ESMF_Field) :: outField - - outField = ESMF_FieldCreate(outGrid, typekind=ESMF_TYPEKIND_R8, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! Perform entire regridding arithmetic on the destination PET - srcTermProcessing = 0 - ! For other options for the regrid operation, please refer to: - ! http://www.earthsystemmodeling.org/esmf_releases/last_built/ESMF_refdoc/node5.html#SECTION050366000000000000000 - call ESMF_FieldRegridStore(inField, outField, regridMethod=regridMethod, & - unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & - srcTermProcessing=srcTermProcessing, Routehandle=rh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! Use fixed ascending order for the sum terms based on their source - ! sequence index to ensure bit-for-bit reproducibility - call ESMF_FieldRegrid(inField, outField, Routehandle=rh, & - termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_FieldWrite(outField, fileName, variableName=fieldName, timeslice=timeslice, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_FieldRegridRelease(routehandle=rh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_FieldDestroy(outField,noGarbage=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - rc = ESMF_SUCCESS - - end subroutine ESMFPP_RegridWrite - !----------------------------------------------------------------------------- ! This subroutine requires ESMFv8 - for coupled FV3 diff --git a/cpl/module_cplfields.F90 b/cpl/module_cplfields.F90 index 380c49c77..68d6f10d8 100644 --- a/cpl/module_cplfields.F90 +++ b/cpl/module_cplfields.F90 @@ -6,6 +6,7 @@ module module_cplfields !----------------------------------------------------------------------------- use ESMF + use NUOPC implicit none @@ -224,6 +225,7 @@ module module_cplfields ! Methods public queryImportFields, queryExportFields public cplFieldGet + public realizeConnectedCplFields !----------------------------------------------------------------------------- contains @@ -237,6 +239,8 @@ integer function queryExportFields(fieldname, abortflag) end function queryExportFields +!----------------------------------------------------------------------------- + integer function queryImportFields(fieldname, abortflag) character(len=*),intent(in) :: fieldname @@ -246,6 +250,7 @@ integer function queryImportFields(fieldname, abortflag) end function queryImportFields +!----------------------------------------------------------------------------- integer function queryFieldList(fieldsInfo, fieldname, abortflag) ! returns integer index of first found fieldname in fieldlist @@ -282,9 +287,9 @@ integer function queryFieldList(fieldsInfo, fieldname, abortflag) CALL ESMF_Finalize(endflag=ESMF_END_ABORT) endif end function queryFieldList -! -!------------------------------------------------------------------------------ -! + +!----------------------------------------------------------------------------- + subroutine cplStateGet(state, fieldList, fieldCount, rc) character(len=*), intent(in) :: state @@ -311,6 +316,7 @@ subroutine cplStateGet(state, fieldList, fieldCount, rc) end subroutine cplStateGet +!----------------------------------------------------------------------------- subroutine cplFieldGet(state, name, localDe, & farrayPtr2d, farrayPtr3d, farrayPtr4d, rc) @@ -379,6 +385,159 @@ subroutine cplFieldGet(state, name, localDe, & end do end subroutine cplFieldGet + + + subroutine realizeConnectedCplFields(state, grid, & + numLevels, numSoilLayers, numTracers, & + fields_info, state_tag, fieldList, fill_value, rc) + + use field_manager_mod, only: MODEL_ATMOS + use tracer_manager_mod, only: get_number_tracers, get_tracer_names + + type(ESMF_State), intent(inout) :: state + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: numLevels + integer, intent(in) :: numSoilLayers + integer, intent(in) :: numTracers + type(FieldInfo), dimension(:), intent(in) :: fields_info + character(len=*), intent(in) :: state_tag !< Import or export. + type(ESMF_Field), dimension(:), intent(out) :: fieldList + real(ESMF_KIND_R8), optional , intent(in) :: fill_value + integer, intent(out) :: rc + + ! local variables + + integer :: item, pos, tracerCount + logical :: isConnected + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: l_fill_value + real(ESMF_KIND_R8), parameter :: d_fill_value = 0._ESMF_KIND_R8 + type(ESMF_StateIntent_Flag) :: stateintent + character(len=32), allocatable, dimension(:) :: tracerNames, tracerUnits + + ! begin + rc = ESMF_SUCCESS + + if (present(fill_value)) then + l_fill_value = fill_value + else + l_fill_value = d_fill_value + end if + + ! attach list of tracer names to exported tracer field as metadata + call ESMF_StateGet(state, stateintent=stateintent, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (stateintent == ESMF_STATEINTENT_EXPORT) then + call get_number_tracers(MODEL_ATMOS, num_tracers=tracerCount) + allocate(tracerNames(tracerCount), tracerUnits(tracerCount)) + do item = 1, tracerCount + call get_tracer_names(MODEL_ATMOS, item, tracerNames(item), units=tracerUnits(item)) + end do + end if + + do item = 1, size(fields_info) + isConnected = NUOPC_IsConnected(state, fieldName=trim(fields_info(item)%name), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (isConnected) then + call ESMF_StateGet(state, field=field, itemName=trim(fields_info(item)%name), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_FieldEmptySet(field, grid=grid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + select case (fields_info(item)%type) + case ('l','layer') + call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/numLevels/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + case ('i','interface') + call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/numLevels+1/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + case ('t','tracer') + call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1, 1/), ungriddedUBound=(/numLevels, numTracers/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (allocated(tracerNames)) then + call addFieldMetadata(field, 'tracerNames', tracerNames, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + end if + if (allocated(tracerUnits)) then + call addFieldMetadata(field, 'tracerUnits', tracerUnits, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + end if + case ('s','surface') + call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + case ('g','soil') + call ESMF_FieldEmptyComplete(field, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/numSoilLayers/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + case default + call ESMF_LogSetError(ESMF_RC_NOT_VALID, & + msg="exportFieldType = '"//trim(fields_info(item)%type)//"' not recognized", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + end select + call NUOPC_Realize(state, field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! -- initialize field value + call ESMF_FieldFill(field, dataFillScheme="const", const1=l_fill_value, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! -- save field + fieldList(item) = field + call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fields_info(item)%name) & + // ' is connected ', ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) + else + ! remove a not connected Field from State + call ESMF_StateRemove(state, (/trim(fields_info(item)%name)/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fields_info(item)%name) & + // ' is not connected ', ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) + end if + end do + + if (allocated(tracerNames)) deallocate(tracerNames) + if (allocated(tracerUnits)) deallocate(tracerUnits) + + end subroutine realizeConnectedCplFields + +!----------------------------------------------------------------------------- + + subroutine addFieldMetadata(field, key, values, rc) + + ! This subroutine implements a preliminary method to provide metadata to + ! a coupled model that is accessing the field via reference sharing + ! (NUOPC SharedStatusField=.true.). The method sets a (key, values) pair + ! in the field's array ESMF_Info object to retrieve an array of strings + ! encoding metadata. + ! + ! Such a capability should be implemented in the standard NUOPC connector + ! for more general applications, possibly providing access to the field's + ! ESMF_Info object. + + type(ESMF_Field) :: field + character(len=*), intent(in) :: key + character(len=*), intent(in) :: values(:) + integer, optional, intent(out) :: rc + + ! local variable + integer :: localrc + type(ESMF_Array) :: array + type(ESMF_Info) :: info + + ! begin + if (present(rc)) rc = ESMF_SUCCESS + + call ESMF_FieldGet(field, array=array, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + call ESMF_InfoGetFromHost(array, info, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + call ESMF_InfoSet(info, key, values, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + + end subroutine addFieldMetadata ! !------------------------------------------------------------------------------ ! diff --git a/fv3_cap.F90 b/fv3_cap.F90 index a256fbdf6..87dbe0e69 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -16,21 +16,20 @@ module fv3gfs_cap_mod use ESMF use NUOPC use NUOPC_Model, only: model_routine_SS => SetServices, & + SetVM, & routine_Run, & label_Advertise, & label_RealizeProvided, & label_Advance, & label_CheckImport, & + label_SetRunClock, & label_TimestampExport, & label_Finalize, & NUOPC_ModelGet ! use module_fv3_config, only: quilting, output_fh, & nfhout, nfhout_hf, nsout, dt_atmos, & - nfhmax, nfhmax_hf,output_hfmax, & - output_interval,output_interval_hf, & - calendar, calendar_type, & - force_date_from_configure, & + calendar, & cplprint_flag,output_1st_tstep_rst, & first_kdt @@ -38,12 +37,11 @@ module fv3gfs_cap_mod num_files, filename_base, & wrttasks_per_group, n_group, & lead_wrttask, last_wrttask, & - output_grid, output_file, & nsout_io, iau_offset, lflname_fulltime ! use module_fcst_grid_comp, only: fcstSS => SetServices, & fcstGrid, numLevels, numSoilLayers, & - numTracers + numTracers, mygrid, grid_number_on_all_pets use module_wrt_grid_comp, only: wrtSS => SetServices ! @@ -51,8 +49,8 @@ module fv3gfs_cap_mod nImportFields, importFields, importFieldsInfo, & importFieldsValid, queryImportFields - use module_cap_cpl, only: realizeConnectedCplFields, & - clock_cplIntval, diagnose_cplFields + use module_cplfields, only: realizeConnectedCplFields + use module_cap_cpl, only: diagnose_cplFields use atmos_model_mod, only: setup_exportdata @@ -62,7 +60,6 @@ module fv3gfs_cap_mod ! !----------------------------------------------------------------------- ! - type(ESMF_Clock),save :: clock_fv3 type(ESMF_GridComp) :: fcstComp type(ESMF_State) :: fcstState @@ -138,6 +135,14 @@ subroutine SetServices(gcomp, rc) specPhaseLabel="phase2", specRoutine=ModelAdvance_phase2, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! specializations to set fv3 cap run clock (model clock) + call ESMF_MethodRemove(gcomp, label=label_SetRunClock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! specializations required to support 'inline' run sequences call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & specPhaseLabel="phase1", specRoutine=fv3_checkimport, rc=rc) @@ -173,40 +178,45 @@ subroutine InitializeAdvertise(gcomp, rc) character(240) :: msgString logical :: isPresent, isSet type(ESMF_VM) :: vm, fcstVM - type(ESMF_Time) :: currTime, startTime, stopTime - type(ESMF_TimeInterval) :: RunDuration, timeStep, rsthour, IAU_offsetTI + type(ESMF_Time) :: currTime, startTime + type(ESMF_TimeInterval) :: timeStep, rsthour type(ESMF_Config) :: cf type(ESMF_RegridMethod_Flag) :: regridmethod - type(ESMF_TimeInterval) :: earthStep - integer(ESMF_KIND_I4) :: nhf, nrg - integer,dimension(6) :: date, date_init - integer :: i, j, k, io_unit, urc, ierr, ist + integer :: i, j, k, urc, ist integer :: noutput_fh, nfh, nfh2 integer :: petcount - integer :: num_output_file + integer :: nfhmax_hf + real :: nfhmax real :: output_startfh, outputfh, outputfh2(2) - logical :: opened, loutput_fh, lfreq + logical :: loutput_fh, lfreq character(ESMF_MAXSTR) :: name integer,dimension(:), allocatable :: petList, fcstPetList, originPetList, targetPetList character(len=esmf_maxstr),allocatable :: fcstItemNameList(:) type(ESMF_StateItem_Flag), allocatable :: fcstItemTypeList(:) character(20) :: cwrtcomp integer :: isrcTermProcessing + type(ESMF_Info) :: parentInfo, childInfo character(len=*),parameter :: subname='(fv3_cap:InitializeAdvertise)' - real(kind=8) :: MPI_Wtime, timewri, timeis, timerhs + real(kind=8) :: MPI_Wtime, timeis, timerhs ! !------------------------------------------------------------------------ ! rc = ESMF_SUCCESS timeis = MPI_Wtime() + call ESMF_GridCompGet(gcomp,name=name,vm=vm,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, petCount=petcount, localpet=mype, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! query for importState and exportState call NUOPC_ModelGet(gcomp, driverClock=clock, importState=importState, exportState=exportState, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeGet(gcomp, name="ProfileMemory", value=value, defaultValue="true", & + call ESMF_AttributeGet(gcomp, name="ProfileMemory", value=value, defaultValue="false", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return profile_memory = (trim(value)/="false") @@ -228,18 +238,6 @@ subroutine InitializeAdvertise(gcomp, rc) write(msgString,'(A,i6)') trim(subname)//' dbug = ',dbug call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - call ESMF_GridCompGet(gcomp,name=name,vm=vm,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_VMGet(vm, petCount=petcount, localpet=mype, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - -! print *,'in fv3_cap,initAdvertize,name=',trim(name),'petcount=',petcount,'mype=',mype -! -! create an instance clock for fv3 - clock_fv3 = ESMF_ClockCreate(clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! !------------------------------------------------------------------------ ! get config variables ! @@ -265,8 +263,8 @@ subroutine InitializeAdvertise(gcomp, rc) noutput_fh = ESMF_ConfigGetLen(config=CF, label ='output_fh:',rc=rc) - if(mype == 0) print *,'af nems config,quilting=',quilting,'calendar=', trim(calendar),' iau_offset=',iau_offset, & - 'noutput_fh=',noutput_fh + if(mype == 0) print *,'af nems config,quilting=',quilting,' calendar=', trim(calendar),' iau_offset=',iau_offset, & + ' noutput_fh=',noutput_fh ! nfhout = 0 ; nfhmax_hf = 0 ; nfhout_hf = 0 ; nsout = 0 if ( quilting ) then @@ -282,9 +280,8 @@ subroutine InitializeAdvertise(gcomp, rc) label ='isrcTermProcessing:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(mype == 0) print *,'af nems config,quilting=',quilting,'write_groups=', & - write_groups,wrttasks_per_group,'calendar=',trim(calendar),'calendar_type=',calendar_type, & - 'isrcTermProcessing=', isrcTermProcessing + if(mype == 0) print *,'af nems config,quilting=',quilting,' write_groups=', & + write_groups,wrttasks_per_group,' isrcTermProcessing=', isrcTermProcessing ! call ESMF_ConfigGetAttribute(config=CF,value=num_files, & label ='num_files:',rc=rc) @@ -297,33 +294,6 @@ subroutine InitializeAdvertise(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return enddo - allocate(output_file(num_files)) - num_output_file = ESMF_ConfigGetLen(config=CF, label ='output_file:',rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (num_files == num_output_file) then - call ESMF_ConfigGetAttribute(CF,valueList=output_file,label='output_file:', & - count=num_files, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - do i = 1, num_files - if(output_file(i) /= "netcdf" .and. output_file(i) /= "netcdf_parallel") then - write(0,*)"fv3_cap.F90: only netcdf and netcdf_parallel are allowed for multiple values of output_file" - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif - enddo - else if ( num_output_file == 1) then - call ESMF_ConfigGetAttribute(CF,valuelist=output_file,label='output_file:', count=1, rc=rc) - output_file(1:num_files) = output_file(1) - else - output_file(1:num_files) = 'netcdf' - endif - if(mype == 0) then - print *,'af nems config,num_files=',num_files - do i=1,num_files - print *,'num_file=',i,'filename_base= ',trim(filename_base(i)),& - ' output_file= ',trim(output_file(i)) - enddo - endif -! ! variables for output call ESMF_ConfigGetAttribute(config=CF, value=nfhout, label ='nfhout:', default=-1,rc=rc) call ESMF_ConfigGetAttribute(config=CF, value=nfhmax_hf,label ='nfhmax_hf:',default=-1,rc=rc) @@ -338,75 +308,9 @@ subroutine InitializeAdvertise(gcomp, rc) call ESMF_ConfigGetAttribute(config=CF, value=dt_atmos, label ='dt_atmos:', rc=rc) call ESMF_ConfigGetAttribute(config=CF, value=nfhmax, label ='nhours_fcst:',rc=rc) if(mype == 0) print *,'af nems config,dt_atmos=',dt_atmos,'nfhmax=',nfhmax - call ESMF_TimeIntervalSet(timeStep,s=dt_atmos,rc=rc) - call ESMF_ClockSet(clock_fv3,timeStep=timeStep, rc=rc) -! -!------------------------------------------------------------------------ -! may need to set currTime for restart -! - call ESMF_ClockGet(clock_fv3, currTime=currTime, StartTime=startTime, & - RunDuration=RunDuration, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - stopTime = startTime + RunDuration -! *** read restart time from restart file - do i=751,899 - inquire(i, opened=opened) - if(.not. opened)then - io_unit = i - exit - endif - enddo -! - date = 0 ; date_init = 0 - force_date_from_configure = .true. -! - open(unit=io_unit, file=trim('INPUT/coupler.res'),status="old",err=998 ) - read (io_unit,*,err=999) calendar_type - read (io_unit,*) date_init - read (io_unit,*) date - close(io_unit) - force_date_from_configure = .false. -! - if(date(1) == 0 .and. date_init(1) /= 0) date = date_init - if(mype == 0) print *,'bf clock_fv3,date=',date,'date_init=',date_init - - call ESMF_VMbroadcast(vm, date, 6, 0) - call ESMF_TimeSet(time=currTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) + call ESMF_TimeIntervalSet(timeStep, s=dt_atmos, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -999 continue -998 continue -! if(mype==0) print *,'final date =',date,'date_init=',date_init - -!reset currTime in clock - call ESMF_ClockSet(clock_fv3, currTime=currTime, startTime=startTime, & - stopTime=stopTime, timeStep=timeStep, rc=rc) - - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! - !Under NUOPC, the EARTH driver clock is a separate instance from the - ! - fv3 clock. However, the fv3 clock may have been reset from restart - ! - therefore the EARTH driver clock must also be adjusted. - ! - Affected: currTime, timeStep - call ESMF_ClockGet(clock, timeStep=earthStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - if (earthStep > (stopTime-currTime)) earthStep = stopTime - currTime - call ESMF_ClockSet(clock, currTime=currTime, timeStep=earthStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - ! Set fv3 component clock as copy of EARTH clock. - call NUOPC_CompSetClock(gcomp, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - ! Read in the FV3 coupling interval - call clock_cplIntval(gcomp, CF) first_kdt = 1 if( output_1st_tstep_rst) then @@ -436,6 +340,18 @@ subroutine InitializeAdvertise(gcomp, rc) fcstComp = ESMF_GridCompCreate(petList=fcstPetList, name='fv3_fcst', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! + ! copy attributes from fv3cap component to fcstComp + call ESMF_InfoGetFromHost(gcomp, info=parentInfo, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_InfoGetFromHost(fcstComp, info=childInfo, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_InfoUpdate(lhs=childInfo, rhs=parentInfo, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! use the generic SetVM method to do resource and threading control + call ESMF_GridCompSetVM(fcstComp, SetVM, userRc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return call ESMF_GridCompSetServices(fcstComp, fcstSS, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return @@ -449,12 +365,12 @@ subroutine InitializeAdvertise(gcomp, rc) ! call fcst Initialize (including creating fcstgrid and fcst fieldbundle) call ESMF_GridCompInitialize(fcstComp, exportState=fcstState, & - clock=clock_fv3, userRc=urc, rc=rc) + clock=clock, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! -! reconcile the fcstComp's import state +! reconcile the fcstComp's export state call ESMF_StateReconcile(fcstState, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! @@ -483,7 +399,9 @@ subroutine InitializeAdvertise(gcomp, rc) ! pull out the item names and item types from fcstState call ESMF_StateGet(fcstState, itemNameList=fcstItemNameList, & - itemTypeList=fcstItemTypeList, rc=rc) + itemTypeList=fcstItemTypeList, & + !itemorderflag=ESMF_ITEMORDER_ADDORDER, & + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! loop over all items in the fcstState and collect all FieldBundles @@ -502,9 +420,6 @@ subroutine InitializeAdvertise(gcomp, rc) return endif enddo -! -! set up ESMF time interval at center of iau window - call ESMF_TimeIntervalSet(IAU_offsetTI, h=iau_offset, rc=rc) ! k = num_pes_fcst timerhs = MPI_Wtime() @@ -526,6 +441,17 @@ subroutine InitializeAdvertise(gcomp, rc) ! print *,'af wrtComp(i)=',i,'name=',trim(cwrtcomp),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return +! copy attributes from fv3cap component to wrtComp + call ESMF_InfoGetFromHost(wrtComp(i), info=childInfo, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_InfoUpdate(lhs=childInfo, rhs=parentInfo, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + +! use the generic SetVM method to do resource and threading control + call ESMF_GridCompSetVM(wrtComp(i), SetVM, userRc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + ! call into wrtComp(i) SetServices call ESMF_GridCompSetServices(wrtComp(i), wrtSS, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -550,7 +476,7 @@ subroutine InitializeAdvertise(gcomp, rc) ! call into wrtComp(i) Initialize call ESMF_GridCompInitialize(wrtComp(i), importState=wrtstate(i), & - clock=clock_fv3, phase=1, userRc=urc, rc=rc) + clock=clock, phase=1, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return @@ -603,10 +529,8 @@ subroutine InitializeAdvertise(gcomp, rc) if (i==1) then ! this is a Store() for the first wrtComp -> must do the Store() - timewri = MPI_Wtime() - - call ESMF_FieldBundleRegridStore(fcstFB(j), wrtFB(j,i), & - regridMethod=regridmethod, routehandle=routehandle(j,i), & + call ESMF_FieldBundleRegridStore(fcstFB(j), wrtFB(j,1), & + regridMethod=regridmethod, routehandle=routehandle(j,1), & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & srcTermProcessing=isrcTermProcessing, rc=rc) @@ -633,10 +557,10 @@ subroutine InitializeAdvertise(gcomp, rc) endif write(msgString,"(A,I2.2,',',I2.2,A)") "... returned from wrtFB(",j,i, ") FieldBundleRegridStore()." call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) - enddo + enddo ! j=1, FBcount ! end write_groups - enddo + enddo ! i=1, write_groups if(mype==0) print *,'in fv3cap init, time wrtcrt/regrdst',MPI_Wtime()-timerhs deallocate(petList) deallocate(originPetList) @@ -660,7 +584,7 @@ subroutine InitializeAdvertise(gcomp, rc) !--- use nsout for output frequency nsout*dt_atmos nfh = 0 if( nfhmax > output_startfh ) nfh = nint((nfhmax-output_startfh)/(nsout*dt_atmos/3600.))+1 - if(nfh >0) then + if(nfh >0) then allocate(output_fh(nfh)) if( output_startfh == 0) then output_fh(1) = dt_atmos/3600. @@ -746,7 +670,7 @@ subroutine InitializeAdvertise(gcomp, rc) endif do i=2,nfh output_fh(i) = (i-1)*outputfh2(1) + output_startfh - ! Except fh000, which is the first time output, if any other of the + ! Except fh000, which is the first time output, if any other of the ! output time is not integer hour, set lflname_fulltime to be true, so the ! history file names will contain the full time stamp (HHH-MM-SS). if(.not.lflname_fulltime) then @@ -764,7 +688,7 @@ subroutine InitializeAdvertise(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if( output_startfh == 0) then ! If the output time in output_fh array contains first time stamp output, - ! check the rest of output time, otherwise, check all the output time. + ! check the rest of output time, otherwise, check all the output time. ! If any of them is not integer hour, the history file names will ! contain the full time stamp (HHH-MM-SS) ist = 1 @@ -790,7 +714,7 @@ subroutine InitializeAdvertise(gcomp, rc) endif endif endif ! end loutput_fh - endif + endif if(mype==0) print *,'output_fh=',output_fh(1:size(output_fh)),'lflname_fulltime=',lflname_fulltime ! ! --- advertise Fields in importState and exportState ------------------- @@ -824,10 +748,9 @@ subroutine InitializeRealize(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname='(fv3gfs_cap:InitializeRealize)' - type(ESMF_State) :: importState, exportState - logical :: isPetLocal - integer :: n + character(len=*),parameter :: subname='(fv3gfs_cap:InitializeRealize)' + type(ESMF_State) :: importState, exportState + logical :: isPetLocal rc = ESMF_SUCCESS @@ -843,7 +766,7 @@ subroutine InitializeRealize(gcomp, rc) if (isPetLocal) then ! -- realize connected fields in exportState - call realizeConnectedCplFields(exportState, fcstGrid, & + call realizeConnectedCplFields(exportState, fcstGrid(mygrid), & numLevels, numSoilLayers, numTracers, & exportFieldsInfo, 'FV3 Export', exportFields, 0.0_ESMF_KIND_R8, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -853,7 +776,7 @@ subroutine InitializeRealize(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! -- realize connected fields in importState - call realizeConnectedCplFields(importState, fcstGrid, & + call realizeConnectedCplFields(importState, fcstGrid(mygrid), & numLevels, numSoilLayers, numTracers, & importFieldsInfo, 'FV3 Import', importFields, 9.99e20_ESMF_KIND_R8, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -869,88 +792,18 @@ subroutine ModelAdvance(gcomp, rc) type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc - ! local variables - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime, startTime, stopTime - type(ESMF_TimeInterval) :: timeStep - - integer :: i, urc - character(len=*),parameter :: subname='(fv3_cap:ModelAdvance)' - character(240) :: msgString - character(240) :: startTime_str, currTime_str, stopTime_str, timeStep_str - !----------------------------------------------------------------------------- rc = ESMF_SUCCESS if (profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance: ") - ! Because of the way that the internal Clock was set in SetClock(), - ! its timeStep is likely smaller than the parent timeStep. As a consequence - ! the time interval covered by a single parent timeStep will result in - ! multiple calls to the ModelAdvance() routine. Every time the currTime - ! will come in by one internal timeStep advanced. This goes until the - ! stopTime of the internal Clock has been reached. - - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="------>Advancing FV3 from: ", unit=msgString, rc=rc) + call ModelAdvance_phase1(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) + call ModelAdvance_phase2(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -!----------------------------------------------------------------------- -!*** Use the internal Clock set by NUOPC layer for FV3 but update stopTime -!----------------------------------------------------------------------- - - ! Component internal Clock gets updated per NUOPC rules - call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! The stopTime will be updated to be the next coupling time - call ESMF_ClockGet(clock, currTime=currTime, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! Set the coupling time to be stopTime in Clock that FV3 core uses - call ESMF_ClockSet(clock_fv3, currTime=currTime, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="entering FV3_ADVANCE with clock_fv3 current: ", & - unit=msgString) - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="startTime", & - preString="entering FV3_ADVANCE with clock_fv3 start: ", & - unit=msgString) - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="stopTime", & - preString="entering FV3_ADVANCE with clock_fv3 stop: ", & - unit=msgString) - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - - ! call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & - ! timeStep=timeStep, stopTime=stopTime, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! call ESMF_TimeGet(startTime, timestring=startTime_str, rc=rc) - ! call ESMF_TimeGet(currTime, timestring=currTime_str, rc=rc) - ! call ESMF_TimeGet(stopTime, timestring=stopTime_str, rc=rc) - ! call ESMF_TimeIntervalGet(timeStep, timestring=timeStep_str, rc=rc) - -! -!----------------------------------------------------------------------------- -!*** integration loop - - integrate: do while(.NOT.ESMF_ClockIsStopTime(clock_fv3, rc=rc)) - - call ModelAdvance_phase1(gcomp, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ModelAdvance_phase2(gcomp, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - enddo integrate -! if (profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance: ") end subroutine ModelAdvance @@ -962,105 +815,42 @@ subroutine ModelAdvance_phase1(gcomp, rc) integer, intent(out) :: rc ! local variables - type(ESMF_State) :: importState, exportState type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Time) :: startTime, stopTime - integer :: urc logical :: fcstpe character(len=*),parameter :: subname='(fv3_cap:ModelAdvance_phase1)' character(240) :: msgString - integer :: date(6) - !----------------------------------------------------------------------------- rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance_phase1: ") - fcstpe = .false. - if( mype < num_pes_fcst ) fcstpe = .true. - - ! Expecting to be called by NUOPC run method exactly once for every coupling - ! step. - ! Also expecting the coupling step to be identical to the timeStep for - ! clock_fv3. - - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="------>Advancing FV3 phase1 from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - -!----------------------------------------------------------------------- -!*** Use the internal Clock set by NUOPC layer for FV3 but update stopTime -!----------------------------------------------------------------------- - - ! Component internal Clock gets updated per NUOPC rules call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! The stopTime will be updated to be the next external coupling time - call ESMF_ClockGet(clock, currTime=currTime, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! Set the FV3-OCN coupling time to be stopTime in Clock that FV3 core uses - !call ESMF_ClockSet(clock_fv3, currTime=currTime, stopTime=stopTime, rc=rc) - call ESMF_ClockSet(clock_fv3, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="entering FV3_ADVANCE phase1 with clock_fv3 current: ", & + call ESMF_ClockPrint(clock, options="currTime", & + preString="entering FV3_ADVANCE phase1 with clock current: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="startTime", & - preString="entering FV3_ADVANCE phase1 with clock_fv3 start: ", & + call ESMF_ClockPrint(clock, options="startTime", & + preString="entering FV3_ADVANCE phase1 with clock start: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="stopTime", & - preString="entering FV3_ADVANCE phase1 with clock_fv3 stop: ", & + call ESMF_ClockPrint(clock, options="stopTime", & + preString="entering FV3_ADVANCE phase1 with clock stop: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & - timeStep=timeStep, stopTime=stopTime, rc=rc) + call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock, phase=1, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - -! if(mype==0) print *,'total steps=', nint((stopTime-startTime)/timeStep) -! if(mype==lead_wrttask(1)) print *,'on wrt lead,total steps=', nint((stopTime-startTime)/timeStep) - call ESMF_TimeGet(time=stopTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! if(mype==0) print *,'af clock,stop date=',date -! if(mype==lead_wrttask(1)) print *,'on wrt lead,af clock,stop date=',date - call ESMF_TimeIntervalGet(timeStep,yy=date(1),mm=date(2),d=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! if(mype==0) print *,'af clock,timestep date=',date -! if(mype==lead_wrttask(1)) print *,'on wrt lead,af clock,timestep date=',date - - call ESMF_LogWrite('Model Advance phase1: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & - phase=1, userRc=urc, rc=rc) - if (rc /= ESMF_SUCCESS) then - if(mype==0) print *,'after fcstComp phase1 rc=',rc - endif - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - call ESMF_LogWrite('Model Advance phase1: after fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - ! assign import_data called during phase=1 if( dbug > 0 .or. cplprint_flag ) then - call diagnose_cplFields(gcomp, clock_fv3, fcstpe, cplprint_flag, dbug, 'import') + fcstpe = .false. + if( mype < num_pes_fcst ) fcstpe = .true. + call diagnose_cplFields(gcomp, clock, fcstpe, cplprint_flag, dbug, 'import') endif if (profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance_phase1: ") @@ -1074,73 +864,63 @@ subroutine ModelAdvance_phase2(gcomp, rc) integer, intent(out) :: rc ! local variables - type(ESMF_State) :: importState, exportState - type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep - type(ESMF_Time) :: startTime, stopTime + type(ESMF_Time) :: startTime type(ESMF_TimeInterval) :: time_elapsed - integer :: na, i, urc + integer :: na, j, urc integer :: nfseconds logical :: fcstpe character(len=*),parameter :: subname='(fv3_cap:ModelAdvance_phase2)' character(240) :: msgString - real(kind=8) :: MPI_Wtime - real(kind=8) :: timewri, timerhi, timerh + + type(ESMF_Clock) :: clock, clock_out !----------------------------------------------------------------------------- rc = ESMF_SUCCESS + if(profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance_phase2: ") - fcstpe = .false. - if( mype < num_pes_fcst ) fcstpe = .true. -! - timewri = MPI_Wtime() - call ESMF_LogWrite('Model Advance phase2: before fcstComp run phase2', ESMF_LOGMSG_INFO, rc=rc) + call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & - phase=2, userRc=urc, rc=rc) - + call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock, phase=2, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - call ESMF_LogWrite('Model Advance phase2: after fcstComp run phase2', ESMF_LOGMSG_INFO, rc=rc) + clock_out = ESMF_ClockCreate(clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ClockAdvance(clock = clock_fv3, rc = RC) + call ESMF_ClockAdvance(clock_out, rc = RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & - timeStep=timeStep, stopTime=stopTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - time_elapsed = currtime - starttime - na = nint(time_elapsed/timeStep) - call ESMF_TimeIntervalGet(time_elapsed, s=nfseconds, rc=rc) -! - if(mype==0) print *,'n fv3_cap,in model run, advance,na=',na - !------------------------------------------------------------------------------- !*** if it is output time, call data transfer and write grid comp run if( quilting ) then + call ESMF_ClockGet(clock_out, startTime=startTime, currTime=currTime, & + timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + time_elapsed = currTime - startTime + na = nint(time_elapsed/timeStep) + call ESMF_TimeIntervalGet(time_elapsed, s=nfseconds, rc=rc) + output: if (ANY(nint(output_fh(:)*3600.0) == nfseconds)) then ! if (mype == 0 .or. mype == lead_wrttask(1)) print *,' aft fcst run output time=',nfseconds, & 'FBcount=',FBcount,'na=',na - timerhi = MPI_Wtime() call ESMF_VMEpochEnter(epoch=ESMF_VMEpoch_Buffer, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - do i=1, FBCount + do j=1, FBCount - call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), & - routehandle=routehandle(i, n_group), & + call ESMF_FieldBundleRegrid(fcstFB(j), wrtFB(j,n_group), & + routehandle=routehandle(j, n_group), & termorderflag=(/ESMF_TERMORDER_SRCSEQ/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! @@ -1149,15 +929,10 @@ subroutine ModelAdvance_phase2(gcomp, rc) call ESMF_VMEpochExit(rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - timerhi = MPI_Wtime() - call ESMF_GridCompRun(wrtComp(n_group), importState=wrtState(n_group), clock=clock_fv3,userRc=urc,rc=rc) - - timerh = MPI_Wtime() - + call ESMF_GridCompRun(wrtComp(n_group), importState=wrtState(n_group), clock=clock_out, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return @@ -1174,28 +949,63 @@ subroutine ModelAdvance_phase2(gcomp, rc) endif ! quilting -!jw check clock - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 current: ", & + call ESMF_ClockPrint(clock, options="currTime", & + preString="leaving FV3_ADVANCE phase2 with clock current: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="startTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 start: ", & + call ESMF_ClockPrint(clock, options="startTime", & + preString="leaving FV3_ADVANCE phase2 with clock start: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="stopTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 stop: ", & + call ESMF_ClockPrint(clock, options="stopTime", & + preString="leaving FV3_ADVANCE phase2 with clock stop: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) if( dbug > 0 .or. cplprint_flag ) then - call diagnose_cplFields(gcomp, clock_fv3, fcstpe, cplprint_flag, dbug, 'export') + fcstpe = .false. + if( mype < num_pes_fcst ) fcstpe = .true. + call diagnose_cplFields(gcomp, clock_out, fcstpe, cplprint_flag, dbug, 'export') end if if(profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance_phase2: ") end subroutine ModelAdvance_phase2 +!----------------------------------------------------------------------------- + + subroutine ModelSetRunClock(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: dclock, mclock + type(ESMF_TimeInterval) :: dtimestep, mtimestep + type(ESMF_Time) :: mcurrtime, mstoptime + +!----------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_ClockGet(dclock, timeStep=dtimestep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_ClockGet(mclock, currTime=mcurrtime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_TimeIntervalSet(mtimestep,s=dt_atmos,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + mstoptime = mcurrtime + dtimestep + + call ESMF_ClockSet(mclock, timeStep=mtimestep, stopTime=mstoptime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + end subroutine ModelSetRunClock + !----------------------------------------------------------------------------- subroutine fv3_checkimport(gcomp, rc) @@ -1218,6 +1028,8 @@ subroutine fv3_checkimport(gcomp, rc) character(esmf_maxstr) :: msgString integer :: date(6) + rc = ESMF_SUCCESS + ! query the Component for its clock call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1323,7 +1135,7 @@ subroutine ModelFinalize(gcomp, rc) ! local variables character(len=*),parameter :: subname='(fv3gfs_cap:ModelFinalize)' - integer :: i, unit, urc + integer :: i, urc type(ESMF_VM) :: vm real(kind=8) :: MPI_Wtime, timeffs ! @@ -1334,6 +1146,7 @@ subroutine ModelFinalize(gcomp, rc) rc = ESMF_SUCCESS ! call ESMF_GridCompGet(gcomp,vm=vm,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! !*** finalize grid comps if( quilting ) then diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 3827ccb68..041a2d46b 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -196,7 +196,7 @@ subroutine FV3GFS_GFS_checksum (Model, GFS_Data, Atm_block) nsfcprop2d = nsfcprop2d + 16 endif - allocate (temp2d(isc:iec,jsc:jec,nsfcprop2d+Model%ntot3d+Model%nctp)) + allocate (temp2d(isc:iec,jsc:jec,nsfcprop2d+Model%ntot2d+Model%nctp)) allocate (temp3d(isc:iec,jsc:jec,1:lev,14+Model%ntot3d+2*ntr)) allocate (temp3dlevsp1(isc:iec,jsc:jec,1:lev+1,3)) @@ -1462,7 +1462,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) if (Sfcprop(nb)%landfrac(ix) > zero) then - tem = one / Sfcprop(nb)%landfrac(ix) + tem = one / (Sfcprop(nb)%fice(ix)*(one-Sfcprop(nb)%landfrac(ix))+Sfcprop(nb)%landfrac(ix)) Sfcprop(nb)%snodl(ix) = Sfcprop(nb)%snowd(ix) * tem else Sfcprop(nb)%snodl(ix) = zero @@ -1477,7 +1477,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) if (Sfcprop(nb)%landfrac(ix) > zero) then - tem = one / Sfcprop(nb)%landfrac(ix) + tem = one / (Sfcprop(nb)%fice(ix)*(one-Sfcprop(nb)%landfrac(ix))+Sfcprop(nb)%landfrac(ix)) Sfcprop(nb)%weasdl(ix) = Sfcprop(nb)%weasd(ix) * tem else Sfcprop(nb)%weasdl(ix) = zero @@ -1501,7 +1501,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta !$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%zorlw(ix) = Sfcprop(nb)%zorl(ix) !--- compute zorlw from existing variables + if (Sfcprop(nb)%landfrac(ix) < one .and. Sfcprop(nb)%fice(ix) < one) then + Sfcprop(nb)%zorlw(ix) = min(Sfcprop(nb)%zorl(ix), 0.317) + endif enddo enddo endif @@ -1521,7 +1523,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta !$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorl(ix) !--- compute zorli from existing variables + if (Sfcprop(nb)%fice(ix)*(one-Sfcprop(nb)%landfrac(ix)) > zero) then + Sfcprop(nb)%zorli(ix) = one + endif enddo enddo endif @@ -1547,6 +1551,36 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta enddo endif + if (sfc_var2(i,j,47) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing snodi') +!$omp parallel do default(shared) private(nb, ix, tem) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + if (Sfcprop(nb)%fice(ix) > zero) then + tem = one / (Sfcprop(nb)%fice(ix)*(one-Sfcprop(nb)%landfrac(ix))+Sfcprop(nb)%landfrac(ix)) + Sfcprop(nb)%snodi(ix) = min(Sfcprop(nb)%snowd(ix) * tem, 3.0) + else + Sfcprop(nb)%snodi(ix) = zero + endif + enddo + enddo + endif + + if (sfc_var2(i,j,48) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing weasdi') +!$omp parallel do default(shared) private(nb, ix, tem) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + if (Sfcprop(nb)%fice(ix) > zero) then + tem = one / (Sfcprop(nb)%fice(ix)*(one-Sfcprop(nb)%landfrac(ix))+Sfcprop(nb)%landfrac(ix)) + Sfcprop(nb)%weasdi(ix) = Sfcprop(nb)%weasd(ix)*tem + else + Sfcprop(nb)%weasdi(ix) = zero + endif + enddo + enddo + endif + if (Model%use_cice_alb) then if (sfc_var2(i,j,49) < -9990.0_r8) then !$omp parallel do default(shared) private(nb, ix) @@ -3047,7 +3081,7 @@ end subroutine store_data3D ! #ifdef use_WRTCOMP - subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nbdlphys) + subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nbdlphys, rc) ! !------------------------------------------------------------- !*** set esmf bundle for phys output fields @@ -3058,15 +3092,17 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb ! implicit none ! - type(GFS_externaldiag_type),intent(in) :: Diag(:) + type(GFS_externaldiag_type),intent(in) :: Diag(:) integer, intent(in) :: axes(:) type(ESMF_FieldBundle),intent(inout) :: phys_bundle(:) type(ESMF_Grid),intent(inout) :: fcst_grid logical,intent(in) :: quilting integer, intent(in) :: nbdlphys + integer,intent(out) :: rc + ! !*** local variables - integer i, j, k, n, rc, idx, ibdl, nbdl + integer i, j, k, n, idx, ibdl, nbdl integer id, axis_length, direction, edges, axis_typ integer num_attributes, num_field_dyn integer currdate(6) @@ -3099,7 +3135,7 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb !------------------------------------------------------------ ! allocate(bdl_intplmethod(nbdlphys), outputfile(nbdlphys)) - if(mpp_pe()==mpp_root_pe())print *,'in fv_phys bundle,nbdl=',nbdlphys + if(mpp_pe()==mpp_root_pe()) print *,'in fv_phys bundle,nbdl=',nbdlphys do ibdl = 1, nbdlphys loutputfile = .false. call ESMF_FieldBundleGet(phys_bundle(ibdl), name=physbdl_name,rc=rc) @@ -3178,14 +3214,14 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb allocate(udimList(udimCount)) call ESMF_AttributeGet(fcst_grid, convention="NetCDF", purpose="FV3", & name="vertical_dim_labels", valueList=udimList, rc=rc) -! if(mpp_pe()==mpp_root_pe())print *,'in fv3gfsio, vertical +! if(mpp_pe()==mpp_root_pe()) print *,'in fv3gfsio, vertical ! list=',udimList(1:udimCount),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return else - if(mpp_pe()==mpp_root_pe())print *,'in fv_dyn bundle,axis_name_vert=',axis_name_vert + if(mpp_pe()==mpp_root_pe()) print *,'in fv_dyn bundle,axis_name_vert=',axis_name_vert call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3", & attrList=(/"vertical_dim_labels"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -3193,6 +3229,7 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb name="vertical_dim_labels", valueList=axis_name_vert, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif + deallocate(axis_name_vert) endif !*** add attributes @@ -3207,13 +3244,13 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb direction, edges, Domain, DomainU, axis_data, & num_attributes=num_attributes, attributes=attributes) ! - edgesS='' + edgesS = '' do i = 1,num_axes_phys if(axes(i) == edges) edgesS=axis_name(i) enddo ! Add vertical dimension Attributes to Grid if( id>2 ) then -! if(mpp_pe()==mpp_root_pe())print *,' in dyn add grid, axis_name=', & +! if(mpp_pe()==mpp_root_pe()) print *,' in dyn add grid, axis_name=', & ! trim(axis_name(id)),'axis_data=',axis_data if(trim(edgesS)/='') then call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3", & @@ -3307,6 +3344,8 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb endif enddo + deallocate(axis_name) + deallocate(all_axes) end subroutine fv_phys_bundle_setup ! @@ -3415,62 +3454,62 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph ! !*** add field attributes call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"long_name"/), rc=rc) + attrList=(/"long_name"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='long_name',value=trim(long_name),rc=rc) + name='long_name',value=trim(long_name),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"units"/), rc=rc) + attrList=(/"units"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='units',value=trim(units),rc=rc) + name='units',value=trim(units),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"missing_value"/), rc=rc) + attrList=(/"missing_value"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='missing_value',value=missing_value,rc=rc) + name='missing_value',value=missing_value,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"_FillValue"/), rc=rc) + attrList=(/"_FillValue"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='_FillValue',value=missing_value,rc=rc) + name='_FillValue',value=missing_value,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"cell_methods"/), rc=rc) + attrList=(/"cell_methods"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='cell_methods',value=trim(cell_methods),rc=rc) + name='cell_methods',value=trim(cell_methods),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) ! call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & - attrList=(/"output_file"/), rc=rc) + attrList=(/"output_file"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & - name='output_file',value=trim(output_file),rc=rc) + name='output_file',value=trim(output_file),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) diff --git a/io/inline_post.F90 b/io/inline_post.F90 index b51e2e7ac..2e123346e 100644 --- a/io/inline_post.F90 +++ b/io/inline_post.F90 @@ -16,7 +16,7 @@ module inline_post contains - subroutine inline_post_run(wrt_int_state,mypei,mpicomp,lead_write, & + subroutine inline_post_run(wrt_int_state,grid_id,mypei,mpicomp,lead_write, & mynfhr,mynfmin,mynfsec) ! ! revision history: @@ -30,6 +30,7 @@ subroutine inline_post_run(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! type(wrt_internal_state),intent(in) :: wrt_int_state + integer,intent(in) :: grid_id integer,intent(in) :: mypei integer,intent(in) :: mpicomp integer,intent(in) :: lead_write @@ -37,14 +38,14 @@ subroutine inline_post_run(wrt_int_state,mypei,mpicomp,lead_write, & integer,intent(in) :: mynfmin integer,intent(in) :: mynfsec ! - if(mypei == 0) print *,'inline_post_run, output_grid=',trim(output_grid) - if(trim(output_grid) == 'gaussian_grid' & - .or. trim(output_grid) == 'global_latlon') then + if(mypei == 0) print *,'inline_post_run, output_grid=',trim(output_grid(grid_id)) + if(trim(output_grid(grid_id)) == 'gaussian_grid' & + .or. trim(output_grid(grid_id)) == 'global_latlon') then call post_run_gfs(wrt_int_state, mypei, mpicomp, lead_write, & mynfhr, mynfmin,mynfsec) - else if( trim(output_grid) == 'regional_latlon' & - .or. trim(output_grid) == 'rotated_latlon' & - .or. trim(output_grid) == 'lambert_conformal') then + else if( trim(output_grid(grid_id)) == 'regional_latlon' & + .or. trim(output_grid(grid_id)) == 'rotated_latlon' & + .or. trim(output_grid(grid_id)) == 'lambert_conformal') then if(mypei == 0) print *,'inline_post_run, call post_run_regional' call post_run_regional(wrt_int_state, mypei, mpicomp, lead_write, & mynfhr, mynfmin,mynfsec) @@ -55,21 +56,22 @@ end subroutine inline_post_run ! !----------------------------------------------------------------------- ! - subroutine inline_post_getattr(wrt_int_state) + subroutine inline_post_getattr(wrt_int_state,grid_id) ! use esmf ! implicit none ! type(wrt_internal_state),intent(inout) :: wrt_int_state + integer, intent(in) :: grid_id ! - if(trim(output_grid) == 'gaussian_grid' & - .or. trim(output_grid) == 'global_latlon') then + if(trim(output_grid(grid_id)) == 'gaussian_grid' & + .or. trim(output_grid(grid_id)) == 'global_latlon') then call post_getattr_gfs(wrt_int_state) - else if( trim(output_grid) == 'regional_latlon' & - .or. trim(output_grid) == 'rotated_latlon' & - .or. trim(output_grid) == 'lambert_conformal') then - call post_getattr_regional(wrt_int_state) + else if( trim(output_grid(grid_id)) == 'regional_latlon' & + .or. trim(output_grid(grid_id)) == 'rotated_latlon' & + .or. trim(output_grid(grid_id)) == 'lambert_conformal') then + call post_getattr_regional(wrt_int_state,grid_id) endif ! end subroutine inline_post_getattr diff --git a/io/module_fv3_io_def.F90 b/io/module_fv3_io_def.F90 index 65d2b926b..dda5310ad 100644 --- a/io/module_fv3_io_def.F90 +++ b/io/module_fv3_io_def.F90 @@ -1,4 +1,4 @@ - module module_fv3_io_def +module module_fv3_io_def ! !*** fv3 io related configration variables ! @@ -9,24 +9,26 @@ module module_fv3_io_def ! use esmf, only : esmf_maxstr implicit none -! + integer :: num_pes_fcst integer :: wrttasks_per_group, write_groups integer :: n_group integer :: num_files - character(len=esmf_maxstr) :: app_domain - character(len=esmf_maxstr) :: output_grid - integer :: imo,jmo - integer :: ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d integer :: nbdlphys - integer :: nsout_io, iau_offset, ideflate, nbits + integer :: nsout_io, iau_offset logical :: lflname_fulltime - real :: cen_lon, cen_lat, lon1, lat1, lon2, lat2, dlon, dlat - real :: stdlat1, stdlat2, dx, dy + character(len=esmf_maxstr),dimension(:),allocatable :: filename_base character(len=esmf_maxstr),dimension(:),allocatable :: output_file -! + integer,dimension(:),allocatable :: lead_wrttask, last_wrttask -! - end module module_fv3_io_def + character(len=esmf_maxstr),dimension(:),allocatable :: output_grid + integer,dimension(:),allocatable :: imo,jmo + real,dimension(:),allocatable :: cen_lon, cen_lat + real,dimension(:),allocatable :: lon1, lat1, lon2, lat2, dlon, dlat + real,dimension(:),allocatable :: stdlat1, stdlat2, dx, dy + integer,dimension(:),allocatable :: ideflate, nbits + integer,dimension(:),allocatable :: ichunk2d, jchunk2d, ichunk3d, jchunk3d, kchunk3d + +end module module_fv3_io_def diff --git a/io/module_write_internal_state.F90 b/io/module_write_internal_state.F90 index e396063c9..9c9ebbe26 100644 --- a/io/module_write_internal_state.F90 +++ b/io/module_write_internal_state.F90 @@ -49,8 +49,8 @@ module write_internal_state integer :: lat_start, lon_start integer :: lat_end, lon_end real :: latstart, latlast, lonstart, lonlast - integer,dimension(:),allocatable :: lat_start_wrtgrp - integer,dimension(:),allocatable :: lat_end_wrtgrp + integer,dimension(:),allocatable :: lat_start_wrtgrp, lon_start_wrtgrp + integer,dimension(:),allocatable :: lat_end_wrtgrp, lon_end_wrtgrp real,dimension(:,:),allocatable :: lonPtr, latPtr ! !-------------------------- diff --git a/io/module_write_netcdf.F90 b/io/module_write_netcdf.F90 index 30959e625..1445d5e04 100644 --- a/io/module_write_netcdf.F90 +++ b/io/module_write_netcdf.F90 @@ -1,7 +1,8 @@ -#define ESMF_ERR_RETURN(rc) if (ESMF_LogFoundError(rc, msg="Breaking out of subroutine", line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) +#define ESMF_ERR_RETURN(rc) \ + if (ESMF_LogFoundError(rc, msg="Breaking out of subroutine", line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) #define NC_ERR_STOP(status) \ - if (status /= nf90_noerr) write(0,*) "line ", __LINE__, trim(nf90_strerror(status)); \ + if (status /= nf90_noerr) write(0,*) "file: ", __FILE__, " line: ", __LINE__, trim(nf90_strerror(status)); \ if (status /= nf90_noerr) call ESMF_Finalize(endflag=ESMF_END_ABORT) module module_write_netcdf @@ -9,84 +10,159 @@ module module_write_netcdf use esmf use netcdf use module_fv3_io_def,only : ideflate, nbits, & + ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d, & output_grid,dx,dy,lon1,lat1,lon2,lat2 + use mpi implicit none private public write_netcdf + logical :: par + + interface quantize_array + module procedure quantize_array_3d + module procedure quantize_array_4d + end interface + contains !---------------------------------------------------------------------------------------- - subroutine write_netcdf(fieldbundle, wrtfb, filename, mpi_comm, mype, im, jm, ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d, rc) + subroutine write_netcdf(wrtfb, filename, & + use_parallel_netcdf, mpi_comm, mype, & + grid_id, rc) ! - type(ESMF_FieldBundle), intent(in) :: fieldbundle type(ESMF_FieldBundle), intent(in) :: wrtfb character(*), intent(in) :: filename + logical, intent(in) :: use_parallel_netcdf integer, intent(in) :: mpi_comm integer, intent(in) :: mype - integer, intent(in) :: im, jm - integer, intent(in) :: ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d + integer, intent(in) :: grid_id integer, optional,intent(out) :: rc ! !** local vars - integer :: i,j,m,n,k - integer :: lm + integer :: i,j,t, istart,iend,jstart,jend + integer :: im, jm, lm + + integer, dimension(:), allocatable :: fldlev + + real(ESMF_KIND_R4), dimension(:,:), pointer :: array_r4 + real(ESMF_KIND_R4), dimension(:,:,:), pointer :: array_r4_cube + real(ESMF_KIND_R4), dimension(:,:,:), pointer :: array_r4_3d + real(ESMF_KIND_R4), dimension(:,:,:,:), pointer :: array_r4_3d_cube - integer, dimension(:), allocatable :: fldlev - real(4), dimension(:,:), allocatable :: arrayr4 - real(8), dimension(:,:), allocatable :: arrayr8 - real(4), dimension(:,:,:), allocatable :: arrayr4_3d,arrayr4_3d_save - real(8), dimension(:,:,:), allocatable :: arrayr8_3d + real(ESMF_KIND_R8), dimension(:,:), pointer :: array_r8 + real(ESMF_KIND_R8), dimension(:,:,:), pointer :: array_r8_cube + real(ESMF_KIND_R8), dimension(:,:,:), pointer :: array_r8_3d + real(ESMF_KIND_R8), dimension(:,:,:,:), pointer :: array_r8_3d_cube - real(8) x(im),y(jm) + real(8), dimension(:), allocatable :: x,y integer :: fieldCount, fieldDimCount, gridDimCount integer, dimension(:), allocatable :: ungriddedLBound, ungriddedUBound + integer, dimension(:), allocatable :: start_idx type(ESMF_Field), allocatable :: fcstField(:) type(ESMF_TypeKind_Flag) :: typekind type(ESMF_TypeKind_Flag) :: attTypeKind type(ESMF_Grid) :: wrtgrid type(ESMF_Array) :: array + type(ESMF_DistGrid) :: distgrid - integer :: attcount + integer :: attCount character(len=ESMF_MAXSTR) :: attName, fldName integer :: varival - real(4) :: varr4val, scale_fact, offset, dataMin, dataMax + real(4) :: varr4val, dataMin, dataMax real(4), allocatable, dimension(:) :: compress_err real(8) :: varr8val character(len=ESMF_MAXSTR) :: varcval - character(128) :: time_units - - integer :: ncerr + integer :: ncerr,ierr integer :: ncid integer :: oldMode - integer :: im_dimid, jm_dimid, pfull_dimid, phalf_dimid, time_dimid - integer :: im_varid, jm_varid, lm_varid, time_varid, lon_varid, lat_varid + integer :: im_dimid, jm_dimid, tile_dimid, pfull_dimid, phalf_dimid, time_dimid + integer :: im_varid, jm_varid, tile_varid, lon_varid, lat_varid + integer, dimension(:), allocatable :: dimids_2d, dimids_3d integer, dimension(:), allocatable :: varids logical shuffle - call ESMF_FieldBundleGet(fieldbundle, fieldCount=fieldCount, rc=rc); ESMF_ERR_RETURN(rc) + logical :: is_cubed_sphere + integer :: rank, deCount, localDeCount, dimCount, tileCount + integer :: my_tile, start_i, start_j + integer, dimension(:,:), allocatable :: minIndexPDe, maxIndexPDe + integer, dimension(:,:), allocatable :: minIndexPTile, maxIndexPTile + integer, dimension(:), allocatable :: deToTileMap, localDeToDeMap + logical :: do_io + integer :: par_access +! + is_cubed_sphere = .false. + tileCount = 0 + my_tile = 0 + start_i = -10000000 + start_j = -10000000 + + par = use_parallel_netcdf + do_io = par .or. (mype==0) + + call ESMF_FieldBundleGet(wrtfb, fieldCount=fieldCount, rc=rc); ESMF_ERR_RETURN(rc) allocate(compress_err(fieldCount)); compress_err=-999. allocate(fldlev(fieldCount)) ; fldlev = 0 allocate(fcstField(fieldCount)) allocate(varids(fieldCount)) - call ESMF_FieldBundleGet(fieldbundle, fieldList=fcstField, grid=wrtGrid, & + call ESMF_FieldBundleGet(wrtfb, fieldList=fcstField, grid=wrtGrid, & ! itemorderflag=ESMF_ITEMORDER_ADDORDER, & rc=rc); ESMF_ERR_RETURN(rc) call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc); ESMF_ERR_RETURN(rc) do i=1,fieldCount - call ESMF_FieldGet(fcstField(i), dimCount=fieldDimCount, rc=rc); ESMF_ERR_RETURN(rc) + call ESMF_FieldGet(fcstField(i), dimCount=fieldDimCount, array=array, rc=rc); ESMF_ERR_RETURN(rc) + if (fieldDimCount > 3) then write(0,*)"write_netcdf: Only 2D and 3D fields are supported!" - stop + call ESMF_Finalize(endflag=ESMF_END_ABORT) end if + + ! use first field to determine tile number, grid size, start index etc. + if (i == 1) then + call ESMF_ArrayGet(array, & + distgrid=distgrid, & + dimCount=dimCount, & + deCount=deCount, & + localDeCount=localDeCount, & + tileCount=tileCount, & + rc=rc); ESMF_ERR_RETURN(rc) + + allocate(minIndexPDe(dimCount,deCount)) + allocate(maxIndexPDe(dimCount,deCount)) + allocate(minIndexPTile(dimCount, tileCount)) + allocate(maxIndexPTile(dimCount, tileCount)) + call ESMF_DistGridGet(distgrid, & + minIndexPDe=minIndexPDe, maxIndexPDe=maxIndexPDe, & + minIndexPTile=minIndexPTile, maxIndexPTile=maxIndexPTile, & + rc=rc); ESMF_ERR_RETURN(rc) + + allocate(deToTileMap(deCount)) + allocate(localDeToDeMap(localDeCount)) + call ESMF_ArrayGet(array, & + deToTileMap=deToTileMap, & + localDeToDeMap=localDeToDeMap, & + rc=rc); ESMF_ERR_RETURN(rc) + + is_cubed_sphere = (tileCount == 6) + my_tile = deToTileMap(localDeToDeMap(1)+1) + im = maxIndexPTile(1,1) + jm = maxIndexPTile(2,1) + start_i = minIndexPDe(1,localDeToDeMap(1)+1) + start_j = minIndexPDe(2,localDeToDeMap(1)+1) + if (.not. par) then + start_i = 1 + start_j = 1 + end if + end if + if (fieldDimCount > gridDimCount) then allocate(ungriddedLBound(fieldDimCount-gridDimCount)) allocate(ungriddedUBound(fieldDimCount-gridDimCount)) @@ -104,301 +180,559 @@ subroutine write_netcdf(fieldbundle, wrtfb, filename, mpi_comm, mype, im, jm, ic lm = maxval(fldlev(:)) - allocate(arrayr4(im,jm)) - allocate(arrayr8(im,jm)) - allocate(arrayr4_3d(im,jm,lm),arrayr4_3d_save(im,jm,lm)) - allocate(arrayr8_3d(im,jm,lm)) - -! create netcdf file and enter define mode - if (mype==0) then - - ncerr = nf90_create(trim(filename),& - cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL),& - ncid=ncid); NC_ERR_STOP(ncerr) - ncerr = nf90_set_fill(ncid, NF90_NOFILL, oldMode); NC_ERR_STOP(ncerr) - - ! define dimensions - ncerr = nf90_def_dim(ncid, "grid_xt", im, im_dimid); NC_ERR_STOP(ncerr) - ncerr = nf90_def_dim(ncid, "grid_yt", jm, jm_dimid); NC_ERR_STOP(ncerr) - ! define coordinate variables - ncerr = nf90_def_var(ncid, "grid_xt", NF90_DOUBLE, im_dimid, im_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_def_var(ncid, "lon", NF90_DOUBLE, (/im_dimid,jm_dimid/), lon_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lon_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lon_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "cartesian_axis", "X"); NC_ERR_STOP(ncerr) - ncerr = nf90_def_var(ncid, "grid_yt", NF90_DOUBLE, jm_dimid, jm_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_def_var(ncid, "lat", NF90_DOUBLE, (/im_dimid,jm_dimid/), lat_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lat_varid, "long_name", "T-cell latitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lat_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "cartesian_axis", "Y"); NC_ERR_STOP(ncerr) - - if (lm > 1) then - call add_dim(ncid, "pfull", pfull_dimid, wrtgrid, rc) - call add_dim(ncid, "phalf", phalf_dimid, wrtgrid, rc) + ! for serial output allocate 'global' arrays + if (.not. par) then + allocate(array_r4(im,jm)) + allocate(array_r8(im,jm)) + allocate(array_r4_3d(im,jm,lm)) + allocate(array_r8_3d(im,jm,lm)) + if (is_cubed_sphere) then + allocate(array_r4_cube(im,jm,tileCount)) + allocate(array_r8_cube(im,jm,tileCount)) + allocate(array_r4_3d_cube(im,jm,lm,tileCount)) + allocate(array_r8_3d_cube(im,jm,lm,tileCount)) + end if end if - call add_dim(ncid, "time", time_dimid, wrtgrid, rc) + ! create netcdf file and enter define mode + if (do_io) then + + if (par) then + ncerr = nf90_create(trim(filename),& + cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL),& + comm=mpi_comm, info = MPI_INFO_NULL, ncid=ncid); NC_ERR_STOP(ncerr) + else + ncerr = nf90_create(trim(filename),& + cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL),& + ncid=ncid); NC_ERR_STOP(ncerr) + end if - call get_global_attr(wrtfb, ncid, rc) + ! disable auto filling. + ncerr = nf90_set_fill(ncid, NF90_NOFILL, oldMode); NC_ERR_STOP(ncerr) - do i=1, fieldCount - call ESMF_FieldGet(fcstField(i), name=fldName, typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) - - ! define variables - if (fldlev(i) == 1) then - if (typekind == ESMF_TYPEKIND_R4) then - if (ideflate > 0) then - if (ichunk2d < 0 .or. jchunk2d < 0) then - ! let netcdf lib choose chunksize - ! shuffle filter on for 2d fields (lossless compression) - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i), & - shuffle=.true.,deflate_level=ideflate); NC_ERR_STOP(ncerr) - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i), & - shuffle=.true.,deflate_level=ideflate,& - chunksizes=(/ichunk2d,jchunk2d,1/),cache_size=40*im*jm); NC_ERR_STOP(ncerr) - endif - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - endif - else if (typekind == ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & - (/im_dimid,jm_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - else - write(0,*)'Unsupported typekind ', typekind - stop - end if - else if (fldlev(i) > 1) then - if (typekind == ESMF_TYPEKIND_R4) then - if (ideflate > 0) then - ! shuffle filter off for 3d fields using lossy compression - if (nbits > 0) then - shuffle=.false. + ! define dimensions [grid_xt, grid_yta ,(pfull/phalf), (tile), time] + ncerr = nf90_def_dim(ncid, "grid_xt", im, im_dimid); NC_ERR_STOP(ncerr) + ncerr = nf90_def_dim(ncid, "grid_yt", jm, jm_dimid); NC_ERR_STOP(ncerr) + if (lm > 1) then + call add_dim(ncid, "pfull", pfull_dimid, wrtgrid, rc) + call add_dim(ncid, "phalf", phalf_dimid, wrtgrid, rc) + end if + if (is_cubed_sphere) then + ncerr = nf90_def_dim(ncid, "tile", tileCount, tile_dimid); NC_ERR_STOP(ncerr) + end if + call add_dim(ncid, "time", time_dimid, wrtgrid, rc) + + ! define coordinate variables + ncerr = nf90_def_var(ncid, "grid_xt", NF90_DOUBLE, im_dimid, im_varid); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, im_varid, "cartesian_axis", "X"); NC_ERR_STOP(ncerr) + ncerr = nf90_def_var(ncid, "grid_yt", NF90_DOUBLE, jm_dimid, jm_varid); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "cartesian_axis", "Y"); NC_ERR_STOP(ncerr) + if (is_cubed_sphere) then + ncerr = nf90_def_var(ncid, "tile", NF90_INT, tile_dimid, tile_varid); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, tile_varid, "long_name", "cubed-spehere face"); NC_ERR_STOP(ncerr) + end if + + ! coordinate variable attributes based on output_grid type + if (trim(output_grid(grid_id)) == 'gaussian_grid' .or. & + trim(output_grid(grid_id)) == 'global_latlon' .or. & + trim(output_grid(grid_id)) == 'regional_latlon') then + ncerr = nf90_put_att(ncid, im_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, im_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "long_name", "T-cell latiitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'rotated_latlon') then + ncerr = nf90_put_att(ncid, im_varid, "long_name", "rotated T-cell longiitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, im_varid, "units", "degrees"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "long_name", "rotated T-cell latiitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees"); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'lambert_conformal') then + ncerr = nf90_put_att(ncid, im_varid, "long_name", "x-coordinate of projection"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, im_varid, "units", "meters"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "long_name", "y-coordinate of projection"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, jm_varid, "units", "meters"); NC_ERR_STOP(ncerr) + end if + + ! define longitude variable + if (is_cubed_sphere) then + ncerr = nf90_def_var(ncid, "lon", NF90_DOUBLE, [im_dimid,jm_dimid,tile_dimid], lon_varid); NC_ERR_STOP(ncerr) + else + ncerr = nf90_def_var(ncid, "lon", NF90_DOUBLE, [im_dimid,jm_dimid ], lon_varid); NC_ERR_STOP(ncerr) + end if + ncerr = nf90_put_att(ncid, lon_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, lon_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) + + ! define latitude variable + if (is_cubed_sphere) then + ncerr = nf90_def_var(ncid, "lat", NF90_DOUBLE, [im_dimid,jm_dimid,tile_dimid], lat_varid); NC_ERR_STOP(ncerr) + else + ncerr = nf90_def_var(ncid, "lat", NF90_DOUBLE, [im_dimid,jm_dimid ], lat_varid); NC_ERR_STOP(ncerr) + end if + ncerr = nf90_put_att(ncid, lat_varid, "long_name", "T-cell latitude"); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, lat_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) + + if (par) then + ncerr = nf90_var_par_access(ncid, im_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + ncerr = nf90_var_par_access(ncid, lon_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + ncerr = nf90_var_par_access(ncid, jm_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + ncerr = nf90_var_par_access(ncid, lat_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + if (is_cubed_sphere) then + ncerr = nf90_var_par_access(ncid, tile_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + end if + end if + + + call get_global_attr(wrtfb, ncid, rc) + + + ! define variables (fields) + if (is_cubed_sphere) then + allocate(dimids_2d(4)) + allocate(dimids_3d(5)) + dimids_2d = [im_dimid,jm_dimid, tile_dimid,time_dimid] + if (lm > 1) dimids_3d = [im_dimid,jm_dimid,pfull_dimid,tile_dimid,time_dimid] + else + allocate(dimids_2d(3)) + allocate(dimids_3d(4)) + dimids_2d = [im_dimid,jm_dimid, time_dimid] + if (lm > 1) dimids_3d = [im_dimid,jm_dimid,pfull_dimid, time_dimid] + end if + + do i=1, fieldCount + call ESMF_FieldGet(fcstField(i), name=fldName, rank=rank, typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) + + par_access = NF90_INDEPENDENT + ! define variables + if (rank == 2) then + if (typekind == ESMF_TYPEKIND_R4) then + if (ideflate(grid_id) > 0) then + if (ichunk2d(grid_id) < 0 .or. jchunk2d(grid_id) < 0) then + ! let netcdf lib choose chunksize + ! shuffle filter on for 2d fields (lossless compression) + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_2d, varids(i), & + shuffle=.true.,deflate_level=ideflate(grid_id)); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_2d, varids(i), & + shuffle=.true.,deflate_level=ideflate(grid_id),& + chunksizes=[ichunk2d(grid_id),jchunk2d(grid_id),tileCount,1]); NC_ERR_STOP(ncerr) + else + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_2d, varids(i), & + shuffle=.true.,deflate_level=ideflate(grid_id),& + chunksizes=[ichunk2d(grid_id),jchunk2d(grid_id), 1]); NC_ERR_STOP(ncerr) + end if + end if + ! compression filters require collective access. + par_access = NF90_COLLECTIVE else - shuffle=.true. - endif - if (ichunk3d < 0 .or. jchunk3d < 0 .or. kchunk3d < 0) then - ! let netcdf lib choose chunksize - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i), & - shuffle=shuffle,deflate_level=ideflate); NC_ERR_STOP(ncerr) + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_2d, varids(i)); NC_ERR_STOP(ncerr) + end if + else if (typekind == ESMF_TYPEKIND_R8) then + ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & + dimids_2d, varids(i)); NC_ERR_STOP(ncerr) + else + write(0,*)'Unsupported typekind ', typekind + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + else if (rank == 3) then + if (typekind == ESMF_TYPEKIND_R4) then + if (ideflate(grid_id) > 0) then + ! shuffle filter off for 3d fields using lossy compression + if (nbits(grid_id) > 0) then + shuffle=.false. + else + shuffle=.true. + end if + if (ichunk3d(grid_id) < 0 .or. jchunk3d(grid_id) < 0 .or. kchunk3d(grid_id) < 0) then + ! let netcdf lib choose chunksize + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_3d, varids(i), & + shuffle=shuffle,deflate_level=ideflate(grid_id)); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_3d, varids(i), & + shuffle=shuffle,deflate_level=ideflate(grid_id),& + chunksizes=[ichunk3d(grid_id),jchunk3d(grid_id),kchunk3d(grid_id),tileCount,1]); NC_ERR_STOP(ncerr) + else + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_3d, varids(i), & + shuffle=shuffle,deflate_level=ideflate(grid_id),& + chunksizes=[ichunk3d(grid_id),jchunk3d(grid_id),kchunk3d(grid_id), 1]); NC_ERR_STOP(ncerr) + end if + end if + ! compression filters require collective access. + par_access = NF90_COLLECTIVE else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i), & - shuffle=shuffle,deflate_level=ideflate,& - chunksizes=(/ichunk3d,jchunk3d,kchunk3d,1/)); NC_ERR_STOP(ncerr) - endif + ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & + dimids_3d, varids(i)); NC_ERR_STOP(ncerr) + end if + else if (typekind == ESMF_TYPEKIND_R8) then + ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & + dimids_3d, varids(i)); NC_ERR_STOP(ncerr) else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - endif - else if (typekind == ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - else - write(0,*)'Unsupported typekind ', typekind - stop - end if - end if - - ! define variable attributes - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & - rc=rc); ESMF_ERR_RETURN(rc) - - do j=1,attCount - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=j, & - name=attName, typekind=attTypeKind, itemCount=n, & - rc=rc); ESMF_ERR_RETURN(rc) + write(0,*)'Unsupported typekind ', typekind + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + else + write(0,*)'Unsupported rank ', rank + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + if (par) then + ncerr = nf90_var_par_access(ncid, varids(i), par_access); NC_ERR_STOP(ncerr) + end if - if ( index(trim(attName),"ESMF") /= 0 ) then - cycle - endif + ! define variable attributes + call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, count=attCount, & + rc=rc); ESMF_ERR_RETURN(rc) - if (attTypeKind==ESMF_TYPEKIND_I4) then + do j=1,attCount call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=j, & + name=attName, typekind=attTypeKind, & rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varival); NC_ERR_STOP(ncerr) - else if (attTypeKind==ESMF_TYPEKIND_R4) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, & - rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr4val); NC_ERR_STOP(ncerr) + if (index(trim(attName),"ESMF") /= 0) then + cycle + end if - else if (attTypeKind==ESMF_TYPEKIND_R8) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr8val, & - rc=rc); ESMF_ERR_RETURN(rc) - if (trim(attName) /= '_FillValue') then - ! FIXME: _FillValue must be cast to var type for recent versions of netcdf - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr8val); NC_ERR_STOP(ncerr) - endif + if (attTypeKind==ESMF_TYPEKIND_I4) then + call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & + name=trim(attName), value=varival, & + rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_att(ncid, varids(i), trim(attName), varival); NC_ERR_STOP(ncerr) + + else if (attTypeKind==ESMF_TYPEKIND_R4) then + call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & + name=trim(attName), value=varr4val, & + rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr4val); NC_ERR_STOP(ncerr) + + else if (attTypeKind==ESMF_TYPEKIND_R8) then + call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & + name=trim(attName), value=varr8val, & + rc=rc); ESMF_ERR_RETURN(rc) + if (trim(attName) /= '_FillValue') then + ! FIXME: _FillValue must be cast to var type when using NF90_NETCDF4 + ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr8val); NC_ERR_STOP(ncerr) + end if + + else if (attTypeKind==ESMF_TYPEKIND_CHARACTER) then + call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & + name=trim(attName), value=varcval, & + rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_att(ncid, varids(i), trim(attName), trim(varcval)); NC_ERR_STOP(ncerr) - else if (attTypeKind==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varcval, & - rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), trim(varcval)); NC_ERR_STOP(ncerr) - - end if - - end do ! j=1,attCount - - end do ! i=1,fieldCount - - ! write grid_xt, grid_yt attributes - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "T-cell latiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "rotated T-cell longiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "degrees"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "rotated T-cell latiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees"); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "x-coordinate of projection"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "meters"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "y-coordinate of projection"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "meters"); NC_ERR_STOP(ncerr) - endif - - ncerr = nf90_enddef(ncid); NC_ERR_STOP(ncerr) + end if + + end do ! j=1,attCount + + if (is_cubed_sphere) then + ncerr = nf90_put_att(ncid, varids(i), 'coordinates', 'lon lat'); NC_ERR_STOP(ncerr) + ncerr = nf90_put_att(ncid, varids(i), 'grid_mapping', 'cubed_sphere'); NC_ERR_STOP(ncerr) + end if + + end do ! i=1,fieldCount + + ncerr = nf90_enddef(ncid); NC_ERR_STOP(ncerr) + end if + ! end of define mode + + ! + ! write dimension variables and lon,lat variables + ! + if (allocated(start_idx)) deallocate(start_idx) + if (is_cubed_sphere) then + allocate(start_idx(3)) + start_idx = [start_i, start_j, my_tile] + else + allocate(start_idx(2)) + start_idx = [start_i, start_j] + end if + + ! write lon (lon_varid) + if (par) then + call ESMF_GridGetCoord(wrtGrid, coordDim=1, farrayPtr=array_r8, rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_var(ncid, lon_varid, values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + else + call ESMF_GridGetCoord(wrtGrid, coordDim=1, array=array, rc=rc); ESMF_ERR_RETURN(rc) + if (is_cubed_sphere) then + do t=1,tileCount + call ESMF_ArrayGather(array, array_r8_cube(:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (do_io) then + ncerr = nf90_put_var(ncid, lon_varid, values=array_r8_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_ArrayGather(array, array_r8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (do_io) then + ncerr = nf90_put_var(ncid, lon_varid, values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + end if + endif end if -! end of define mode - - ! write grid_xt, grid_yt values - call ESMF_GridGetCoord(wrtGrid, coordDim=1, array=array, rc=rc); ESMF_ERR_RETURN(rc) - call ESMF_ArrayGather(array, arrayr8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_var(ncid, im_varid, values=arrayr8(:,1) ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then + istart = lbound(array_r8,1); iend = ubound(array_r8,1) + jstart = lbound(array_r8,2); jend = ubound(array_r8,2) + + ! write grid_xt (im_varid) + if (do_io) then + allocate (x(im)) + if (trim(output_grid(grid_id)) == 'gaussian_grid' .or. & + trim(output_grid(grid_id)) == 'global_latlon' .or. & + trim(output_grid(grid_id)) == 'regional_latlon') then + ncerr = nf90_put_var(ncid, im_varid, values=array_r8(:,jstart), start=[istart], count=[iend-istart+1]); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'rotated_latlon') then + do i=1,im + x(i) = lon1(grid_id) + (lon2(grid_id)-lon1(grid_id))/(im-1) * (i-1) + end do + ncerr = nf90_put_var(ncid, im_varid, values=x); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'lambert_conformal') then do i=1,im - x(i) = lon1 + (lon2-lon1)/(im-1) * (i-1) - enddo - ncerr = nf90_put_var(ncid, im_varid, values=x ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then + x(i) = dx(grid_id) * (i-1) + end do + ncerr = nf90_put_var(ncid, im_varid, values=x); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'cubed_sphere_grid') then do i=1,im - x(i) = dx * (i-1) - enddo - ncerr = nf90_put_var(ncid, im_varid, values=x ); NC_ERR_STOP(ncerr) + x(i) = i + end do + ncerr = nf90_put_var(ncid, im_varid, values=x); NC_ERR_STOP(ncerr) + else + write(0,*)'unknown output_grid ', trim(output_grid(grid_id)) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + end if + + ! write lat (lat_varid) + if (par) then + call ESMF_GridGetCoord(wrtGrid, coordDim=2, farrayPtr=array_r8, rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_var(ncid, lat_varid, values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + else + call ESMF_GridGetCoord(wrtGrid, coordDim=2, array=array, rc=rc); ESMF_ERR_RETURN(rc) + if (is_cubed_sphere) then + do t=1,tileCount + call ESMF_ArrayGather(array, array_r8_cube(:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (do_io) then + ncerr = nf90_put_var(ncid, lat_varid, values=array_r8_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_ArrayGather(array, array_r8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (do_io) then + ncerr = nf90_put_var(ncid, lat_varid, values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + end if endif - ncerr = nf90_put_var(ncid, lon_varid, values=arrayr8 ); NC_ERR_STOP(ncerr) - endif - - call ESMF_GridGetCoord(wrtGrid, coordDim=2, array=array, rc=rc); ESMF_ERR_RETURN(rc) - call ESMF_ArrayGather(array, arrayr8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_var(ncid, jm_varid, values=arrayr8(1,:) ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then + end if + + ! write grid_yt (jm_varid) + if (do_io) then + allocate (y(jm)) + if (trim(output_grid(grid_id)) == 'gaussian_grid' .or. & + trim(output_grid(grid_id)) == 'global_latlon' .or. & + trim(output_grid(grid_id)) == 'regional_latlon') then + ncerr = nf90_put_var(ncid, jm_varid, values=array_r8(istart,:), start=[jstart], count=[jend-jstart+1]); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'rotated_latlon') then do j=1,jm - y(j) = lat1 + (lat2-lat1)/(jm-1) * (j-1) - enddo - ncerr = nf90_put_var(ncid, jm_varid, values=y ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then + y(j) = lat1(grid_id) + (lat2(grid_id)-lat1(grid_id))/(jm-1) * (j-1) + end do + ncerr = nf90_put_var(ncid, jm_varid, values=y); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'lambert_conformal') then do j=1,jm - y(j) = dy * (j-1) - enddo - ncerr = nf90_put_var(ncid, jm_varid, values=y ); NC_ERR_STOP(ncerr) - endif - ncerr = nf90_put_var(ncid, lat_varid, values=arrayr8 ); NC_ERR_STOP(ncerr) - endif + y(j) = dy(grid_id) * (j-1) + end do + ncerr = nf90_put_var(ncid, jm_varid, values=y); NC_ERR_STOP(ncerr) + else if (trim(output_grid(grid_id)) == 'cubed_sphere_grid') then + do j=1,jm + y(j) = j + end do + ncerr = nf90_put_var(ncid, jm_varid, values=y); NC_ERR_STOP(ncerr) + else + write(0,*)'unknown output_grid ', trim(output_grid(grid_id)) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + end if + ! write tile (tile_varid) + if (do_io .and. is_cubed_sphere) then + ncerr = nf90_put_var(ncid, tile_varid, values=[1,2,3,4,5,6]); NC_ERR_STOP(ncerr) + end if + + ! write variables (fields) do i=1, fieldCount - call ESMF_FieldGet(fcstField(i),name=fldName,typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) + call ESMF_FieldGet(fcstField(i),name=fldName,rank=rank,typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) - if (fldlev(i) == 1) then - if (typekind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGather(fcstField(i), arrayr4, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - ncerr = nf90_put_var(ncid, varids(i), values=arrayr4, start=(/1,1,1/),count=(/im,jm,1/) ); NC_ERR_STOP(ncerr) - end if - else if (typekind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGather(fcstField(i), arrayr8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - ncerr = nf90_put_var(ncid, varids(i), values=arrayr8, start=(/1,1,1/),count=(/im,jm,1/) ); NC_ERR_STOP(ncerr) - end if + if (rank == 2) then + + if (allocated(start_idx)) deallocate(start_idx) + if (is_cubed_sphere) then + allocate(start_idx(4)) + start_idx = [start_i,start_j,my_tile,1] + else + allocate(start_idx(3)) + start_idx = [start_i,start_j, 1] end if - else if (fldlev(i) > 1) then + if (typekind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGather(fcstField(i), arrayr4_3d, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - if (ideflate > 0 .and. nbits > 0) then - ! Lossy compression if nbits>0. - ! The floating point data is quantized to improve compression - ! See doi:10.5194/gmd-10-413-2017. The method employed - ! here is identical to the 'scaled linear packing' method in - ! that paper, except that the data are scaling into an arbitrary - ! range (2**nbits-1 not just 2**16-1) and are stored as - ! re-scaled floats instead of short integers. - ! The zlib algorithm does almost as - ! well packing the re-scaled floats as it does the scaled - ! integers, and this avoids the need for the client to apply the - ! rescaling (plus it allows the ability to adjust the packing - ! range). - arrayr4_3d_save = arrayr4_3d - dataMax = maxval(arrayr4_3d); dataMin = minval(arrayr4_3d) - arrayr4_3d = quantized(arrayr4_3d_save, nbits, dataMin, dataMax) - ! compute max abs compression error, save as a variable - ! attribute. - compress_err(i) = maxval(abs(arrayr4_3d_save-arrayr4_3d)) - endif - ncerr = nf90_put_var(ncid, varids(i), values=arrayr4_3d, start=(/1,1,1/),count=(/im,jm,lm,1/) ); NC_ERR_STOP(ncerr) - end if + if (par) then + call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=array_r4, rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_var(ncid, varids(i), values=array_r4, start=start_idx); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + call ESMF_FieldGet(fcstField(i), array=array, rc=rc); ESMF_ERR_RETURN(rc) + do t=1,tileCount + call ESMF_ArrayGather(array, array_r4_cube(:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (do_io) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r4_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_FieldGather(fcstField(i), array_r4, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (do_io) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r4, start=start_idx); NC_ERR_STOP(ncerr) + end if + end if + end if else if (typekind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGather(fcstField(i), arrayr8_3d, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) - if (mype==0) then - ncerr = nf90_put_var(ncid, varids(i), values=arrayr8_3d, start=(/1,1,1/),count=(/im,jm,lm,1/) ); NC_ERR_STOP(ncerr) - end if + if (par) then + call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=array_r8, rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_var(ncid, varids(i), values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + call ESMF_FieldGet(fcstField(i), array=array, rc=rc); ESMF_ERR_RETURN(rc) + do t=1,tileCount + call ESMF_ArrayGather(array, array_r8_cube(:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (do_io) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r8_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_FieldGather(fcstField(i), array_r8, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (do_io) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r8, start=start_idx); NC_ERR_STOP(ncerr) + end if + end if + end if end if - end if + else if (rank == 3) then - end do + if (allocated(start_idx)) deallocate(start_idx) + if (is_cubed_sphere) then + allocate(start_idx(5)) + start_idx = [start_i,start_j,1,my_tile,1] + else + allocate(start_idx(4)) + start_idx = [start_i,start_j,1, 1] + end if - if (ideflate > 0 .and. nbits > 0 .and. mype == 0) then + if (typekind == ESMF_TYPEKIND_R4) then + if (par) then + call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=array_r4_3d, rc=rc); ESMF_ERR_RETURN(rc) + if (ideflate(grid_id) > 0 .and. nbits(grid_id) > 0) then + dataMax = maxval(array_r4_3d) + dataMin = minval(array_r4_3d) + call mpi_allreduce(mpi_in_place,dataMax,1,mpi_real4,mpi_max,mpi_comm,ierr) + call mpi_allreduce(mpi_in_place,dataMin,1,mpi_real4,mpi_min,mpi_comm,ierr) + call quantize_array(array_r4_3d, dataMin, dataMax, nbits(grid_id), compress_err(i)) + call mpi_allreduce(mpi_in_place,compress_err(i),1,mpi_real4,mpi_max,mpi_comm,ierr) + end if + ncerr = nf90_put_var(ncid, varids(i), values=array_r4_3d, start=start_idx); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + call ESMF_FieldGet(fcstField(i), array=array, rc=rc); ESMF_ERR_RETURN(rc) + do t=1,tileCount + call ESMF_ArrayGather(array, array_r4_3d_cube(:,:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (mype==0) then + if (ideflate(grid_id) > 0 .and. nbits(grid_id) > 0) then + call quantize_array(array_r4_3d_cube, minval(array_r4_3d_cube), maxval(array_r4_3d_cube), nbits(grid_id), compress_err(i)) + end if + ncerr = nf90_put_var(ncid, varids(i), values=array_r4_3d_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_FieldGather(fcstField(i), array_r4_3d, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (mype==0) then + if (ideflate(grid_id) > 0 .and. nbits(grid_id) > 0) then + call quantize_array(array_r4_3d, minval(array_r4_3d), maxval(array_r4_3d), nbits(grid_id), compress_err(i)) + end if + ncerr = nf90_put_var(ncid, varids(i), values=array_r4_3d, start=start_idx); NC_ERR_STOP(ncerr) + end if + end if + end if + else if (typekind == ESMF_TYPEKIND_R8) then + if (par) then + call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=array_r8_3d, rc=rc); ESMF_ERR_RETURN(rc) + ncerr = nf90_put_var(ncid, varids(i), values=array_r8_3d, start=start_idx); NC_ERR_STOP(ncerr) + else + if (is_cubed_sphere) then + call ESMF_FieldGet(fcstField(i), array=array, rc=rc); ESMF_ERR_RETURN(rc) + do t=1,tileCount + call ESMF_ArrayGather(array, array_r8_3d_cube(:,:,:,t), rootPet=0, tile=t, rc=rc); ESMF_ERR_RETURN(rc) + end do + if (mype==0) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r8_3d_cube, start=start_idx); NC_ERR_STOP(ncerr) + end if + else + call ESMF_FieldGather(fcstField(i), array_r8_3d, rootPet=0, rc=rc); ESMF_ERR_RETURN(rc) + if (mype==0) then + ncerr = nf90_put_var(ncid, varids(i), values=array_r8_3d, start=start_idx); NC_ERR_STOP(ncerr) + end if + end if + end if + end if ! end typekind + + else + + write(0,*)'Unsupported rank ', rank + call ESMF_Finalize(endflag=ESMF_END_ABORT) + + end if ! end rank + + end do ! end fieldCount + + if (ideflate(grid_id) > 0 .and. nbits(grid_id) > 0 .and. do_io) then ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) do i=1, fieldCount if (compress_err(i) > 0) then ncerr = nf90_put_att(ncid, varids(i), 'max_abs_compression_error', compress_err(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, varids(i), 'nbits', nbits); NC_ERR_STOP(ncerr) - endif - enddo + ncerr = nf90_put_att(ncid, varids(i), 'nbits', nbits(grid_id)); NC_ERR_STOP(ncerr) + end if + end do ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - endif + end if - deallocate(arrayr4) - deallocate(arrayr8) - deallocate(arrayr4_3d,arrayr4_3d_save) - deallocate(arrayr8_3d) + if (.not. par) then + deallocate(array_r4) + deallocate(array_r8) + deallocate(array_r4_3d) + deallocate(array_r8_3d) + if (is_cubed_sphere) then + deallocate(array_r4_cube) + deallocate(array_r8_cube) + deallocate(array_r4_3d_cube) + deallocate(array_r8_3d_cube) + end if + end if + + if (do_io) then + deallocate(dimids_2d) + deallocate(dimids_3d) + end if deallocate(fcstField) deallocate(varids) deallocate(compress_err) - if (mype==0) then - ncerr = nf90_close(ncid=ncid); NC_ERR_STOP(ncerr) + if (do_io) then + ncerr = nf90_close(ncid=ncid); NC_ERR_STOP(ncerr) end if end subroutine write_netcdf -! + !---------------------------------------------------------------------------------------- subroutine get_global_attr(fldbundle, ncid, rc) type(ESMF_FieldBundle), intent(in) :: fldbundle @@ -406,21 +740,19 @@ subroutine get_global_attr(fldbundle, ncid, rc) integer, intent(out) :: rc ! local variable - integer :: i, attcount + integer :: i, attCount integer :: ncerr character(len=ESMF_MAXSTR) :: attName type(ESMF_TypeKind_Flag) :: typekind integer :: varival - real(ESMF_KIND_R4) :: varr4val real(ESMF_KIND_R4), dimension(:), allocatable :: varr4list - real(ESMF_KIND_R8) :: varr8val real(ESMF_KIND_R8), dimension(:), allocatable :: varr8list integer :: itemCount character(len=ESMF_MAXSTR) :: varcval ! call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & + attnestflag=ESMF_ATTNEST_OFF, count=attCount, & rc=rc); ESMF_ERR_RETURN(rc) do i=1,attCount @@ -458,7 +790,7 @@ subroutine get_global_attr(fldbundle, ncid, rc) end do end subroutine get_global_attr -! + !---------------------------------------------------------------------------------------- subroutine get_grid_attr(grid, prefix, ncid, varid, rc) type(ESMF_Grid), intent(in) :: grid @@ -468,7 +800,7 @@ subroutine get_grid_attr(grid, prefix, ncid, varid, rc) integer, intent(out) :: rc ! local variable - integer :: i, attcount, n, ind + integer :: i, attCount, n, ind integer :: ncerr character(len=ESMF_MAXSTR) :: attName type(ESMF_TypeKind_Flag) :: typekind @@ -479,16 +811,14 @@ subroutine get_grid_attr(grid, prefix, ncid, varid, rc) character(len=ESMF_MAXSTR) :: varcval ! call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & + attnestflag=ESMF_ATTNEST_OFF, count=attCount, & rc=rc); ESMF_ERR_RETURN(rc) - !write(0,*)'grid attcount = ', attcount do i=1,attCount call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & typekind=typekind, itemCount=n, rc=rc); ESMF_ERR_RETURN(rc) - !write(0,*)'grid att = ',i,trim(attName), ' itemCount = ' , n if (index(trim(attName), trim(prefix)//":")==1) then ind = len(trim(prefix)//":") @@ -507,10 +837,10 @@ subroutine get_grid_attr(grid, prefix, ncid, varid, rc) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc); ESMF_ERR_RETURN(rc) if (trim(attName) /= '_FillValue') then - ! FIXME: _FillValue must be cast to var type for recent versions - ! of netcdf + ! FIXME: _FillValue must be cast to var type when using + ! NF90_NETCDF4. Until this is fixed, using netCDF default _FillValue. ncerr = nf90_put_att(ncid, varid, trim(attName(ind+1:len(attName))), varr8val); NC_ERR_STOP(ncerr) - endif + end if else if (typekind==ESMF_TYPEKIND_CHARACTER) then call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & @@ -525,6 +855,7 @@ subroutine get_grid_attr(grid, prefix, ncid, varid, rc) end subroutine get_grid_attr +!---------------------------------------------------------------------------------------- subroutine add_dim(ncid, dim_name, dimid, grid, rc) integer, intent(in) :: ncid character(len=*), intent(in) :: dim_name @@ -533,75 +864,127 @@ subroutine add_dim(ncid, dim_name, dimid, grid, rc) integer, intent(out) :: rc ! local variable - integer :: i, attcount, n, dim_varid + integer :: n, dim_varid integer :: ncerr - character(len=ESMF_MAXSTR) :: attName type(ESMF_TypeKind_Flag) :: typekind - integer, allocatable :: valueListI(:) real(ESMF_KIND_R4), allocatable :: valueListR4(:) real(ESMF_KIND_R8), allocatable :: valueListR8(:) - character(len=ESMF_MAXSTR), allocatable :: valueListC(:) ! call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, name=dim_name, & typekind=typekind, itemCount=n, rc=rc); ESMF_ERR_RETURN(rc) - if ( trim(dim_name) == "time" ) then - ncerr = nf90_def_dim(ncid, trim(dim_name), NF90_UNLIMITED, dimid); NC_ERR_STOP(ncerr) + if (trim(dim_name) == "time") then + ! using an unlimited dim requires collective mode (NF90_COLLECTIVE) + ! for parallel writes, which seems to slow things down on hera. + !ncerr = nf90_def_dim(ncid, trim(dim_name), NF90_UNLIMITED, dimid); NC_ERR_STOP(ncerr) + ncerr = nf90_def_dim(ncid, trim(dim_name), 1, dimid); NC_ERR_STOP(ncerr) else ncerr = nf90_def_dim(ncid, trim(dim_name), n, dimid); NC_ERR_STOP(ncerr) end if if (typekind==ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, dim_name, NF90_REAL8, dimids=(/dimid/), varid=dim_varid); NC_ERR_STOP(ncerr) + ncerr = nf90_def_var(ncid, dim_name, NF90_REAL8, dimids=[dimid], varid=dim_varid); NC_ERR_STOP(ncerr) allocate(valueListR8(n)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name=trim(dim_name), valueList=valueListR8, rc=rc); ESMF_ERR_RETURN(rc) ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_var(ncid, dim_varid, values=valueListR8 ); NC_ERR_STOP(ncerr) + ncerr = nf90_put_var(ncid, dim_varid, values=valueListR8); NC_ERR_STOP(ncerr) ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) deallocate(valueListR8) else if (typekind==ESMF_TYPEKIND_R4) then - ncerr = nf90_def_var(ncid, dim_name, NF90_REAL4, dimids=(/dimid/), varid=dim_varid); NC_ERR_STOP(ncerr) + ncerr = nf90_def_var(ncid, dim_name, NF90_REAL4, dimids=[dimid], varid=dim_varid); NC_ERR_STOP(ncerr) allocate(valueListR4(n)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name=trim(dim_name), valueList=valueListR4, rc=rc); ESMF_ERR_RETURN(rc) ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_var(ncid, dim_varid, values=valueListR4 ); NC_ERR_STOP(ncerr) + ncerr = nf90_put_var(ncid, dim_varid, values=valueListR4); NC_ERR_STOP(ncerr) ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) deallocate(valueListR4) else write(0,*)'Error in module_write_netcdf.F90(add_dim) unknown typekind for ',trim(dim_name) call ESMF_Finalize(endflag=ESMF_END_ABORT) end if + if (par) then + ncerr = nf90_var_par_access(ncid, dim_varid, NF90_INDEPENDENT); NC_ERR_STOP(ncerr) + end if call get_grid_attr(grid, dim_name, ncid, dim_varid, rc) end subroutine add_dim -! + !---------------------------------------------------------------------------------------- - subroutine nccheck(status) - use netcdf - implicit none - integer, intent (in) :: status - - if (status /= nf90_noerr) then - write(0,*) status, trim(nf90_strerror(status)) - stop "stopped" + subroutine quantize_array_3d(array, dataMin, dataMax, nbits, compress_err) + + real(4), dimension(:,:,:), intent(inout) :: array + real(4), intent(in) :: dataMin, dataMax + integer, intent(in) :: nbits + real(4), intent(out) :: compress_err + + real(4) :: scale_fact, offset + real(4), dimension(:,:,:), allocatable :: array_save + ! Lossy compression if nbits>0. + ! The floating point data is quantized to improve compression + ! See doi:10.5194/gmd-10-413-2017. The method employed + ! here is identical to the 'scaled linear packing' method in + ! that paper, except that the data are scaling into an arbitrary + ! range (2**nbits-1 not just 2**16-1) and are stored as + ! re-scaled floats instead of short integers. + ! The zlib algorithm does almost as + ! well packing the re-scaled floats as it does the scaled + ! integers, and this avoids the need for the client to apply the + ! rescaling (plus it allows the ability to adjust the packing + ! range). + scale_fact = (dataMax - dataMin) / (2**nbits-1) + offset = dataMin + if (scale_fact > 0.) then + allocate(array_save, source=array) + array = scale_fact*(nint((array_save - offset) / scale_fact)) + offset + ! compute max abs compression error + compress_err = maxval(abs(array_save-array)) + deallocate(array_save) + else + ! field is constant + compress_err = 0. end if - end subroutine nccheck - - elemental real function quantized(dataIn, nbits, dataMin, dataMax) - integer, intent(in) :: nbits - real(4), intent(in) :: dataIn, dataMin, dataMax - real(4) offset, scale_fact - ! convert data to 32 bit integers in range 0 to 2**nbits-1, then cast - ! cast back to 32 bit floats (data is then quantized in steps - ! proportional to 2**nbits so last 32-nbits in floating - ! point representation should be zero for efficient zlib compression). - scale_fact = (dataMax - dataMin) / (2**nbits-1); offset = dataMin - quantized = scale_fact*(nint((dataIn - offset) / scale_fact)) + offset - end function quantized + end subroutine quantize_array_3d + + subroutine quantize_array_4d(array, dataMin, dataMax, nbits, compress_err) + + real(4), dimension(:,:,:,:), intent(inout) :: array + real(4), intent(in) :: dataMin, dataMax + integer, intent(in) :: nbits + real(4), intent(out) :: compress_err + + real(4) :: scale_fact, offset + real(4), dimension(:,:,:,:), allocatable :: array_save + + ! Lossy compression if nbits>0. + ! The floating point data is quantized to improve compression + ! See doi:10.5194/gmd-10-413-2017. The method employed + ! here is identical to the 'scaled linear packing' method in + ! that paper, except that the data are scaling into an arbitrary + ! range (2**nbits-1 not just 2**16-1) and are stored as + ! re-scaled floats instead of short integers. + ! The zlib algorithm does almost as + ! well packing the re-scaled floats as it does the scaled + ! integers, and this avoids the need for the client to apply the + ! rescaling (plus it allows the ability to adjust the packing + ! range). + scale_fact = (dataMax - dataMin) / (2**nbits-1) + offset = dataMin + if (scale_fact > 0.) then + allocate(array_save, source=array) + array = scale_fact*(nint((array_save - offset) / scale_fact)) + offset + ! compute max abs compression error + compress_err = maxval(abs(array_save-array)) + deallocate(array_save) + else + ! field is constant + compress_err = 0. + end if + end subroutine quantize_array_4d +!---------------------------------------------------------------------------------------- end module module_write_netcdf diff --git a/io/module_write_netcdf_parallel.F90 b/io/module_write_netcdf_parallel.F90 deleted file mode 100644 index 0506d794a..000000000 --- a/io/module_write_netcdf_parallel.F90 +++ /dev/null @@ -1,627 +0,0 @@ -#define ESMF_ERR_RETURN(rc) if (ESMF_LogFoundError(rc, msg="Breaking out of subroutine", line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) - -#define NC_ERR_STOP(status) \ - if (status /= nf90_noerr) write(0,*) "line ", __LINE__, trim(nf90_strerror(status)); \ - if (status /= nf90_noerr) call ESMF_Finalize(endflag=ESMF_END_ABORT) - -module module_write_netcdf_parallel - - use esmf - use netcdf - use module_fv3_io_def,only : ideflate, nbits, & - output_grid,dx,dy,lon1,lat1,lon2,lat2 - use mpi - - implicit none - private - public write_netcdf_parallel - - contains - -#ifdef NO_PARALLEL_NETCDF -!---------------------------------------------------------------------------------------- - subroutine write_netcdf_parallel(fieldbundle, wrtfb, filename, mpi_comm, mype, im, jm, ichunk2d, jchunk2d, ichunk3d, jchunk3d, kchunk3d, rc) - type(ESMF_FieldBundle), intent(in) :: fieldbundle - type(ESMF_FieldBundle), intent(in) :: wrtfb - character(*), intent(in) :: filename - integer, intent(in) :: mpi_comm - integer, intent(in) :: mype - integer, intent(in) :: im, jm, ichunk2d, jchunk2d, & - ichunk3d, jchunk3d, kchunk3d - integer, optional,intent(out) :: rc - print *,'in stub write_netcdf_parallel - model not built with parallel netcdf support, return' - end subroutine write_netcdf_parallel -#else -!---------------------------------------------------------------------------------------- - subroutine write_netcdf_parallel(fieldbundle, wrtfb, filename, mpi_comm, mype, im, jm, ichunk2d, jchunk2d, ichunk3d, jchunk3d, kchunk3d, rc) -! - type(ESMF_FieldBundle), intent(in) :: fieldbundle - type(ESMF_FieldBundle), intent(in) :: wrtfb - character(*), intent(in) :: filename - integer, intent(in) :: mpi_comm - integer, intent(in) :: mype - integer, intent(in) :: im, jm, ichunk2d, jchunk2d, & - ichunk3d, jchunk3d, kchunk3d - integer, optional,intent(out) :: rc -! -!** local vars - integer :: i,j,m,n,k,istart,iend,jstart,jend,i1,i2,j1,j2,k1,k2 - integer :: lm - - integer, dimension(:), allocatable :: fldlev - real(ESMF_KIND_R4), dimension(:,:), pointer :: arrayr4 - real(ESMF_KIND_R8), dimension(:,:), pointer :: arrayr8 - real(ESMF_KIND_R4), dimension(:,:,:), pointer :: arrayr4_3d,arrayr4_3d_save - real(ESMF_KIND_R8), dimension(:,:,:), pointer :: arrayr8_3d - - real(8) x(im),y(jm) - integer :: fieldCount, fieldDimCount, gridDimCount - integer, dimension(:), allocatable :: ungriddedLBound, ungriddedUBound - - type(ESMF_Field), allocatable :: fcstField(:) - type(ESMF_TypeKind_Flag) :: typekind - type(ESMF_TypeKind_Flag) :: attTypeKind - type(ESMF_Grid) :: wrtgrid - type(ESMF_Array) :: array - - integer :: attcount - character(len=ESMF_MAXSTR) :: attName, fldName - integer :: totalLBound2d(2),totalUBound2d(2),totalLBound3d(3),totalUBound3d(3) - - integer :: varival - real(4) :: varr4val, scale_fact, offset, dataMin, dataMax - real(4), allocatable, dimension(:) :: compress_err - real(8) :: varr8val - character(len=ESMF_MAXSTR) :: varcval - - character(128) :: time_units - - integer :: ncerr,ierr - integer :: ncid - integer :: oldMode - integer :: im_dimid, jm_dimid, pfull_dimid, phalf_dimid, time_dimid - integer :: im_varid, jm_varid, lm_varid, time_varid, lon_varid, lat_varid - integer, dimension(:), allocatable :: varids - logical shuffle -! - call ESMF_FieldBundleGet(fieldbundle, fieldCount=fieldCount, rc=rc); ESMF_ERR_RETURN(rc) - - allocate(compress_err(fieldCount)); compress_err=-999. - allocate(fldlev(fieldCount)) ; fldlev = 0 - allocate(fcstField(fieldCount)) - allocate(varids(fieldCount)) - - call ESMF_FieldBundleGet(fieldbundle, fieldList=fcstField, grid=wrtGrid, & -! itemorderflag=ESMF_ITEMORDER_ADDORDER, & - rc=rc); ESMF_ERR_RETURN(rc) - - call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc); ESMF_ERR_RETURN(rc) - - do i=1,fieldCount - call ESMF_FieldGet(fcstField(i), dimCount=fieldDimCount, rc=rc); ESMF_ERR_RETURN(rc) - if (fieldDimCount > 3) then - write(0,*)"write_netcdf: Only 2D and 3D fields are supported!" - stop - end if - if (fieldDimCount > gridDimCount) then - allocate(ungriddedLBound(fieldDimCount-gridDimCount)) - allocate(ungriddedUBound(fieldDimCount-gridDimCount)) - call ESMF_FieldGet(fcstField(i), & - ungriddedLBound=ungriddedLBound, & - ungriddedUBound=ungriddedUBound, rc=rc); ESMF_ERR_RETURN(rc) - fldlev(i) = ungriddedUBound(fieldDimCount-gridDimCount) - & - ungriddedLBound(fieldDimCount-gridDimCount) + 1 - deallocate(ungriddedLBound) - deallocate(ungriddedUBound) - else if (fieldDimCount == 2) then - fldlev(i) = 1 - end if - end do - - lm = maxval(fldlev(:)) - -! create netcdf file for parallel access - - ncerr = nf90_create(trim(filename),& - cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL),& - comm=mpi_comm, info = MPI_INFO_NULL, ncid=ncid); NC_ERR_STOP(ncerr) -! disable auto filling. - ncerr = nf90_set_fill(ncid, NF90_NOFILL, oldMode); NC_ERR_STOP(ncerr) - - ! define dimensions - ncerr = nf90_def_dim(ncid, "grid_xt", im, im_dimid); NC_ERR_STOP(ncerr) - ncerr = nf90_def_dim(ncid, "grid_yt", jm, jm_dimid); NC_ERR_STOP(ncerr) - ! define coordinate variables - ncerr = nf90_def_var(ncid, "grid_xt", NF90_DOUBLE, im_dimid, im_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, im_varid, NF90_INDEPENDENT) - ncerr = nf90_def_var(ncid, "lon", NF90_DOUBLE, (/im_dimid,jm_dimid/), lon_varid); NC_ERR_STOP(ncerr) - !ncerr = nf90_var_par_access(ncid, lon_varid, NF90_INDEPENDENT) - ncerr = nf90_put_att(ncid, lon_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lon_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "cartesian_axis", "X"); NC_ERR_STOP(ncerr) - ncerr = nf90_def_var(ncid, "grid_yt", NF90_DOUBLE, jm_dimid, jm_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, jm_varid, NF90_INDEPENDENT) - ncerr = nf90_def_var(ncid, "lat", NF90_DOUBLE, (/im_dimid,jm_dimid/), lat_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, lat_varid, NF90_INDEPENDENT) - ncerr = nf90_put_att(ncid, lat_varid, "long_name", "T-cell latitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, lat_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "cartesian_axis", "Y"); NC_ERR_STOP(ncerr) - - if (lm > 1) then - call add_dim(ncid, "pfull", pfull_dimid, wrtgrid, rc) - call add_dim(ncid, "phalf", phalf_dimid, wrtgrid, rc) - end if - - call add_dim(ncid, "time", time_dimid, wrtgrid, rc) - - call get_global_attr(wrtfb, ncid, rc) - - do i=1, fieldCount - call ESMF_FieldGet(fcstField(i), name=fldName, typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) - - ! define variables - if (fldlev(i) == 1) then - if (typekind == ESMF_TYPEKIND_R4) then - if (ideflate > 0) then - if (ichunk2d < 0 .or. jchunk2d < 0) then - ! let netcdf lib choose chunksize - ! shuffle filter on for 2d fields (lossless compression) - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i), & - shuffle=.true.,deflate_level=ideflate); NC_ERR_STOP(ncerr) - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i), & - shuffle=.true.,deflate_level=ideflate,& - chunksizes=(/ichunk2d,jchunk2d,1/)); NC_ERR_STOP(ncerr) - endif - ! compression filters require collective access. - ncerr = nf90_var_par_access(ncid, varids(i), NF90_COLLECTIVE) - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, varids(i), NF90_INDEPENDENT) - endif - else if (typekind == ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & - (/im_dimid,jm_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, varids(i), NF90_INDEPENDENT) - else - write(0,*)'Unsupported typekind ', typekind - stop - end if - else if (fldlev(i) > 1) then - if (typekind == ESMF_TYPEKIND_R4) then - if (ideflate > 0) then - ! shuffle filter off for 3d fields using lossy compression - if (nbits > 0) then - shuffle=.false. - else - shuffle=.true. - endif - if (ichunk3d < 0 .or. jchunk3d < 0 .or. kchunk3d < 0) then - ! let netcdf lib choose chunksize - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i), & - shuffle=shuffle,deflate_level=ideflate); NC_ERR_STOP(ncerr) - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i), & - shuffle=shuffle,deflate_level=ideflate,& - chunksizes=(/ichunk3d,jchunk3d,kchunk3d,1/)); NC_ERR_STOP(ncerr) - endif - ! compression filters require collective access. - ncerr = nf90_var_par_access(ncid, varids(i), NF90_COLLECTIVE) - else - ncerr = nf90_def_var(ncid, trim(fldName), NF90_FLOAT, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, varids(i), NF90_INDEPENDENT) - endif - else if (typekind == ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, trim(fldName), NF90_DOUBLE, & - (/im_dimid,jm_dimid,pfull_dimid,time_dimid/), varids(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, varids(i), NF90_INDEPENDENT) - else - write(0,*)'Unsupported typekind ', typekind - stop - end if - end if - - ! define variable attributes - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & - rc=rc); ESMF_ERR_RETURN(rc) - - do j=1,attCount - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=j, & - name=attName, typekind=attTypeKind, itemCount=n, & - rc=rc); ESMF_ERR_RETURN(rc) - - if ( index(trim(attName),"ESMF") /= 0 ) then - cycle - endif - - if (attTypeKind==ESMF_TYPEKIND_I4) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, & - rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varival); NC_ERR_STOP(ncerr) - - else if (attTypeKind==ESMF_TYPEKIND_R4) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, & - rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr4val); NC_ERR_STOP(ncerr) - - else if (attTypeKind==ESMF_TYPEKIND_R8) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr8val, & - rc=rc); ESMF_ERR_RETURN(rc) - if (trim(attName) /= '_FillValue') then - ! FIXME: _FillValue must be cast to var type when using NF90_NETCDF4 - ncerr = nf90_put_att(ncid, varids(i), trim(attName), varr8val); NC_ERR_STOP(ncerr) - endif - - else if (attTypeKind==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varcval, & - rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varids(i), trim(attName), trim(varcval)); NC_ERR_STOP(ncerr) - - end if - - end do ! j=1,attCount - - end do ! i=1,fieldCount - - ! write grid_xt, grid_yt attributes - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "T-cell longitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "degrees_E"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "T-cell latiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees_N"); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "rotated T-cell longiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "degrees"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "rotated T-cell latiitude"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "degrees"); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then - ncerr = nf90_put_att(ncid, im_varid, "long_name", "x-coordinate of projection"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, im_varid, "units", "meters"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "long_name", "y-coordinate of projection"); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, jm_varid, "units", "meters"); NC_ERR_STOP(ncerr) - endif - - ncerr = nf90_enddef(ncid); NC_ERR_STOP(ncerr) - -! end of define mode - - ! write grid_xt, grid_yt values - call ESMF_GridGetCoord(wrtGrid, coordDim=1, farrayPtr=arrayr8, rc=rc); ESMF_ERR_RETURN(rc) - istart = lbound(arrayr8,1); iend = ubound(arrayr8,1) - jstart = lbound(arrayr8,2); jend = ubound(arrayr8,2) - !print *,'in write netcdf mpi dim 1',istart,iend,jstart,jend,shape(arrayr8),minval(arrayr8(:,jstart)),maxval(arrayr8(:,jstart)) - - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_var(ncid, im_varid, values=arrayr8(:,jstart),start=(/istart/), count=(/iend-istart+1/)); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then - do i=1,im - x(i) = lon1 + (lon2-lon1)/(im-1) * (i-1) - enddo - ncerr = nf90_put_var(ncid, im_varid, values=x ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then - do i=1,im - x(i) = dx * (i-1) - enddo - ncerr = nf90_put_var(ncid, im_varid, values=x ); NC_ERR_STOP(ncerr) - endif - ncerr = nf90_put_var(ncid, lon_varid, values=arrayr8, start=(/istart,jstart/)); NC_ERR_STOP(ncerr) - - call ESMF_GridGetCoord(wrtGrid, coordDim=2, farrayPtr=arrayr8, rc=rc); ESMF_ERR_RETURN(rc) - !print *,'in write netcdf mpi dim 2',istart,iend,jstart,jend,shape(arrayr8),minval(arrayr8(istart,:)),maxval(arrayr8(istart,:)) - if (trim(output_grid) == 'gaussian_grid' .or. & - trim(output_grid) == 'global_latlon' .or. & - trim(output_grid) == 'regional_latlon') then - ncerr = nf90_put_var(ncid, jm_varid, values=arrayr8(istart,:),start=(/jstart/),count=(/jend-jstart+1/)); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'rotated_latlon') then - do j=1,jm - y(j) = lat1 + (lat2-lat1)/(jm-1) * (j-1) - enddo - ncerr = nf90_put_var(ncid, jm_varid, values=y ); NC_ERR_STOP(ncerr) - else if (trim(output_grid) == 'lambert_conformal') then - do j=1,jm - y(j) = dy * (j-1) - enddo - ncerr = nf90_put_var(ncid, jm_varid, values=y ); NC_ERR_STOP(ncerr) - endif - ncerr = nf90_put_var(ncid, lat_varid, values=arrayr8, start=(/istart,jstart/)); NC_ERR_STOP(ncerr) - - do i=1, fieldCount - - call ESMF_FieldGet(fcstField(i),name=fldName,typekind=typekind, rc=rc); ESMF_ERR_RETURN(rc) - - if (fldlev(i) == 1) then - if (typekind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=arrayr4, totalLBound=totalLBound2d, totalUBound=totalUBound2d,rc=rc); ESMF_ERR_RETURN(rc) - !print *,'field name=',trim(fldName),'bound=',totalLBound2d,'ubound=',totalUBound2d - ncerr = nf90_put_var(ncid, varids(i), values=arrayr4, start=(/totalLBound2d(1),totalLBound2d(2),1/)); NC_ERR_STOP(ncerr) - else if (typekind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=arrayr8, totalLBound=totalLBound2d, totalUBound=totalUBound2d,rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_var(ncid, varids(i), values=arrayr8, start=(/totalLBound2d(1),totalLBound2d(2),1/)); NC_ERR_STOP(ncerr) - end if - else if (fldlev(i) > 1) then - if (typekind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=arrayr4_3d, totalLBound=totalLBound3d, totalUBound=totalUBound3d,rc=rc); ESMF_ERR_RETURN(rc) - if (ideflate > 0 .and. nbits > 0) then - i1=totalLBound3d(1);i2=totalUBound3d(1) - j1=totalLBound3d(2);j2=totalUBound3d(2) - k1=totalLBound3d(3);k2=totalUBound3d(3) - dataMax = maxval(arrayr4_3d(i1:i2,j1:j2,k1:k2)) - dataMin = minval(arrayr4_3d(i1:i2,j1:j2,k1:k2)) - call mpi_allreduce(mpi_in_place,dataMax,1,mpi_real4,mpi_max,mpi_comm,ierr) - call mpi_allreduce(mpi_in_place,dataMin,1,mpi_real4,mpi_min,mpi_comm,ierr) - ! Lossy compression if nbits>0. - ! The floating point data is quantized to improve compression - ! See doi:10.5194/gmd-10-413-2017. The method employed - ! here is identical to the 'scaled linear packing' method in - ! that paper, except that the data are scaling into an arbitrary - ! range (2**nbits-1 not just 2**16-1) and are stored as - ! re-scaled floats instead of short integers. - ! The zlib algorithm does almost as - ! well packing the re-scaled floats as it does the scaled - ! integers, and this avoids the need for the client to apply the - ! rescaling (plus it allows the ability to adjust the packing - ! range) - scale_fact = (dataMax - dataMin) / (2**nbits-1); offset = dataMin - if (scale_fact > 0.) then - allocate(arrayr4_3d_save(i1:i2,j1:j2,k1:k2)) - arrayr4_3d_save(i1:i2,j1:j2,k1:k2)=arrayr4_3d(i1:i2,j1:j2,k1:k2) - arrayr4_3d = scale_fact*(nint((arrayr4_3d_save - offset) / scale_fact)) + offset - ! compute max abs compression error. - compress_err(i) = & - maxval(abs(arrayr4_3d_save(i1:i2,j1:j2,k1:k2)-arrayr4_3d(i1:i2,j1:j2,k1:k2))) - deallocate(arrayr4_3d_save) - call mpi_allreduce(mpi_in_place,compress_err(i),1,mpi_real4,mpi_max,mpi_comm,ierr) - !print *,'field name=',trim(fldName),dataMin,dataMax,compress_err(i) - else - ! field is constant - compress_err(i) = 0. - endif - endif - ncerr = nf90_put_var(ncid, varids(i), values=arrayr4_3d, start=(/totalLBound3d(1),totalLBound3d(2),totalLBound3d(3),1/)); NC_ERR_STOP(ncerr) - else if (typekind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(fcstField(i), localDe=0, farrayPtr=arrayr8_3d, totalLBound=totalLBound3d, totalUBound=totalUBound3d,rc=rc); ESMF_ERR_RETURN(rc) - !print *,'field name=',trim(fldName),'bound=',totalLBound3d,'ubound=',totalUBound3d - ncerr = nf90_put_var(ncid, varids(i), values=arrayr8_3d, start=(/totalLBound3d(1),totalLBound3d(2),totalLBound3d(3),1/)); NC_ERR_STOP(ncerr) - end if - - end if !end fldlev(i) - - end do ! end fieldCount - - if (ideflate > 0 .and. nbits > 0) then - ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) - do i=1, fieldCount - if (compress_err(i) > 0) then - ncerr = nf90_put_att(ncid, varids(i), 'max_abs_compression_error', compress_err(i)); NC_ERR_STOP(ncerr) - ncerr = nf90_put_att(ncid, varids(i), 'nbits', nbits); NC_ERR_STOP(ncerr) - endif - enddo - ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - endif - - deallocate(fcstField) - deallocate(varids) - deallocate(compress_err) - - ncerr = nf90_close(ncid=ncid); NC_ERR_STOP(ncerr) - !call mpi_barrier(mpi_comm,ierr) - !print *,'netcdf parallel close, finished write_netcdf_parallel' - - end subroutine write_netcdf_parallel -#endif - -!---------------------------------------------------------------------------------------- - subroutine get_global_attr(fldbundle, ncid, rc) - type(ESMF_FieldBundle), intent(in) :: fldbundle - integer, intent(in) :: ncid - integer, intent(out) :: rc - -! local variable - integer :: i, attcount - integer :: ncerr - character(len=ESMF_MAXSTR) :: attName - type(ESMF_TypeKind_Flag) :: typekind - - integer :: varival - real(ESMF_KIND_R4) :: varr4val - real(ESMF_KIND_R4), dimension(:), allocatable :: varr4list - real(ESMF_KIND_R8) :: varr8val - real(ESMF_KIND_R8), dimension(:), allocatable :: varr8list - integer :: itemCount - character(len=ESMF_MAXSTR) :: varcval -! - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & - rc=rc); ESMF_ERR_RETURN(rc) - - do i=1,attCount - - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=itemCount, rc=rc); ESMF_ERR_RETURN(rc) - - if (typekind==ESMF_TYPEKIND_I4) then - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, NF90_GLOBAL, trim(attName), varival); NC_ERR_STOP(ncerr) - - else if (typekind==ESMF_TYPEKIND_R4) then - allocate (varr4list(itemCount)) - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=varr4list, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, NF90_GLOBAL, trim(attName), varr4list); NC_ERR_STOP(ncerr) - deallocate(varr4list) - - else if (typekind==ESMF_TYPEKIND_R8) then - allocate (varr8list(itemCount)) - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=varr8list, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, NF90_GLOBAL, trim(attName), varr8list); NC_ERR_STOP(ncerr) - deallocate(varr8list) - - else if (typekind==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varcval, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, NF90_GLOBAL, trim(attName), trim(varcval)); NC_ERR_STOP(ncerr) - - end if - - end do - - end subroutine get_global_attr -! -!---------------------------------------------------------------------------------------- - subroutine get_grid_attr(grid, prefix, ncid, varid, rc) - type(ESMF_Grid), intent(in) :: grid - character(len=*), intent(in) :: prefix - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(out) :: rc - -! local variable - integer :: i, attcount, n, ind - integer :: ncerr - character(len=ESMF_MAXSTR) :: attName - type(ESMF_TypeKind_Flag) :: typekind - - integer :: varival - real(ESMF_KIND_R4) :: varr4val - real(ESMF_KIND_R8) :: varr8val - character(len=ESMF_MAXSTR) :: varcval -! - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, & - rc=rc); ESMF_ERR_RETURN(rc) - - !write(0,*)'grid attcount = ', attcount - do i=1,attCount - - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc); ESMF_ERR_RETURN(rc) - !write(0,*)'grid att = ',i,trim(attName), ' itemCount = ' , n - - if (index(trim(attName), trim(prefix)//":")==1) then - ind = len(trim(prefix)//":") - - if (typekind==ESMF_TYPEKIND_I4) then - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varid, trim(attName(ind+1:len(attName))), varival); NC_ERR_STOP(ncerr) - - else if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varid, trim(attName(ind+1:len(attName))), varr4val); NC_ERR_STOP(ncerr) - - else if (typekind==ESMF_TYPEKIND_R8) then - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr8val, rc=rc); ESMF_ERR_RETURN(rc) - if (trim(attName) /= '_FillValue') then - ! FIXME: _FillValue must be cast to var type when using - ! NF90_NETCDF4. Until this is fixed, using netCDF default _FillValue. - ncerr = nf90_put_att(ncid, varid, trim(attName(ind+1:len(attName))), varr8val); NC_ERR_STOP(ncerr) - endif - - else if (typekind==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varcval, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_put_att(ncid, varid, trim(attName(ind+1:len(attName))), trim(varcval)); NC_ERR_STOP(ncerr) - - end if - - end if - - end do - - end subroutine get_grid_attr - - subroutine add_dim(ncid, dim_name, dimid, grid, rc) - integer, intent(in) :: ncid - character(len=*), intent(in) :: dim_name - integer, intent(inout) :: dimid - type(ESMF_Grid), intent(in) :: grid - integer, intent(out) :: rc - -! local variable - integer :: i, attcount, n, dim_varid - integer :: ncerr - character(len=ESMF_MAXSTR) :: attName - type(ESMF_TypeKind_Flag) :: typekind - - integer, allocatable :: valueListI(:) - real(ESMF_KIND_R4), allocatable :: valueListR4(:) - real(ESMF_KIND_R8), allocatable :: valueListR8(:) - character(len=ESMF_MAXSTR), allocatable :: valueListC(:) -! - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, name=dim_name, & - typekind=typekind, itemCount=n, rc=rc); ESMF_ERR_RETURN(rc) - - if ( trim(dim_name) == "time" ) then - ! using an unlimited dim requires collective mode (NF90_COLLECTIVE) - ! for parallel writes, which seems to slow things down on hera. - !ncerr = nf90_def_dim(ncid, trim(dim_name), NF90_UNLIMITED, dimid); NC_ERR_STOP(ncerr) - ncerr = nf90_def_dim(ncid, trim(dim_name), 1, dimid); NC_ERR_STOP(ncerr) - else - ncerr = nf90_def_dim(ncid, trim(dim_name), n, dimid); NC_ERR_STOP(ncerr) - end if - - if (typekind==ESMF_TYPEKIND_R8) then - ncerr = nf90_def_var(ncid, dim_name, NF90_REAL8, dimids=(/dimid/), varid=dim_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, dim_varid, NF90_INDEPENDENT) - allocate(valueListR8(n)) - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(dim_name), valueList=valueListR8, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_var(ncid, dim_varid, values=valueListR8 ); NC_ERR_STOP(ncerr) - ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) - deallocate(valueListR8) - else if (typekind==ESMF_TYPEKIND_R4) then - ncerr = nf90_def_var(ncid, dim_name, NF90_REAL4, dimids=(/dimid/), varid=dim_varid); NC_ERR_STOP(ncerr) - ncerr = nf90_var_par_access(ncid, dim_varid, NF90_INDEPENDENT) - allocate(valueListR4(n)) - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(dim_name), valueList=valueListR4, rc=rc); ESMF_ERR_RETURN(rc) - ncerr = nf90_enddef(ncid=ncid); NC_ERR_STOP(ncerr) - ncerr = nf90_put_var(ncid, dim_varid, values=valueListR4 ); NC_ERR_STOP(ncerr) - ncerr = nf90_redef(ncid=ncid); NC_ERR_STOP(ncerr) - deallocate(valueListR4) - else - write(0,*)'Error in module_write_netcdf.F90(add_dim) unknown typekind for ',trim(dim_name) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - end if - - call get_grid_attr(grid, dim_name, ncid, dim_varid, rc) - - end subroutine add_dim -! -!---------------------------------------------------------------------------------------- - subroutine nccheck(status) - use netcdf - implicit none - integer, intent (in) :: status - - if (status /= nf90_noerr) then - write(0,*) status, trim(nf90_strerror(status)) - stop "stopped" - end if - end subroutine nccheck - -end module module_write_netcdf_parallel diff --git a/io/module_wrt_grid_comp.F90 b/io/module_wrt_grid_comp.F90 index 70257b8d6..0bbf2a221 100644 --- a/io/module_wrt_grid_comp.F90 +++ b/io/module_wrt_grid_comp.F90 @@ -31,7 +31,7 @@ module module_wrt_grid_comp use write_internal_state use module_fv3_io_def, only : num_pes_fcst, & - n_group, num_files, app_domain, & + n_group, num_files, & filename_base, output_grid, output_file, & imo,jmo,ichunk2d,jchunk2d, & ichunk3d,jchunk3d,kchunk3d,nbits, & @@ -43,7 +43,6 @@ module module_wrt_grid_comp use module_write_netcdf, only : write_netcdf use physcons, only : pi => con_pi use inline_post, only : inline_post_run, inline_post_getattr - use module_write_netcdf_parallel, only : write_netcdf_parallel ! !----------------------------------------------------------------------- ! @@ -55,31 +54,22 @@ module module_wrt_grid_comp ! !----------------------------------------------------------------------- ! - real, parameter :: rdgas=287.04, grav=9.80 - real, parameter :: stndrd_atmos_ps = 101325. - real, parameter :: stndrd_atmos_lapse = 0.0065 ! integer,save :: lead_write_task !<-- Rank of the first write task in the write group integer,save :: last_write_task !<-- Rank of the last write task in the write group integer,save :: ntasks !<-- # of write tasks in the current group + integer,save :: itasks, jtasks !<-- # of write tasks in i/j direction in the current group - integer,save :: mytile !<-- the tile number in write task integer,save :: wrt_mpi_comm !<-- the mpi communicator in the write comp integer,save :: idate(7) logical,save :: write_nsflip - logical,save :: first_init=.false. - logical,save :: first_run=.false. - logical,save :: first_getlatlon=.true. - logical,save :: first_getmaskwrt=.true. !<-- for mask the output grid of the write comp logical,save :: change_wrtidate=.false. ! !----------------------------------------------------------------------- ! - type(wrt_internal_state),pointer :: wrt_int_state ! The internal state pointer. type(ESMF_FieldBundle) :: gridFB integer :: FBcount character(len=esmf_maxstr),allocatable :: fcstItemNameList(:) - real(ESMF_KIND_R4), dimension(:,:), allocatable :: maskwrt ! !----------------------------------------------------------------------- REAL(KIND=8) :: btim,btim0 @@ -113,15 +103,15 @@ subroutine SetServices(wrt_comp, rc) call ESMF_GridCompSetEntryPoint(wrt_comp, ESMF_METHOD_INITIALIZE, & userRoutine=wrt_initialize, rc=rc) - if(rc/=0) write(*,*)'Error: write grid comp, initial' -! + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridCompSetEntryPoint(wrt_comp, ESMF_METHOD_RUN, & userRoutine=wrt_run, rc=rc) - if(rc/=0) write(*,*)'Error: write grid comp, run' -! + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridCompSetEntryPoint(wrt_comp, ESMF_METHOD_FINALIZE, & userRoutine=wrt_finalize, rc=rc) - if(rc/=0) write(*,*)'Error: write grid comp, run' + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return end subroutine SetServices ! @@ -146,21 +136,20 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) type(write_wrap) :: WRAP type(wrt_internal_state),pointer :: wrt_int_state - integer :: ISTAT, tl, i, j, n, k + integer :: tl, i, j, n, k integer,dimension(2,6) :: decomptile integer,dimension(2) :: regDecomp !define delayout for the nest grid integer :: fieldCount integer :: vm_mpi_comm - character(40) :: fieldName, axesname,longname - type(ESMF_Config) :: cf + character(40) :: fieldName + type(ESMF_Config) :: cf, cf_output_grid type(ESMF_DELayout) :: delayout - type(ESMF_Grid) :: wrtGrid, fcstGrid + type(ESMF_Grid) :: fcstGrid + type(ESMF_Grid), allocatable :: wrtGrid(:) type(ESMF_Array) :: array - type(ESMF_FieldBundle) :: fieldbdl_work type(ESMF_Field) :: field_work, field type(ESMF_Decomp_Flag) :: decompflagPTile(2,6) - character(len=80) :: attrValueSList(2) type(ESMF_StateItem_Flag), allocatable :: fcstItemTypeList(:) type(ESMF_FieldBundle) :: fcstFB, fieldbundle type(ESMF_Field), allocatable :: fcstField(:) @@ -179,7 +168,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) real(ESMF_KIND_R4) :: valueR4 real(ESMF_KIND_R8) :: valueR8 - integer :: attCount, axeslen, jidx, idx, noutfile + integer :: attCount, jidx, idx, noutfile character(19) :: newdate character(128) :: FBlist_outfilename(100), outfile_name character(128),dimension(:,:), allocatable :: outfilename @@ -189,19 +178,17 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) real(ESMF_KIND_R8) :: rot_lon, rot_lat real(ESMF_KIND_R8) :: geo_lon, geo_lat real(ESMF_KIND_R8) :: lon1_r8, lat1_r8 - real(ESMF_KIND_R8) :: x1, y1, x, y, delat + real(ESMF_KIND_R8) :: x1, y1, x, y, delat, delon type(ESMF_TimeInterval) :: IAU_offsetTI - type(ESMF_DataCopy_Flag) :: copyflag=ESMF_DATACOPY_REFERENCE -! real(8),parameter :: PI=3.14159265358979d0 + character(256) :: cf_open, cf_close character(256) :: gridfile integer :: num_output_file - ! - logical,save :: first=.true. logical :: lprnt -!test - real(ESMF_KIND_R8),dimension(:,:), pointer :: glatPtr, glonPtr + + integer :: ngrids, grid_id + logical :: top_parent_is_global ! !----------------------------------------------------------------------- !*********************************************************************** @@ -243,6 +230,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! lead_write_task,'last_write_task=',last_write_task, & ! 'mype=',wrt_int_state%mype,'jidx=',jidx,' comm=',wrt_mpi_comm ! + !----------------------------------------------------------------------- !*** get configuration variables !----------------------------------------------------------------------- @@ -265,115 +253,206 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return + if( wrt_int_state%write_dopost ) then +#ifdef NO_INLINE_POST + rc = ESMF_RC_NOT_IMPL + print *,'inline post not available on this machine' + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return +#endif + call esmf_configgetattribute(cf,wrt_int_state%post_nlunit,default=777,label='nlunit:',rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + call ESMF_ConfigGetAttribute(config=CF,value=wrt_int_state%post_namelist,default='itag', & + label ='post_namelist:',rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + endif - ! chunksizes for netcdf_parallel - call ESMF_ConfigGetAttribute(config=CF,value=ichunk2d,default=0,label ='ichunk2d:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF,value=jchunk2d,default=0,label ='jchunk2d:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF,value=ichunk3d,default=0,label ='ichunk3d:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF,value=jchunk3d,default=0,label ='jchunk3d:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF,value=kchunk3d,default=0,label ='kchunk3d:',rc=rc) - - ! zlib compression flag - call ESMF_ConfigGetAttribute(config=CF,value=ideflate,default=0,label ='ideflate:',rc=rc) - if (ideflate < 0) ideflate=0 - - call ESMF_ConfigGetAttribute(config=CF,value=nbits,default=0,label ='nbits:',rc=rc) - ! nbits quantization level for lossy compression (must be between 1 and 31) - ! 1 is most compression, 31 is least. If outside this range, set to zero - ! which means use lossless compression. - if (nbits < 1 .or. nbits > 31) nbits=0 ! lossless compression (no quantization) -! variables for I/O options - call ESMF_ConfigGetAttribute(config=CF,value=app_domain, default="global", & - label ='app_domain:',rc=rc) + allocate(output_file(num_files)) + num_output_file = ESMF_ConfigGetLen(config=CF, label ='output_file:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (num_files == num_output_file) then + call ESMF_ConfigGetAttribute(CF,valueList=output_file,label='output_file:', & + count=num_files, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + do i = 1, num_files + if(output_file(i) /= "netcdf" .and. output_file(i) /= "netcdf_parallel") then + write(0,*)"Only netcdf and netcdf_parallel are allowed for multiple values of output_file" + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + else if ( num_output_file == 1) then + call ESMF_ConfigGetAttribute(CF,valuelist=output_file,label='output_file:', count=1, rc=rc) + output_file(1:num_files) = output_file(1) + else + output_file(1:num_files) = 'netcdf' + endif + if(lprnt) then + print *,'num_files=',num_files + do i=1,num_files + print *,'num_file=',i,'filename_base= ',trim(filename_base(i)),' output_file= ',trim(output_file(i)) + enddo + endif + + call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & + name="ngrids", value=ngrids, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & + name="top_parent_is_global", value=top_parent_is_global, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + allocate(wrtGrid(ngrids)) + + allocate(output_grid(ngrids)) + + allocate(imo(ngrids)) + allocate(jmo(ngrids)) + + allocate(cen_lon(ngrids)) + allocate(cen_lat(ngrids)) + allocate(lon1(ngrids)) + allocate(lat1(ngrids)) + allocate(lon2(ngrids)) + allocate(lat2(ngrids)) + allocate(dlon(ngrids)) + allocate(dlat(ngrids)) + + allocate(stdlat1(ngrids)) + allocate(stdlat2(ngrids)) + allocate(dx(ngrids)) + allocate(dy(ngrids)) + + allocate(ichunk2d(ngrids)) + allocate(jchunk2d(ngrids)) + allocate(ichunk3d(ngrids)) + allocate(jchunk3d(ngrids)) + allocate(kchunk3d(ngrids)) + allocate(ideflate(ngrids)) + allocate(nbits(ngrids)) + + do n=1, ngrids - call ESMF_ConfigGetAttribute(config=CF, value=output_grid, label ='output_grid:',rc=rc) + if (n == 1) then + ! for top level domain look directly in cf + cf_output_grid = cf + else + ! for nest domains, look under specific section + write(cf_open,'("")') n + write(cf_close,'("")') n + cf_output_grid = ESMF_ConfigCreate(cf, openLabel=trim(cf_open), closeLabel=trim(cf_close), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + end if + + if (allocated(wrt_int_state%lat_start_wrtgrp)) deallocate (wrt_int_state%lat_start_wrtgrp) + if (allocated(wrt_int_state%lat_end_wrtgrp )) deallocate (wrt_int_state%lat_end_wrtgrp ) + if (allocated(wrt_int_state%lon_start_wrtgrp)) deallocate (wrt_int_state%lon_start_wrtgrp) + if (allocated(wrt_int_state%lon_end_wrtgrp )) deallocate (wrt_int_state%lon_end_wrtgrp ) + if (allocated(wrt_int_state%latPtr) ) deallocate (wrt_int_state%latPtr) + if (allocated(wrt_int_state%lonPtr) ) deallocate (wrt_int_state%lonPtr) + + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=output_grid(n), label ='output_grid:',rc=rc) if (lprnt) then - print *,'output_grid=',trim(output_grid) + print *,'grid_id= ', n, ' output_grid= ', trim(output_grid(n)) end if - if(trim(output_grid) == 'gaussian_grid' .or. trim(output_grid) == 'global_latlon') then - call ESMF_ConfigGetAttribute(config=CF, value=imo, label ='imo:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=jmo, label ='jmo:',rc=rc) + call ESMF_ConfigGetAttribute(config=CF, value=itasks,default=1,label ='itasks:',rc=rc) + jtasks = ntasks + if(itasks > 0 ) jtasks = ntasks/itasks + if( itasks*jtasks /= ntasks ) then + itasks = 1 + jtasks = ntasks + endif + + if(trim(output_grid(n)) == 'gaussian_grid' .or. trim(output_grid(n)) == 'global_latlon') then + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=imo(n), label ='imo:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=jmo(n), label ='jmo:',rc=rc) if (lprnt) then - print *,'imo=',imo,'jmo=',jmo + print *,'imo=',imo(n),'jmo=',jmo(n) end if - else if(trim(output_grid) == 'regional_latlon') then - call ESMF_ConfigGetAttribute(config=CF, value=lon1, label ='lon1:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lat1, label ='lat1:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lon2, label ='lon2:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lat2, label ='lat2:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dlon, label ='dlon:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dlat, label ='dlat:',rc=rc) - imo = (lon2-lon1)/dlon + 1 - jmo = (lat2-lat1)/dlat + 1 + else if(trim(output_grid(n)) == 'regional_latlon') then + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lon1(n), label ='lon1:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lat1(n), label ='lat1:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lon2(n), label ='lon2:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lat2(n), label ='lat2:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dlon(n), label ='dlon:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dlat(n), label ='dlat:',rc=rc) + imo(n) = (lon2(n)-lon1(n))/dlon(n) + 1 + jmo(n) = (lat2(n)-lat1(n))/dlat(n) + 1 if (lprnt) then - print *,'lon1=',lon1,' lat1=',lat1 - print *,'lon2=',lon2,' lat2=',lat2 - print *,'dlon=',dlon,' dlat=',dlat - print *,'imo =',imo, ' jmo=',jmo + print *,'lon1=',lon1(n),' lat1=',lat1(n) + print *,'lon2=',lon2(n),' lat2=',lat2(n) + print *,'dlon=',dlon(n),' dlat=',dlat(n) + print *,'imo =',imo(n), ' jmo =',jmo(n) end if - else if (trim(output_grid) == 'rotated_latlon') then - call ESMF_ConfigGetAttribute(config=CF, value=cen_lon, label ='cen_lon:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=cen_lat, label ='cen_lat:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lon1, label ='lon1:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lat1, label ='lat1:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lon2, label ='lon2:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lat2, label ='lat2:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dlon, label ='dlon:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dlat, label ='dlat:', rc=rc) - imo = (lon2-lon1)/dlon + 1 - jmo = (lat2-lat1)/dlat + 1 + else if (trim(output_grid(n)) == 'rotated_latlon') then + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=cen_lon(n), label ='cen_lon:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=cen_lat(n), label ='cen_lat:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lon1(n), label ='lon1:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lat1(n), label ='lat1:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lon2(n), label ='lon2:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lat2(n), label ='lat2:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dlon(n), label ='dlon:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dlat(n), label ='dlat:', rc=rc) + imo(n) = (lon2(n)-lon1(n))/dlon(n) + 1 + jmo(n) = (lat2(n)-lat1(n))/dlat(n) + 1 if (lprnt) then - print *,'lon1=',lon1,' lat1=',lat1 - print *,'lon2=',lon2,' lat2=',lat2 - print *,'dlon=',dlon,' dlat=',dlat - print *,'imo =',imo, ' jmo=',jmo + print *,'lon1=',lon1(n),' lat1=',lat1(n) + print *,'lon2=',lon2(n),' lat2=',lat2(n) + print *,'dlon=',dlon(n),' dlat=',dlat(n) + print *,'imo =',imo(n), ' jmo =',jmo(n) end if - else if (trim(output_grid) == 'lambert_conformal') then - call ESMF_ConfigGetAttribute(config=CF, value=cen_lon, label ='cen_lon:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=cen_lat, label ='cen_lat:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=stdlat1, label ='stdlat1:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=stdlat2, label ='stdlat2:',rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=imo, label ='nx:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=jmo, label ='ny:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lon1, label ='lon1:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=lat1, label ='lat1:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dx, label ='dx:', rc=rc) - call ESMF_ConfigGetAttribute(config=CF, value=dy, label ='dy:', rc=rc) + else if (trim(output_grid(n)) == 'lambert_conformal') then + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=cen_lon(n), label ='cen_lon:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=cen_lat(n), label ='cen_lat:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=stdlat1(n), label ='stdlat1:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=stdlat2(n), label ='stdlat2:',rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=imo(n), label ='nx:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=jmo(n), label ='ny:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lon1(n), label ='lon1:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=lat1(n), label ='lat1:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dx(n), label ='dx:', rc=rc) + call ESMF_ConfigGetAttribute(config=cf_output_grid, value=dy(n), label ='dy:', rc=rc) if (lprnt) then - print *,'cen_lon=',cen_lon,' cen_lat=',cen_lat - print *,'stdlat1=',stdlat1,' stdlat2=',stdlat2 - print *,'lon1=',lon1,' lat1=',lat1 - print *,'nx=',imo, ' ny=',jmo - print *,'dx=',dx,' dy=',dy + print *,'cen_lon=',cen_lon(n),' cen_lat=',cen_lat(n) + print *,'stdlat1=',stdlat1(n),' stdlat2=',stdlat2(n) + print *,'lon1=',lon1(n),' lat1=',lat1(n) + print *,'nx=',imo(n), ' ny=',jmo(n) + print *,'dx=',dx(n),' dy=',dy(n) endif endif ! output_grid - if( wrt_int_state%write_dopost ) then -#ifdef NO_INLINE_POST - rc = ESMF_RC_NOT_IMPL - print *,'inline post not available on this machine' - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return -#endif - call esmf_configgetattribute(cf,wrt_int_state%post_nlunit,default=777,label='nlunit:',rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return - call ESMF_ConfigGetAttribute(config=CF,value=wrt_int_state%post_namelist,default='itag', & - label ='post_namelist:',rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + + ! chunksizes for netcdf_parallel + call ESMF_ConfigGetAttribute(config=CF,value=ichunk2d(n),default=0,label ='ichunk2d:',rc=rc) + call ESMF_ConfigGetAttribute(config=CF,value=jchunk2d(n),default=0,label ='jchunk2d:',rc=rc) + call ESMF_ConfigGetAttribute(config=CF,value=ichunk3d(n),default=0,label ='ichunk3d:',rc=rc) + call ESMF_ConfigGetAttribute(config=CF,value=jchunk3d(n),default=0,label ='jchunk3d:',rc=rc) + call ESMF_ConfigGetAttribute(config=CF,value=kchunk3d(n),default=0,label ='kchunk3d:',rc=rc) + + ! zlib compression flag + call ESMF_ConfigGetAttribute(config=CF,value=ideflate(n),default=0,label ='ideflate:',rc=rc) + if (ideflate(n) < 0) ideflate(n)=0 + + call ESMF_ConfigGetAttribute(config=CF,value=nbits(n),default=0,label ='nbits:',rc=rc) + if (lprnt) then + print *,'ideflate=',ideflate(n),' nbits=',nbits(n) + end if + ! nbits quantization level for lossy compression (must be between 1 and 31) + ! 1 is most compression, 31 is least. If outside this range, set to zero + ! which means use lossless compression. + if (nbits(n) < 1 .or. nbits(n) > 31) nbits(n)=0 ! lossless compression (no quantization) + + if (cf_output_grid /= cf) then + ! destroy the temporary config object created for nest domains + call ESMF_ConfigDestroy(config=cf_output_grid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif -! -!----------------------------------------------------------------------- -!*** Create the cubed sphere grid with field on PETs -!*** first try: Create cubed sphere grid from file -!----------------------------------------------------------------------- -! - if ( trim(output_grid) == 'cubed_sphere_grid' ) then - mytile = mod(wrt_int_state%mype,ntasks)+1 - if ( trim(app_domain) == 'global' ) then + if ( trim(output_grid(n)) == 'cubed_sphere_grid' ) then + !*** Create cubed sphere grid from file + if (top_parent_is_global .and. n==1) then + gridfile = 'grid_spec.nc' ! global top-level parent do tl=1,6 decomptile(1,tl) = 1 decomptile(2,tl) = jidx @@ -383,19 +462,23 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) name="gridfile", value=gridfile, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - CALL ESMF_LogWrite("wrtComp: gridfile:"//trim(gridfile),ESMF_LOGMSG_INFO,rc=rc) - wrtgrid = ESMF_GridCreateMosaic(filename="INPUT/"//trim(gridfile), & + call ESMF_LogWrite("wrtComp: gridfile:"//trim(gridfile),ESMF_LOGMSG_INFO,rc=rc) + wrtGrid(n) = ESMF_GridCreateMosaic(filename="INPUT/"//trim(gridfile), & regDecompPTile=decomptile,tileFilePath="INPUT/", & decompflagPTile=decompflagPTile, & staggerlocList=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), & name='wrt_grid', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return else - if(trim(app_domain) == 'nested') then - gridfile='grid.nest02.tile7.nc' - else if(trim(app_domain) == 'regional') then - gridfile='grid.tile7.halo0.nc' - endif + if (top_parent_is_global) then + write(gridfile,'(A,I2.2,A,I1,A)') 'grid.nest', n, '.tile', n+5, '.nc' + else + if (n == 1) then + gridfile='grid.tile7.halo0.nc' ! regional top-level parent + else + write(gridfile,'(A,I2.2,A,I1,A)') 'grid.nest', n, '.tile', n, '.nc' + endif + end if regDecomp(1) = 1 regDecomp(2) = ntasks allocate(petMap(ntasks)) @@ -406,62 +489,63 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! create the nest Grid by reading it from file but use DELayout - wrtGrid = ESMF_GridCreate(filename="INPUT/"//trim(gridfile), & + call ESMF_LogWrite("wrtComp: gridfile:"//trim(gridfile),ESMF_LOGMSG_INFO,rc=rc) + wrtGrid(n) = ESMF_GridCreate(filename="INPUT/"//trim(gridfile), & fileformat=ESMF_FILEFORMAT_GRIDSPEC, regDecomp=regDecomp, & decompflag=(/ESMF_DECOMP_SYMMEDGEMAX,ESMF_DECOMP_SYMMEDGEMAX/), & delayout=delayout, isSphere=.false., indexflag=ESMF_INDEX_DELOCAL, & rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - print *,'in nested/regional cubed_sphere grid, regDecomp=',regDecomp,' PetMap=',petMap(1),petMap(ntasks), & + if (lprnt) print *,'in nested/regional cubed_sphere grid, regDecomp=',regDecomp,' PetMap=',petMap(1),petMap(ntasks), & 'gridfile=',trim(gridfile) deallocate(petMap) endif - else if ( trim(output_grid) == 'gaussian_grid') then + else if ( trim(output_grid(n)) == 'gaussian_grid') then - wrtgrid = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & - maxIndex=(/imo,jmo/), regDecomp=(/1,ntasks/), & - indexflag=ESMF_INDEX_GLOBAL, & - name='wrt_grid',rc=rc) -! indexflag=ESMF_INDEX_GLOBAL, coordSys=ESMF_COORDSYS_SPH_DEG + wrtGrid(n) = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & + maxIndex=(/imo(n),jmo(n)/), regDecomp=(/itasks,jtasks/), & + indexflag=ESMF_INDEX_GLOBAL, & + name='wrt_grid',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridAddCoord(wrtgrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + call ESMF_GridAddCoord(wrtGrid(n), staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=1, farrayPtr=lonPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=1, farrayPtr=lonPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=2, farrayPtr=latPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=2, farrayPtr=latPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! - allocate(slat(jmo), lat(jmo), lon(imo)) - call splat(4, jmo, slat) + allocate(slat(jmo(n)), lat(jmo(n)), lon(imo(n))) + call splat(4, jmo(n), slat) if(write_nsflip) then - do j=1,jmo + do j=1,jmo(n) lat(j) = asin(slat(j)) * radi enddo else - do j=1,jmo - lat(jmo-j+1) = asin(slat(j)) * radi + do j=1,jmo(n) + lat(jmo(n)-j+1) = asin(slat(j)) * radi enddo endif wrt_int_state%latstart = lat(1) - wrt_int_state%latlast = lat(jmo) - do j=1,imo - lon(j) = 360.d0/real(imo,8) *real(j-1,8) + wrt_int_state%latlast = lat(jmo(n)) + do j=1,imo(n) + lon(j) = 360.d0/real(imo(n),8) *real(j-1,8) enddo wrt_int_state%lonstart = lon(1) - wrt_int_state%lonlast = lon(imo) + wrt_int_state%lonlast = lon(imo(n)) do j=lbound(latPtr,2),ubound(latPtr,2) do i=lbound(lonPtr,1),ubound(lonPtr,1) - lonPtr(i,j) = 360.d0/real(imo,8) * real(i-1,8) + lonPtr(i,j) = 360.d0/real(imo(n),8) * real(i-1,8) latPtr(i,j) = lat(j) enddo enddo -! print *,'aft wrtgrd, Gaussian, dimi,i=',lbound(lonPtr,1),ubound(lonPtr,1), & -! ' j=',lbound(lonPtr,2),ubound(lonPtr,2),'imo=',imo,'jmo=',jmo + if(lprnt) print *,'aft wrtgrd, Gaussian, dimi,i=',lbound(lonPtr,1),ubound(lonPtr,1), & + lbound(lonPtr,2),ubound(lonPtr,2),'j(i)=',lbound(latPtr,1),ubound(latPtr,1),& + ' j(j)=',lbound(latPtr,2),ubound(latPtr,2),'imo=',imo,'jmo=',jmo ! if(wrt_int_state%mype==0) print *,'aft wrtgrd, lon=',lonPtr(1:5,1), & ! 'lat=',latPtr(1,1:5),'imo,jmo=',imo,jmo ! lonPtr(lbound(lonPtr,1),ubound(lonPtr,2)),'lat=',latPtr(lbound(lonPtr,1),lbound(lonPtr,2)), & @@ -472,12 +556,20 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%lon_end = ubound(lonPtr,1) allocate( wrt_int_state%lat_start_wrtgrp(wrt_int_state%petcount)) allocate( wrt_int_state%lat_end_wrtgrp (wrt_int_state%petcount)) + allocate( wrt_int_state%lon_start_wrtgrp(wrt_int_state%petcount)) + allocate( wrt_int_state%lon_end_wrtgrp (wrt_int_state%petcount)) call mpi_allgather(wrt_int_state%lat_start,1,MPI_INTEGER, & wrt_int_state%lat_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) call mpi_allgather(wrt_int_state%lat_end, 1,MPI_INTEGER, & wrt_int_state%lat_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_start,1,MPI_INTEGER, & + wrt_int_state%lon_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_end, 1,MPI_INTEGER, & + wrt_int_state%lon_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) if( lprnt ) print *,'aft wrtgrd, Gaussian, dimj_start=',wrt_int_state%lat_start_wrtgrp, & - 'dimj_end=',wrt_int_state%lat_end_wrtgrp, 'wrt_group=',n_group + 'dimj_end=',wrt_int_state%lat_end_wrtgrp, 'wrt_group=',n_group, & + 'lon_start,end=',wrt_int_state%lon_start,wrt_int_state%lon_end, & + 'lat_start,end=',wrt_int_state%lat_start, wrt_int_state%lat_end allocate( wrt_int_state%latPtr(wrt_int_state%lon_start:wrt_int_state%lon_end, & wrt_int_state%lat_start:wrt_int_state%lat_end)) allocate( wrt_int_state%lonPtr(wrt_int_state%lon_start:wrt_int_state%lon_end, & @@ -488,60 +580,63 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%lonPtr(i,j) = lonPtr(i,j) enddo enddo - wrt_int_state%im = imo - wrt_int_state%jm = jmo + wrt_int_state%im = imo(n) + wrt_int_state%jm = jmo(n) wrt_int_state%post_maptype = 4 - deallocate(slat) - else if ( trim(output_grid) == 'global_latlon') then - wrtgrid = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & - maxIndex=(/imo,jmo/), regDecomp=(/1,ntasks/), & - indexflag=ESMF_INDEX_GLOBAL, name='wrt_grid',rc=rc) + deallocate(slat, lat, lon) + + else if ( trim(output_grid(n)) == 'global_latlon') then + wrtGrid(n) = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & + maxIndex=(/imo(n),jmo(n)/), regDecomp=(/itasks,jtasks/), & + indexflag=ESMF_INDEX_GLOBAL, & + name='wrt_grid',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridAddCoord(wrtgrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + call ESMF_GridAddCoord(wrtGrid(n), staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=1, farrayPtr=lonPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=1, farrayPtr=lonPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=2, farrayPtr=latPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=2, farrayPtr=latPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! - allocate(lat(jmo), lon(imo)) - if (mod(jmo,2) == 0) then + allocate(lat(jmo(n)), lon(imo(n))) + if (mod(jmo(n),2) == 0) then ! if jmo even, lats do not include poles and equator - delat = 180.d0/real(jmo,8) + delat = 180.d0/real(jmo(n),8) if(write_nsflip) then - do j=1,jmo + do j=1,jmo(n) lat(j) = 90.d0 - 0.5*delat - real(j-1,8)*delat enddo else - do j=1,jmo + do j=1,jmo(n) lat(j) = -90.d0 + 0.5*delat + real(j-1,8)*delat enddo endif else ! if jmo odd, lats include poles and equator - delat = 180.d0/real(jmo-1,8) + delat = 180.d0/real(jmo(n)-1,8) if(write_nsflip) then - do j=1,jmo + do j=1,jmo(n) lat(j) = 90.d0 - real(j-1,8)*delat enddo else - do j=1,jmo + do j=1,jmo(n) lat(j) = -90.d0 + real(j-1,8)*delat enddo endif endif wrt_int_state%latstart = lat(1) - wrt_int_state%latlast = lat(jmo) - do i=1,imo - lon(i) = 360.d0/real(imo,8) *real(i-1,8) + wrt_int_state%latlast = lat(jmo(n)) + delon = 360.d0/real(imo(n),8) + do i=1,imo(n) + lon(i) = real(i-1,8)*delon enddo wrt_int_state%lonstart = lon(1) - wrt_int_state%lonlast = lon(imo) + wrt_int_state%lonlast = lon(imo(n)) do j=lbound(latPtr,2),ubound(latPtr,2) do i=lbound(lonPtr,1),ubound(lonPtr,1) lonPtr(i,j) = lon(i) @@ -552,12 +647,24 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%lat_end = ubound(latPtr,2) wrt_int_state%lon_start = lbound(lonPtr,1) wrt_int_state%lon_end = ubound(lonPtr,1) + lon1(n) = wrt_int_state%lonstart + lon2(n) = wrt_int_state%lonlast + lat1(n) = wrt_int_state%latstart + lat2(n) = wrt_int_state%latlast + dlon(n) = delon + dlat(n) = delat allocate( wrt_int_state%lat_start_wrtgrp(wrt_int_state%petcount)) allocate( wrt_int_state%lat_end_wrtgrp (wrt_int_state%petcount)) + allocate( wrt_int_state%lon_start_wrtgrp(wrt_int_state%petcount)) + allocate( wrt_int_state%lon_end_wrtgrp (wrt_int_state%petcount)) call mpi_allgather(wrt_int_state%lat_start,1,MPI_INTEGER, & wrt_int_state%lat_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) call mpi_allgather(wrt_int_state%lat_end, 1,MPI_INTEGER, & wrt_int_state%lat_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_start,1,MPI_INTEGER, & + wrt_int_state%lon_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_end, 1,MPI_INTEGER, & + wrt_int_state%lon_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) if( lprnt ) print *,'aft wrtgrd, latlon, dimj_start=',wrt_int_state%lat_start_wrtgrp, & 'dimj_end=',wrt_int_state%lat_end_wrtgrp, 'wrt_group=',n_group allocate( wrt_int_state%latPtr(wrt_int_state%lon_start:wrt_int_state%lon_end, & @@ -570,62 +677,64 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%lonPtr(i,j) = lonPtr(i,j) enddo enddo - wrt_int_state%im = imo - wrt_int_state%jm = jmo + wrt_int_state%im = imo(n) + wrt_int_state%jm = jmo(n) wrt_int_state%post_maptype = 0 - else if ( trim(output_grid) == 'regional_latlon' .or. & - trim(output_grid) == 'rotated_latlon' .or. & - trim(output_grid) == 'lambert_conformal' ) then + deallocate(lat, lon) - wrtgrid = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & - maxIndex=(/imo,jmo/), regDecomp=(/1,ntasks/), & - indexflag=ESMF_INDEX_GLOBAL, & - name='wrt_grid',rc=rc) + else if ( trim(output_grid(n)) == 'regional_latlon' .or. & + trim(output_grid(n)) == 'rotated_latlon' .or. & + trim(output_grid(n)) == 'lambert_conformal' ) then + + wrtGrid(n) = ESMF_GridCreateNoPeriDim(minIndex=(/1,1/), & + maxIndex=(/imo(n),jmo(n)/), regDecomp=(/itasks,jtasks/), & + indexflag=ESMF_INDEX_GLOBAL, & + name='wrt_grid',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridAddCoord(wrtgrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + call ESMF_GridAddCoord(wrtGrid(n), staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=1, farrayPtr=lonPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=1, farrayPtr=lonPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtgrid, coordDim=2, farrayPtr=latPtr, rc=rc) + call ESMF_GridGetCoord(wrtGrid(n), coordDim=2, farrayPtr=latPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - wrt_int_state%im = imo - wrt_int_state%jm = jmo - if ( trim(output_grid) == 'regional_latlon' ) then + wrt_int_state%im = imo(n) + wrt_int_state%jm = jmo(n) + if ( trim(output_grid(n)) == 'regional_latlon' ) then do j=lbound(lonPtr,2),ubound(lonPtr,2) do i=lbound(lonPtr,1),ubound(lonPtr,1) - lonPtr(i,j) = lon1 + (lon2-lon1)/(imo-1) * (i-1) - latPtr(i,j) = lat1 + (lat2-lat1)/(jmo-1) * (j-1) + lonPtr(i,j) = lon1(n) + (lon2(n)-lon1(n))/(imo(n)-1) * (i-1) + latPtr(i,j) = lat1(n) + (lat2(n)-lat1(n))/(jmo(n)-1) * (j-1) enddo enddo wrt_int_state%post_maptype = 0 - else if ( trim(output_grid) == 'rotated_latlon' ) then + else if ( trim(output_grid(n)) == 'rotated_latlon' ) then do j=lbound(lonPtr,2),ubound(lonPtr,2) do i=lbound(lonPtr,1),ubound(lonPtr,1) - rot_lon = lon1 + (lon2-lon1)/(imo-1) * (i-1) - rot_lat = lat1 + (lat2-lat1)/(jmo-1) * (j-1) - call rtll(rot_lon, rot_lat, geo_lon, geo_lat, dble(cen_lon), dble(cen_lat)) + rot_lon = lon1(n) + (lon2(n)-lon1(n))/(imo(n)-1) * (i-1) + rot_lat = lat1(n) + (lat2(n)-lat1(n))/(jmo(n)-1) * (j-1) + call rtll(rot_lon, rot_lat, geo_lon, geo_lat, dble(cen_lon(n)), dble(cen_lat(n))) if (geo_lon < 0.0) geo_lon = geo_lon + 360.0 lonPtr(i,j) = geo_lon latPtr(i,j) = geo_lat enddo enddo wrt_int_state%post_maptype = 207 - else if ( trim(output_grid) == 'lambert_conformal' ) then - lon1_r8 = dble(lon1) - lat1_r8 = dble(lat1) - call lambert(dble(stdlat1),dble(stdlat2),dble(cen_lat),dble(cen_lon), & + else if ( trim(output_grid(n)) == 'lambert_conformal' ) then + lon1_r8 = dble(lon1(n)) + lat1_r8 = dble(lat1(n)) + call lambert(dble(stdlat1(n)),dble(stdlat2(n)),dble(cen_lat(n)),dble(cen_lon(n)), & lon1_r8,lat1_r8,x1,y1, 1) do j=lbound(lonPtr,2),ubound(lonPtr,2) do i=lbound(lonPtr,1),ubound(lonPtr,1) - x = x1 + dx * (i-1) - y = y1 + dy * (j-1) - call lambert(dble(stdlat1),dble(stdlat2),dble(cen_lat),dble(cen_lon), & + x = x1 + dx(n) * (i-1) + y = y1 + dy(n) * (j-1) + call lambert(dble(stdlat1(n)),dble(stdlat2(n)),dble(cen_lat(n)),dble(cen_lon(n)), & geo_lon,geo_lat,x,y,-1) if (geo_lon <0.0) geo_lon = geo_lon + 360.0 lonPtr(i,j) = geo_lon @@ -641,10 +750,16 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%lon_end = ubound(lonPtr,1) allocate( wrt_int_state%lat_start_wrtgrp(wrt_int_state%petcount)) allocate( wrt_int_state%lat_end_wrtgrp (wrt_int_state%petcount)) + allocate( wrt_int_state%lon_start_wrtgrp(wrt_int_state%petcount)) + allocate( wrt_int_state%lon_end_wrtgrp (wrt_int_state%petcount)) call mpi_allgather(wrt_int_state%lat_start,1,MPI_INTEGER, & - wrt_int_state%lat_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + wrt_int_state%lat_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) call mpi_allgather(wrt_int_state%lat_end, 1,MPI_INTEGER, & wrt_int_state%lat_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_start,1,MPI_INTEGER, & + wrt_int_state%lon_start_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) + call mpi_allgather(wrt_int_state%lon_end, 1,MPI_INTEGER, & + wrt_int_state%lon_end_wrtgrp, 1, MPI_INTEGER, wrt_mpi_comm, rc) allocate( wrt_int_state%latPtr(wrt_int_state%lon_start:wrt_int_state%lon_end, & wrt_int_state%lat_start:wrt_int_state%lat_end)) allocate( wrt_int_state%lonPtr(wrt_int_state%lon_start:wrt_int_state%lon_end, & @@ -658,11 +773,13 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) else - write(0,*)"wrt_initialize: Unknown output_grid ", trim(output_grid) - call ESMF_LogWrite("wrt_initialize: Unknown output_grid "//trim(output_grid),ESMF_LOGMSG_ERROR,rc=RC) + write(0,*)"wrt_initialize: Unknown output_grid ", trim(output_grid(n)) + call ESMF_LogWrite("wrt_initialize: Unknown output_grid "//trim(output_grid(n)),ESMF_LOGMSG_ERROR,rc=RC) call ESMF_Finalize(endflag=ESMF_END_ABORT) endif + + end do ! n = 1, ngrids ! !----------------------------------------------------------------------- !*** get write grid component initial time from clock @@ -686,17 +803,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) m=idate(5),s=idate(6),rc=rc) wrt_int_state%idate = idate change_wrtidate = .true. - if (lprnt) print *,'in wrt initial, with iau, io_baseline time=',idate,'rc=',rc + if (lprnt) print *,'in wrt initial, with iau, io_baseline time=',idate,'rc=',rc endif ! -! Create field bundle -!------------------------------------------------------------------- -! -!--- check grid dim count first - call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! !--- Look at the incoming FieldBundles in the imp_state_write, and mirror them ! call ESMF_StateGet(imp_state_write, itemCount=FBCount, rc=rc) @@ -716,12 +825,14 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) outfilename = '' call ESMF_StateGet(imp_state_write, itemNameList=fcstItemNameList, & - itemTypeList=fcstItemTypeList, rc=rc) + itemTypeList=fcstItemTypeList, & + !itemorderflag=ESMF_ITEMORDER_ADDORDER, & + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return !loop over all items in the imp_state_write and collect all FieldBundles - do i=1, FBcount + do i=1, FBCount if (fcstItemTypeList(i) == ESMF_STATEITEM_FIELDBUNDLE) then @@ -730,6 +841,15 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_AttributeGet(fcstFB, convention="NetCDF", purpose="FV3", & + name="grid_id", value=grid_id, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + +!--- check grid dim count first + call ESMF_GridGet(wrtGrid(grid_id), dimCount=gridDimCount, rc=rc) + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! create a mirror FieldBundle and add it to importState fieldbundle = ESMF_FieldBundleCreate(name="mirror_"//trim(fcstItemNameList(i)), rc=rc) @@ -772,7 +892,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_FieldGet(fcstField(j), gridToFieldMap=gridToFieldMap, & ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & rc=rc) - CALL ESMF_LogWrite("after field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("after field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) ! if (lprnt) print *,'in wrt,fcstfld,fieldname=', & ! trim(fieldname),'fieldDimCount=',fieldDimCount,'gridDimCount=',gridDimCount, & @@ -783,12 +903,12 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! create the mirror field - CALL ESMF_LogWrite("call field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) - field_work = ESMF_FieldCreate(wrtGrid, typekind, name=fieldName, & + call ESMF_LogWrite("call field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) + field_work = ESMF_FieldCreate(wrtGrid(grid_id), typekind, name=fieldName, & gridToFieldMap=gridToFieldMap, & ungriddedLBound=ungriddedLBound, & ungriddedUBound=ungriddedUBound, rc=rc) - CALL ESMF_LogWrite("aft call field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("aft call field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -803,11 +923,11 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) name="output_file", value=outfile_name, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - CALL ESMF_LogWrite("bf fcstfield, get output_file "//trim(outfile_name)//" "//trim(fieldName),ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("bf fcstfield, get output_file "//trim(outfile_name)//" "//trim(fieldName),ESMF_LOGMSG_INFO,rc=RC) if (trim(outfile_name) /= '') then outfilename(j,i) = trim(outfile_name) endif - CALL ESMF_LogWrite("af fcstfield, get output_file",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("af fcstfield, get output_file",ESMF_LOGMSG_INFO,rc=RC) ! if (lprnt) print *,' i=',i,' j=',j,' outfilename=',trim(outfilename(j,i)) @@ -820,7 +940,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) deallocate(gridToFieldMap, ungriddedLBound, ungriddedUBound) enddo ! - call ESMF_AttributeCopy(fcstGrid, wrtGrid, & + call ESMF_AttributeCopy(fcstGrid, wrtGrid(grid_id), & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -845,7 +965,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! !create output field bundles - allocate(wrt_int_state%wrtFB(num_files)) + allocate(wrt_int_state%wrtFB(wrt_int_state%FBcount)) do i=1, wrt_int_state%FBcount wrt_int_state%wrtFB_names(i) = trim(FBlist_outfilename(i)) @@ -858,13 +978,17 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_StateGet(imp_state_write, itemName="mirror_"//trim(fcstItemNameList(n)), & fieldbundle=fcstFB, rc=rc) - if( index(trim(fcstItemNameList(n)),trim(FBlist_outfilename(i))) > 0 ) then + if( index(trim(fcstItemNameList(n)),trim(FBlist_outfilename(i))) == 1 ) then ! ! copy the mirror fcstfield bundle Attributes to the output field bundle call ESMF_AttributeCopy(fcstFB, wrt_int_state%wrtFB(i), & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeGet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & + name="grid_id", value=grid_id, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! call ESMF_FieldBundleGet(fcstFB, fieldCount=fieldCount, rc=rc) @@ -905,57 +1029,43 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="source", value="FV3GFS", rc=rc) - if (trim(output_grid) == 'cubed_sphere_grid') then + if (trim(output_grid(grid_id)) == 'cubed_sphere_grid') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="grid", value="cubed_sphere", rc=rc) - else if (trim(output_grid) == 'gaussian_grid') then + else if (trim(output_grid(grid_id)) == 'gaussian_grid') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="grid", value="gaussian", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & attrList=(/"im","jm"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="im", value=imo, rc=rc) - call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="jm", value=jmo, rc=rc) - - else if (trim(output_grid) == 'global_latlon') then - - call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="latlon", rc=rc) - call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"lonstart","latstart","lonlast ","latlast "/), rc=rc) - call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lonstart", value=wrt_int_state%lonstart, rc=rc) + name="im", value=imo(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="latstart", value=wrt_int_state%latstart, rc=rc) - call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lonlast", value=wrt_int_state%lonlast, rc=rc) - call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="latlast", value=wrt_int_state%latlast, rc=rc) + name="jm", value=jmo(grid_id), rc=rc) - else if (trim(output_grid) == 'regional_latlon') then + else if (trim(output_grid(grid_id)) == 'regional_latlon' & + .or. trim(output_grid(grid_id)) == 'global_latlon') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="grid", value="latlon", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & attrList=(/"lon1","lat1","lon2","lat2","dlon","dlat"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon2", value=lon2, rc=rc) + name="lon2", value=lon2(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat2", value=lat2, rc=rc) + name="lat2", value=lat2(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlon", value=dlon, rc=rc) + name="dlon", value=dlon(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlat", value=dlat, rc=rc) + name="dlat", value=dlat(grid_id), rc=rc) - else if (trim(output_grid) == 'rotated_latlon') then + else if (trim(output_grid(grid_id)) == 'rotated_latlon') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="grid", value="rotated_latlon", rc=rc) @@ -969,23 +1079,23 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) "dlon ",& "dlat "/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lon", value=cen_lon, rc=rc) + name="cen_lon", value=cen_lon(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lat", value=cen_lat, rc=rc) + name="cen_lat", value=cen_lat(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon2", value=lon2, rc=rc) + name="lon2", value=lon2(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat2", value=lat2, rc=rc) + name="lat2", value=lat2(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlon", value=dlon, rc=rc) + name="dlon", value=dlon(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlat", value=dlat, rc=rc) + name="dlat", value=dlat(grid_id), rc=rc) - else if (trim(output_grid) == 'lambert_conformal') then + else if (trim(output_grid(grid_id)) == 'lambert_conformal') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & name="grid", value="lambert_conformal", rc=rc) @@ -1001,25 +1111,25 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) "dx ",& "dy "/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lon", value=cen_lon, rc=rc) + name="cen_lon", value=cen_lon(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lat", value=cen_lat, rc=rc) + name="cen_lat", value=cen_lat(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="stdlat1", value=stdlat1, rc=rc) + name="stdlat1", value=stdlat1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="stdlat2", value=stdlat2, rc=rc) + name="stdlat2", value=stdlat2(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="nx", value=imo, rc=rc) + name="nx", value=imo(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="ny", value=jmo, rc=rc) + name="ny", value=jmo(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dx", value=dx, rc=rc) + name="dx", value=dx(grid_id), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dy", value=dy, rc=rc) + name="dy", value=dy(grid_id), rc=rc) end if @@ -1066,8 +1176,10 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) endif enddo + + do n = 1, ngrids ! add the transfer attributes from importState to grid - call ESMF_AttributeAdd(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeAdd(wrtGrid(n), convention="NetCDF", purpose="FV3", & attrList=attNameList(1:j-1), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1093,7 +1205,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if(lprnt) print *,'in write grid comp, new time:unit=',trim(valueS) endif endif - call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(wrtGrid(n), convention="NetCDF", purpose="FV3", & name=trim(attNameList(i)), value=valueS, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1105,7 +1217,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(wrtGrid(n), convention="NetCDF", purpose="FV3", & name=trim(attNameList(i)), value=valueI4, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1117,7 +1229,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(wrtGrid(n), convention="NetCDF", purpose="FV3", & name=trim(attNameList(i)), value=valueR4, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1129,7 +1241,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(wrtGrid(n), convention="NetCDF", purpose="FV3", & name=trim(attNameList(i)), value=valueR8, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1138,17 +1250,16 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! Add special attribute that holds names of "time" related attributes ! for faster access during Run(). - call ESMF_AttributeAdd(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeAdd(wrtGrid(n), convention="NetCDF", purpose="FV3", & attrList=(/"TimeAttributes"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(wrtGrid(n), convention="NetCDF", purpose="FV3", & name="TimeAttributes", valueList=attNameList2(1:k-1), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - deallocate(attNameList, attNameList2, typekindList) ! !*** create temporary field bundle for axes information @@ -1158,20 +1269,14 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeGet(wrtGrid, convention="NetCDF", purpose="FV3", & - name="ESMF:gridded_dim_labels", valueList=attrValueSList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(wrtGrid, coordDim=1, & + call ESMF_GridGetCoord(wrtGrid(n), coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! write(0,*) 'create gridFB,fieldname=',trim(attrValueSList(1)),trim(attrValueSList(2)), & -! 'lon value=',array(1:5) - - field = ESMF_FieldCreate(wrtGrid, array, name=trim(attrValueSList(1)), rc=rc) + field = ESMF_FieldCreate(wrtGrid(n), array, name="grid_xt", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1213,15 +1318,12 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! ! get 2nd dimension - call ESMF_GridGetCoord(wrtGrid, coordDim=2, & + call ESMF_GridGetCoord(wrtGrid(n), coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! write(0,*) 'create gridFB,fieldname=',trim(attrValueSList(1)),trim(attrValueSList(2)), & -! 'lat value=',array(1:5,1),array(1,1:5) - - field = ESMF_FieldCreate(wrtGrid, array, name=trim(attrValueSList(2)), rc=rc) + field = ESMF_FieldCreate(wrtGrid(n), array, name="grid_yt", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return !add attribute info @@ -1260,6 +1362,10 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_FieldBundleAdd(gridFB, (/field/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + end do ! n=1, ngrids + + deallocate(attNameList, attNameList2, typekindList) ! !----------------------------------------------------------------------- !*** SET THE FIRST HISTORY FILE'S TIME INDEX. @@ -1274,17 +1380,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_LogWrite("before initialize for POST", ESMF_LOGMSG_INFO, rc=rc) if (lprnt) print *,'in wrt grid comp, dopost=',wrt_int_state%write_dopost if( wrt_int_state%write_dopost ) then - call inline_post_getattr(wrt_int_state) + call inline_post_getattr(wrt_int_state,1) endif ! -!----------------------------------------------------------------------- -! - IF(RC /= ESMF_SUCCESS) THEN - WRITE(0,*)"FAIL: Write_Initialize." -! ELSE -! WRITE(0,*)"PASS: Write_Initialize." - ENDIF -! ! write_init_tim = MPI_Wtime() - btim0 ! !----------------------------------------------------------------------- @@ -1312,9 +1410,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) TYPE(ESMF_VM) :: VM type(ESMF_FieldBundle) :: file_bundle type(ESMF_Time) :: currtime - type(ESMF_TypeKind_Flag) :: datatype - type(ESMF_Field) :: field_work - type(ESMF_Grid) :: fbgrid, wrtgrid + type(ESMF_Grid) :: fbgrid, wrtGrid type(ESMF_State),save :: stateGridFB type(optimizeT), save :: optimize(4) type(ESMF_GridComp), save, allocatable :: compsGridFB(:) @@ -1322,34 +1418,27 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) type(write_wrap) :: wrap type(wrt_internal_state),pointer :: wrt_int_state ! - integer :: i,j,n,mype,nolog + integer :: i,j,n,mype,nolog, grid_id ! integer :: nf_hours,nf_seconds, nf_minutes, & nseconds,nseconds_num,nseconds_den ! - integer :: id - integer :: nbdl, idx, date(6), ndig + integer :: nbdl, date(6), ndig, nnnn integer :: step=1 ! logical :: opened logical :: lmask_fields - logical,save :: first=.true. - logical,save :: file_first=.true. ! - character(esmf_maxstr) :: filename,compname,bundle_name + character(esmf_maxstr) :: filename,compname character(40) :: cfhour, cform real(ESMF_KIND_R8) :: time ! - real(kind=8) :: wait_time, MPI_Wtime - real(kind=8) :: times,times2,etim - character(10) :: timeb - real(kind=8) :: tbeg,tend + real(kind=8) :: MPI_Wtime + real(kind=8) :: tbeg real(kind=8) :: wbeg,wend - real(kind=ESMF_KIND_R8), dimension(:,:,:), pointer :: datar8 - real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d -! - logical lprnt + logical :: use_parallel_netcdf + logical :: lprnt ! !----------------------------------------------------------------------- !*********************************************************************** @@ -1359,16 +1448,11 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) rc = esmf_success ! !----------------------------------------------------------------------- -!*** get the current write grid comp name, id, and internal state +!*** get the current write grid comp name, and internal state ! call ESMF_GridCompGet(wrt_comp, name=compname, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! print *,'in wrt run. compname=',trim(compname),' rc=',rc - -! instance id from name - read(compname(10:11),"(I2)") id - ! Provide log message indicating which wrtComp is active call ESMF_LogWrite("Write component activated: "//trim(compname), & ESMF_LOGMSG_INFO, rc=rc) @@ -1424,7 +1508,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) nf_seconds = nf_hours*3600+nf_minuteS*60+nseconds+real(nseconds_num)/real(nseconds_den) wrt_int_state%nfhour = nf_seconds/3600. nf_hours = int(nf_seconds/3600.) - if(mype == lead_write_task) print *,'in write grid comp, nf_hours=',nf_hours + if(lprnt) print *,'in write grid comp, nf_hours=',nf_hours ! if iau_offset > nf_hours, don't write out anything if (nf_hours < 0) return @@ -1448,25 +1532,20 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) ! ' nf_seconds=',nf_seconds,wrt_int_state%nfhour ! access the time Attribute which is updated by the driver each time - call ESMF_LogWrite("before Write component get time", ESMF_LOGMSG_INFO, rc=rc) call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & name="time", value=time, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMF_LogWrite("before Write component af get time", ESMF_LOGMSG_INFO, rc=rc) ! !----------------------------------------------------------------------- !*** loop on the files that need to write out !----------------------------------------------------------------------- do i=1, FBCount - call ESMF_LogWrite("before Write component get mirror file bundle", ESMF_LOGMSG_INFO, rc=rc) call ESMF_StateGet(imp_state_write, itemName="mirror_"//trim(fcstItemNameList(i)), & fieldbundle=file_bundle, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_LogWrite("before Write component af get mirror file bundle", ESMF_LOGMSG_INFO, rc=rc) + !recover fields from cartesian vector and sfc pressure call recover_fields(file_bundle,rc) enddo @@ -1478,26 +1557,25 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) if( wrt_int_state%write_dopost ) then ! wbeg = MPI_Wtime() - if (trim(output_grid) == 'regional_latlon' .or. & - trim(output_grid) == 'rotated_latlon' .or. & - trim(output_grid) == 'lambert_conformal') then + if (trim(output_grid(1)) == 'regional_latlon' .or. & + trim(output_grid(1)) == 'rotated_latlon' .or. & + trim(output_grid(1)) == 'lambert_conformal') then !mask fields according to sfc pressure do nbdl=1, wrt_int_state%FBCount - call ESMF_LogWrite("before mask_fields for wrt field bundle", ESMF_LOGMSG_INFO, rc=rc) call mask_fields(wrt_int_state%wrtFB(nbdl),rc) - call ESMF_LogWrite("after mask_fields for wrt field bundle", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return enddo lmask_fields = .true. endif - call inline_post_run(wrt_int_state, mype, wrt_mpi_comm, lead_write_task, & + call inline_post_run(wrt_int_state, 1, mype, wrt_mpi_comm, lead_write_task, & nf_hours, nf_minutes,nseconds) wend = MPI_Wtime() if (lprnt) then write(*,'(A,F10.5,A,I4.2,A,I2.2)')' actual inline post Time is ',wend-wbeg & ,' at Fcst ',nf_hours,':',nf_minutes - endif + endif endif ! @@ -1509,52 +1587,60 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) file_loop_all: do nbdl=1, wrt_int_state%FBCount ! + ! get grid_id + call ESMF_AttributeGet(wrt_int_state%wrtFB(nbdl), convention="NetCDF", purpose="FV3", & + name="grid_id", value=grid_id, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if(step == 1) then file_bundle = wrt_int_state%wrtFB(nbdl) endif + ! FIXME map nbdl to [1:num_files], only used for output_file + nnnn = mod(nbdl-1, num_files) + 1 + ! set default chunksizes for netcdf output ! (use MPI decomposition size). ! if chunksize parameter set to negative value, ! netcdf library default is used. - if (output_file(nbdl)(1:6) == 'netcdf') then - if (ichunk2d == 0) then + if (output_file(nnnn)(1:6) == 'netcdf') then + if (ichunk2d(grid_id) == 0) then if( wrt_int_state%mype == 0 ) & - ichunk2d = wrt_int_state%lon_end-wrt_int_state%lon_start+1 - call mpi_bcast(ichunk2d,1,mpi_integer,0,wrt_mpi_comm,rc) + ichunk2d(grid_id) = wrt_int_state%lon_end-wrt_int_state%lon_start+1 + call mpi_bcast(ichunk2d(grid_id),1,mpi_integer,0,wrt_mpi_comm,rc) endif - if (jchunk2d == 0) then + if (jchunk2d(grid_id) == 0) then if( wrt_int_state%mype == 0 ) & - jchunk2d = wrt_int_state%lat_end-wrt_int_state%lat_start+1 - call mpi_bcast(jchunk2d,1,mpi_integer,0,wrt_mpi_comm,rc) + jchunk2d(grid_id) = wrt_int_state%lat_end-wrt_int_state%lat_start+1 + call mpi_bcast(jchunk2d(grid_id),1,mpi_integer,0,wrt_mpi_comm,rc) endif - if (ichunk3d == 0) then + if (ichunk3d(grid_id) == 0) then if( wrt_int_state%mype == 0 ) & - ichunk3d = wrt_int_state%lon_end-wrt_int_state%lon_start+1 - call mpi_bcast(ichunk3d,1,mpi_integer,0,wrt_mpi_comm,rc) + ichunk3d(grid_id) = wrt_int_state%lon_end-wrt_int_state%lon_start+1 + call mpi_bcast(ichunk3d(grid_id),1,mpi_integer,0,wrt_mpi_comm,rc) endif - if (jchunk3d == 0) then + if (jchunk3d(grid_id) == 0) then if( wrt_int_state%mype == 0 ) & - jchunk3d = wrt_int_state%lat_end-wrt_int_state%lat_start+1 - call mpi_bcast(jchunk3d,1,mpi_integer,0,wrt_mpi_comm,rc) + jchunk3d(grid_id) = wrt_int_state%lat_end-wrt_int_state%lat_start+1 + call mpi_bcast(jchunk3d(grid_id),1,mpi_integer,0,wrt_mpi_comm,rc) endif - if (kchunk3d == 0 .and. nbdl == 1) then + if (kchunk3d(grid_id) == 0 .and. nbdl == 1) then if( wrt_int_state%mype == 0 ) then - call ESMF_FieldBundleGet(wrt_int_state%wrtFB(nbdl), grid=wrtgrid) - call ESMF_AttributeGet(wrtgrid, convention="NetCDF", purpose="FV3", & + call ESMF_FieldBundleGet(wrt_int_state%wrtFB(nbdl), grid=wrtGrid) + call ESMF_AttributeGet(wrtGrid, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, name='pfull', & - itemCount=kchunk3d, rc=rc) + itemCount=kchunk3d(grid_id), rc=rc) endif - call mpi_bcast(kchunk3d,1,mpi_integer,0,wrt_mpi_comm,rc) + call mpi_bcast(kchunk3d(grid_id),1,mpi_integer,0,wrt_mpi_comm,rc) endif if (wrt_int_state%mype == 0) then - print *,'ichunk2d,jchunk2d',ichunk2d,jchunk2d - print *,'ichunk3d,jchunk3d,kchunk3d',ichunk3d,jchunk3d,kchunk3d + print *,'ichunk2d,jchunk2d',ichunk2d(grid_id),jchunk2d(grid_id) + print *,'ichunk3d,jchunk3d,kchunk3d',ichunk3d(grid_id),jchunk3d(grid_id),kchunk3d(grid_id) endif endif filename = trim(wrt_int_state%wrtFB_names(nbdl))//'f'//trim(cfhour)//'.nc' -! if(mype == lead_write_task) print *,'in wrt run,filename=',trim(filename) + if(mype == lead_write_task) print *,'in wrt run,filename= ',nbdl,trim(filename) ! ! set the time Attribute on the grid to carry it into the lower levels @@ -1573,183 +1659,86 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (trim(output_grid) == 'cubed_sphere_grid') then - - wbeg = MPI_Wtime() - call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & - convention="NetCDF", purpose="FV3", & - status=ESMF_FILESTATUS_REPLACE, & - state=stateGridFB, comps=compsGridFB,rc=rc) - - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & - filename=trim(filename), convention="NetCDF", & - purpose="FV3", status=ESMF_FILESTATUS_OLD, & - timeslice=step, state=optimize(nbdl)%state, & - comps=optimize(nbdl)%comps, rc=rc) - - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' actual netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - - else if (trim(output_grid) == 'gaussian_grid') then - - if (trim(output_file(nbdl)) == 'netcdf') then - - wbeg = MPI_Wtime() - call write_netcdf(file_bundle,wrt_int_state%wrtFB(nbdl),trim(filename), & - wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - - else if (trim(output_file(nbdl)) == 'netcdf_parallel') then - -#ifdef NO_PARALLEL_NETCDF - rc = ESMF_RC_NOT_IMPL - print *,'netcdf_parallel not available on this machine' - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return -#endif - wbeg = MPI_Wtime() - call write_netcdf_parallel(file_bundle,wrt_int_state%wrtFB(nbdl), & - trim(filename), wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' parallel netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif + if (trim(output_file(nnnn)) == 'netcdf') then + use_parallel_netcdf = .false. + else if (trim(output_file(nnnn)) == 'netcdf_parallel') then + use_parallel_netcdf = .true. + else + call ESMF_LogWrite("wrt_run: Unknown output_file",ESMF_LOGMSG_ERROR,rc=RC) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif - else if (trim(output_file(nbdl)) == 'netcdf_esmf') then + if (trim(output_grid(grid_id)) == 'cubed_sphere_grid') then - wbeg = MPI_Wtime() - call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & - convention="NetCDF", purpose="FV3", & - status=ESMF_FILESTATUS_REPLACE, state=stateGridFB, comps=compsGridFB,rc=rc) + wbeg = MPI_Wtime() + if (trim(output_file(nnnn)) == 'netcdf_parallel') then + call write_netcdf(wrt_int_state%wrtFB(nbdl),trim(filename), & + .true., wrt_mpi_comm,wrt_int_state%mype, & + grid_id,rc) + else + call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & + convention="NetCDF", purpose="FV3", & + status=ESMF_FILESTATUS_REPLACE, & + state=stateGridFB, comps=compsGridFB,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & - filename=trim(filename), convention="NetCDF", & - purpose="FV3", status=ESMF_FILESTATUS_OLD, & - timeslice=step, state=optimize(nbdl)%state, & + call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & + filename=trim(filename), convention="NetCDF", & + purpose="FV3", status=ESMF_FILESTATUS_OLD, & + timeslice=step, state=optimize(nbdl)%state, & comps=optimize(nbdl)%comps, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' netcdf_esmf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif + end if + wend = MPI_Wtime() + if (lprnt) then + write(*,'(A15,A,F10.5,A,I4.2,A,I2.2,1X,A)')trim(output_file(nnnn)),' Write Time is ',wend-wbeg & + ,' at Fcst ',NF_HOURS,':',NF_MINUTES endif - else if (trim(output_grid) == 'global_latlon') then - - if (trim(output_file(nbdl)) == 'netcdf') then - - wbeg = MPI_Wtime() - call write_netcdf(file_bundle,wrt_int_state%wrtFB(nbdl),trim(filename), & - wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - - else if (trim(output_file(nbdl)) == 'netcdf_parallel') then - -#ifdef NO_PARALLEL_NETCDF - rc = ESMF_RC_NOT_IMPL - print *,'netcdf_parallel not available on this machine' - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return -#endif - wbeg = MPI_Wtime() - call write_netcdf_parallel(file_bundle,wrt_int_state%wrtFB(nbdl), & - trim(filename), wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' parallel netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - - else ! unknown output_file - - call ESMF_LogWrite("wrt_run: Unknown output_file",ESMF_LOGMSG_ERROR,rc=RC) - call ESMF_Finalize(endflag=ESMF_END_ABORT) + else if (trim(output_grid(grid_id)) == 'gaussian_grid' .or. & + trim(output_grid(grid_id)) == 'global_latlon') then + wbeg = MPI_Wtime() + call write_netcdf(wrt_int_state%wrtFB(nbdl),trim(filename), & + use_parallel_netcdf, wrt_mpi_comm,wrt_int_state%mype, & + grid_id,rc) + wend = MPI_Wtime() + if (lprnt) then + write(*,'(A15,A,F10.5,A,I4.2,A,I2.2,1X,A)')trim(output_file(nnnn)),' Write Time is ',wend-wbeg & + ,' at Fcst ',NF_HOURS,':',NF_MINUTES endif - else if (trim(output_grid) == 'regional_latlon' .or. & - trim(output_grid) == 'rotated_latlon' .or. & - trim(output_grid) == 'lambert_conformal') then + else if (trim(output_grid(grid_id)) == 'regional_latlon' .or. & + trim(output_grid(grid_id)) == 'rotated_latlon' .or. & + trim(output_grid(grid_id)) == 'lambert_conformal') then !mask fields according to sfc pressure - !if (mype == lead_write_task) print *,'before mask_fields' if( .not. lmask_fields ) then wbeg = MPI_Wtime() - call ESMF_LogWrite("before mask_fields for wrt field bundle", ESMF_LOGMSG_INFO, rc=rc) - !call mask_fields(wrt_int_state%wrtFB(nbdl),rc) call mask_fields(file_bundle,rc) - !if (mype == lead_write_task) print *,'after mask_fields' - call ESMF_LogWrite("after mask_fields for wrt field bundle", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return wend = MPI_Wtime() - if (mype == lead_write_task) then + if (lprnt) then write(*,'(A,F10.5,A,I4.2,A,I2.2)')' mask_fields time is ',wend-wbeg endif endif - if (trim(output_file(nbdl)) == 'netcdf' .and. nbits==0) then - - wbeg = MPI_Wtime() - call write_netcdf(file_bundle,wrt_int_state%wrtFB(nbdl),trim(filename), & - wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (mype == lead_write_task) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - - else if (trim(output_file(nbdl)) == 'netcdf_parallel' .and. nbits==0) then - -#ifdef NO_PARALLEL_NETCDF - rc = ESMF_RC_NOT_IMPL - print *,'netcdf_parallel not available on this machine' - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return -#endif - wbeg = MPI_Wtime() - call write_netcdf_parallel(file_bundle,wrt_int_state%wrtFB(nbdl), & - trim(filename), wrt_mpi_comm,wrt_int_state%mype,imo,jmo,& - ichunk2d,jchunk2d,ichunk3d,jchunk3d,kchunk3d,rc) - wend = MPI_Wtime() - if (lprnt) then - write(*,'(A,F10.5,A,I4.2,A,I2.2)')' parallel netcdf Write Time is ',wend-wbeg & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES - endif - else ! unknown output_file - - if( nbits /= 0) then - call ESMF_LogWrite("wrt_run: lossy compression is not supported for regional grids",ESMF_LOGMSG_ERROR,rc=RC) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - else - call ESMF_LogWrite("wrt_run: Unknown output_file",ESMF_LOGMSG_ERROR,rc=RC) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif + if (nbits(grid_id) /= 0) then + call ESMF_LogWrite("wrt_run: lossy compression is not supported for regional grids",ESMF_LOGMSG_ERROR,rc=RC) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if + wbeg = MPI_Wtime() + call write_netcdf(wrt_int_state%wrtFB(nbdl),trim(filename), & + use_parallel_netcdf, wrt_mpi_comm,wrt_int_state%mype, & + grid_id,rc) + wend = MPI_Wtime() + if (lprnt) then + write(*,'(A15,A,F10.5,A,I4.2,A,I2.2,1X,A)')trim(output_file(nnnn)),' Write Time is ',wend-wbeg & + ,' at Fcst ',NF_HOURS,':',NF_MINUTES endif else ! unknown output_grid @@ -1766,7 +1755,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) ! !** write out log file ! - if(mype == lead_write_task) then + if (mype == lead_write_task) then do n=701,900 inquire(n,opened=OPENED) if(.not.opened)then @@ -1785,6 +1774,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) !----------------------------------------------------------------------- ! call ESMF_VMBarrier(VM, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! write_run_tim = MPI_Wtime() - tbeg ! @@ -1792,12 +1782,6 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) WRITE(*,'(A,F10.5,A,I4.2,A,I2.2)')' total Write Time is ',write_run_tim & ,' at Fcst ',NF_HOURS,':',NF_MINUTES ENDIF -! - IF(RC /= ESMF_SUCCESS) THEN - WRITE(0,*)"FAIL: WRITE_RUN" -! ELSE -! WRITE(0,*)"PASS: WRITE_RUN" - ENDIF ! !----------------------------------------------------------------------- ! @@ -1840,21 +1824,14 @@ subroutine wrt_finalize(wrt_comp, imp_state_write, exp_state_write, clock, rc) !----------------------------------------------------------------------- ! call ESMF_GridCompGetInternalState(wrt_comp, wrap, rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + deallocate(wrap%write_int_state,stat=stat) -! if (ESMF_LogFoundDeallocError(statusToCheck=stat, & msg="Deallocation of internal state memory failed.", & line=__LINE__, file=__FILE__)) return ! !----------------------------------------------------------------------- -! - IF(RC /= ESMF_SUCCESS)THEN - WRITE(0,*)'FAIL: Write_Finalize.' -! ELSE -! WRITE(0,*)'PASS: Write_Finalize.' - ENDIF -! -!----------------------------------------------------------------------- ! end subroutine wrt_finalize ! @@ -1865,8 +1842,12 @@ subroutine recover_fields(file_bundle,rc) type(ESMF_FieldBundle), intent(in) :: file_bundle integer, intent(out), optional :: rc ! + real, parameter :: rdgas = 287.04, grav = 9.80 + real, parameter :: stndrd_atmos_ps = 101325. + real, parameter :: stndrd_atmos_lapse = 0.0065 + integer i,j,k,ifld,fieldCount,nstt,nend,fieldDimCount,gridDimCount - integer istart,iend,jstart,jend,kstart,kend,km + integer istart,iend,jstart,jend,kstart,kend logical uPresent, vPresent type(ESMF_Grid) fieldGrid type(ESMF_Field) ufield, vfield @@ -1880,68 +1861,63 @@ subroutine recover_fields(file_bundle,rc) real(ESMF_KIND_R4), dimension(:,:,:), pointer :: uwind3dr4,vwind3dr4 real(ESMF_KIND_R4), dimension(:,:,:), pointer :: cart3dPtr2dr4 real(ESMF_KIND_R4), dimension(:,:,:,:), pointer :: cart3dPtr3dr4 - real(ESMF_KIND_R8), dimension(:,:,:,:), pointer :: cart3dPtr3dr8 - save lonloc, latloc real(ESMF_KIND_R8) :: coslon, sinlon, sinlat ! ! get filed count call ESMF_FieldBundleGet(file_bundle, fieldCount=fieldCount, & grid=fieldGrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! - CALL ESMF_LogWrite("call recover field on wrt comp",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field on wrt comp",ESMF_LOGMSG_INFO,rc=RC) call ESMF_GridGet(fieldgrid, dimCount=gridDimCount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if( first_getlatlon ) then - CALL ESMF_LogWrite("call recover field get coord 1",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get coord 1",ESMF_LOGMSG_INFO,rc=RC) - call ESMF_GridGetCoord(fieldgrid, coordDim=1, farrayPtr=lon, rc=rc) + call ESMF_GridGetCoord(fieldgrid, coordDim=1, farrayPtr=lon, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - allocate(lonloc(lbound(lon,1):ubound(lon,1),lbound(lon,2):ubound(lon,2))) - istart = lbound(lon,1) - iend = ubound(lon,1) - jstart = lbound(lon,2) - jend = ubound(lon,2) + allocate(lonloc(lbound(lon,1):ubound(lon,1),lbound(lon,2):ubound(lon,2))) + istart = lbound(lon,1) + iend = ubound(lon,1) + jstart = lbound(lon,2) + jend = ubound(lon,2) !$omp parallel do default(none) shared(lon,lonloc,jstart,jend,istart,iend) & !$omp private(i,j) - do j=jstart,jend - do i=istart,iend - lonloc(i,j) = lon(i,j) * pi/180. - enddo - enddo + do j=jstart,jend + do i=istart,iend + lonloc(i,j) = lon(i,j) * pi/180. + enddo + enddo - CALL ESMF_LogWrite("call recover field get coord 2",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get coord 2",ESMF_LOGMSG_INFO,rc=RC) - call ESMF_GridGetCoord(fieldgrid, coordDim=2, farrayPtr=lat, rc=rc) + call ESMF_GridGetCoord(fieldgrid, coordDim=2, farrayPtr=lat, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - allocate(latloc(lbound(lat,1):ubound(lat,1),lbound(lat,2):ubound(lat,2))) - istart = lbound(lat,1) - iend = ubound(lat,1) - jstart = lbound(lat,2) - jend = ubound(lat,2) + allocate(latloc(lbound(lat,1):ubound(lat,1),lbound(lat,2):ubound(lat,2))) + istart = lbound(lat,1) + iend = ubound(lat,1) + jstart = lbound(lat,2) + jend = ubound(lat,2) !$omp parallel do default(none) shared(lat,latloc,jstart,jend,istart,iend) & !$omp private(i,j) - do j=jstart,jend - do i=istart,iend - latloc(i,j) = lat(i,j) * pi/180.d0 - enddo - enddo - first_getlatlon = .false. - endif + do j=jstart,jend + do i=istart,iend + latloc(i,j) = lat(i,j) * pi/180.d0 + enddo + enddo ! allocate(fcstField(fieldCount)) - CALL ESMF_LogWrite("call recover field get fcstField",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get fcstField",ESMF_LOGMSG_INFO,rc=RC) call ESMF_FieldBundleGet(file_bundle, fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) ! do ifld=1,fieldCount - CALL ESMF_LogWrite("call recover field get fieldname, type dimcount",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get fieldname, type dimcount",ESMF_LOGMSG_INFO,rc=RC) call ESMF_FieldGet(fcstField(ifld),name=fieldName,typekind=typekind,dimCount=fieldDimCount, rc=rc) ! convert back wind @@ -1957,7 +1933,7 @@ subroutine recover_fields(file_bundle,rc) endif ! print *,'in get 3D vector wind, uwindname=',trim(uwindname),' v=', trim(vwindname),' fieldname=',trim(fieldname) ! get u , v wind - CALL ESMF_LogWrite("call recover field get u, v field",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get u, v field",ESMF_LOGMSG_INFO,rc=RC) call ESMF_FieldBundleGet(file_bundle,trim(uwindname),field=ufield,isPresent=uPresent,rc=rc) call ESMF_FieldBundleGet(file_bundle,trim(vwindname),field=vfield,isPresent=vPresent,rc=rc) if(.not. uPresent .or. .not.vPresent) then @@ -1969,7 +1945,7 @@ subroutine recover_fields(file_bundle,rc) ! get field data if ( typekind == ESMF_TYPEKIND_R4 ) then if( fieldDimCount > gridDimCount+1 ) then - CALL ESMF_LogWrite("call recover field get 3d card wind farray",ESMF_LOGMSG_INFO,rc=RC) + call ESMF_LogWrite("call recover field get 3d card wind farray",ESMF_LOGMSG_INFO,rc=RC) call ESMF_FieldGet(fcstField(ifld), localDe=0, farrayPtr=cart3dPtr3dr4, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if( ubound(cart3dPtr3dr4,1)-lbound(cart3dPtr3dr4,1)+1/=3) then @@ -2006,11 +1982,11 @@ subroutine recover_fields(file_bundle,rc) enddo else call ESMF_FieldGet(fcstField(ifld), localDe=0, farrayPtr=cart3dPtr2dr4, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if( ubound(cart3dPtr2dr4,1)-lbound(cart3dPtr2dr4,1)+1 /= 3) then rc=991 - print *,'ERROR, 2D the vector dimension /= 3, rc=',rc - exit + write(0,*) 'ERROR, 2D the vector dimension /= 3, rc=',rc + call ESMF_Finalize(endflag=ESMF_END_ABORT) endif istart = lbound(cart3dPtr2dr4,2) iend = ubound(cart3dPtr2dr4,2) @@ -2067,8 +2043,8 @@ subroutine mask_fields(file_bundle,rc) type(ESMF_FieldBundle), intent(in) :: file_bundle integer, intent(out), optional :: rc ! - integer i,j,k,ifld,fieldCount,nstt,nend,fieldDimCount,gridDimCount - integer istart,iend,jstart,jend,kstart,kend,km + integer i,j,k,ifld,fieldCount,fieldDimCount,gridDimCount + integer istart,iend,jstart,jend,kstart,kend type(ESMF_Grid) fieldGrid type(ESMF_TypeKind_Flag) typekind type(ESMF_TypeKind_Flag) attTypeKind @@ -2085,8 +2061,6 @@ subroutine mask_fields(file_bundle,rc) real(ESMF_KIND_R8) :: missing_value_r8=9.99e20 character(len=ESMF_MAXSTR) :: msg - save maskwrt - call ESMF_LogWrite("call mask field on wrt comp",ESMF_LOGMSG_INFO,rc=RC) ! get fieldCount @@ -2104,8 +2078,6 @@ subroutine mask_fields(file_bundle,rc) call ESMF_FieldBundleGet(file_bundle, fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) ! generate the maskwrt according to surface pressure - if( first_getmaskwrt ) then - do ifld=1,fieldCount !call ESMF_LogWrite("call mask field get fieldname, type dimcount",ESMF_LOGMSG_INFO,rc=RC) call ESMF_FieldGet(fcstField(ifld),name=fieldName,typekind=typekind,dimCount=fieldDimCount, rc=rc) @@ -2142,9 +2114,6 @@ subroutine mask_fields(file_bundle,rc) exit endif enddo - first_getmaskwrt = .false. - - endif !first_getmaskwrt ! loop to mask all fields according to maskwrt do ifld=1,fieldCount @@ -2164,8 +2133,8 @@ subroutine mask_fields(file_bundle,rc) line=__LINE__, file=__FILE__)) return ! bail out if( ubound(vect4dPtr3dr4,1)-lbound(vect4dPtr3dr4,1)+1/=3 ) then rc=991 - print *,'ERROR, 3D the vector dimension /= 3, rc=',rc - exit + write(0,*) 'ERROR, 3D the vector dimension /= 3, rc=',rc + call ESMF_Finalize(endflag=ESMF_END_ABORT) endif ! Get the _FillValue from the field attribute if exists call ESMF_AttributeGet(fcstField(ifld), convention="NetCDF", purpose="FV3", & @@ -2207,8 +2176,8 @@ subroutine mask_fields(file_bundle,rc) line=__LINE__, file=__FILE__)) return ! bail out if( ubound(vect3dPtr2dr4,1)-lbound(vect3dPtr2dr4,1)+1 /= 3 ) then rc=991 - print *,'ERROR, 2D the vector dimension /= 3, rc=',rc - exit + write(0,*) 'ERROR, 2D the vector dimension /= 3, rc=',rc + call ESMF_Finalize(endflag=ESMF_END_ABORT) endif ! Get the _FillValue from the field attribute if exists call ESMF_AttributeGet(fcstField(ifld), convention="NetCDF", purpose="FV3", & @@ -2318,6 +2287,7 @@ subroutine mask_fields(file_bundle,rc) endif enddo ! + deallocate(maskwrt) deallocate(fcstField) rc = 0 @@ -3346,12 +3316,12 @@ subroutine splat4(idrt,jmax,aslat) 121.737742088d0, 124.879308913d0, 128.020877005d0, 131.162446275d0, & 134.304016638d0, 137.445588020d0, 140.587160352d0, 143.728733573d0, & 146.870307625d0, 150.011882457d0, 153.153458019d0, 156.295034268d0 / - real(8) :: dlt,d1=1.d0 - integer :: jhe,jho,j0=0 + real(8) :: dlt + integer :: jhe,jho ! real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8),parameter :: C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8) r - integer jh,js,n,j + integer jh,n,j ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! GAUSSIAN LATITUDES IF(IDRT.EQ.4) THEN @@ -3456,12 +3426,12 @@ subroutine splat8(idrt,jmax,aslat) 121.737742088d0, 124.879308913d0, 128.020877005d0, 131.162446275d0, & 134.304016638d0, 137.445588020d0, 140.587160352d0, 143.728733573d0, & 146.870307625d0, 150.011882457d0, 153.153458019d0, 156.295034268d0 / - real(8) :: dlt,d1=1.d0 - integer(4) :: jhe,jho,j0=0 + real(8) :: dlt + integer(4) :: jhe,jho ! real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8),parameter :: C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8) r - integer jh,js,n,j + integer jh,n,j ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! GAUSSIAN LATITUDES IF(IDRT.EQ.4) THEN @@ -3611,7 +3581,7 @@ subroutine lambert(stlat1,stlat2,c_lat,c_lon,glon,glat,x,y,inv) ! inv == 1 (glon,glat) ---> (x,y) lat/lon to grid ! inv == -1 (x,y) ---> (glon,glat) grid to lat/lon - real(ESMF_KIND_R8) :: en,f,rho,rho0, dlon, theta, xp, yp + real(ESMF_KIND_R8) :: en,f,rho,rho0, dlon, theta IF (stlat1 == stlat2) THEN en=sin(stlat1*dtor) @@ -3653,7 +3623,7 @@ subroutine get_outfile(nfl, filename, outfile_name,noutfile) character(*), intent(inout) :: outfile_name(:) integer, intent(inout) :: noutfile - integer :: i,j,n,idx + integer :: i,j,n logical :: found ! noutfile = 0 diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 08079d9c9..c0adaa0a5 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -368,7 +368,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & avgetrans, avgesnow, avgprec_cont, avgcprate_cont,& avisbeamswin, avisdiffswin, airbeamswin, airdiffswin, & alwoutc, alwtoac, aswoutc, aswtoac, alwinc, aswinc,& - avgpotevp, snoavg, ti, si, cuppt + avgpotevp, snoavg, ti, si, cuppt, fdnsst use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & @@ -505,13 +505,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! GFS does not have surface specific humidity ! inst sensible heat flux ! inst latent heat flux -!$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) +!$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths,fdnsst) do j=jsta,jend do i=1,im qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL ths(i,j) = SPVAL + fdnsst(i,j) = SPVAL enddo enddo @@ -917,6 +918,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo endif + ! foundation temperature + if(trim(fieldname)=='tref') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,fdnsst) + do j=jsta,jend + do i=ista, iend + if (arrayr42d(i,j) /= spval) then + fdnsst(i,j) = arrayr42d(i,j) + endif + enddo + enddo + endif + ! convective precip in m per physics time step if(trim(fieldname)=='cpratb_ave') then !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) diff --git a/io/post_regional.F90 b/io/post_regional.F90 index 44ea99b2e..a42e10475 100644 --- a/io/post_regional.F90 +++ b/io/post_regional.F90 @@ -220,7 +220,7 @@ end subroutine post_run_regional ! !----------------------------------------------------------------------- ! - subroutine post_getattr_regional(wrt_int_state) + subroutine post_getattr_regional(wrt_int_state,grid_id) ! use esmf use ctlblk_mod, only: im, jm, mpi_comm_comp,gdsdegr,spval @@ -236,6 +236,7 @@ subroutine post_getattr_regional(wrt_int_state) implicit none ! type(wrt_internal_state),intent(inout) :: wrt_int_state + integer, intent(in) :: grid_id ! ! local variable integer i,j,k,n,kz, attcount, nfb @@ -254,92 +255,92 @@ subroutine post_getattr_regional(wrt_int_state) fldbundle = wrt_int_state%wrtFB(nfb) ! set grid spec: -! if(mype==0) print*,'in post_getattr_lam,output_grid=',trim(output_grid),'nfb=',nfb +! if(mype==0) print*,'in post_getattr_lam,output_grid=',trim(output_grid(grid_id)),'nfb=',nfb ! if(mype==0) print*,'in post_getattr_lam, lon1=',lon1,lon2,lat1,lat2,dlon,dlat gdsdegr = 1000000. - if(trim(output_grid) == 'regional_latlon') then + if(trim(output_grid(grid_id)) == 'regional_latlon') then MAPTYPE=0 gridtype='A' - if( lon1<0 ) then - lonstart = nint((lon1+360.)*gdsdegr) + if( lon1(grid_id)<0 ) then + lonstart = nint((lon1(grid_id)+360.)*gdsdegr) else - lonstart = nint(lon1*gdsdegr) + lonstart = nint(lon1(grid_id)*gdsdegr) endif - if( lon2<0 ) then - lonlast = nint((lon2+360.)*gdsdegr) + if( lon2(grid_id)<0 ) then + lonlast = nint((lon2(grid_id)+360.)*gdsdegr) else - lonlast = nint(lon2*gdsdegr) + lonlast = nint(lon2(grid_id)*gdsdegr) endif - latstart = nint(lat1*gdsdegr) - latlast = nint(lat2*gdsdegr) + latstart = nint(lat1(grid_id)*gdsdegr) + latlast = nint(lat2(grid_id)*gdsdegr) - dxval = dlon*gdsdegr - dyval = dlat*gdsdegr + dxval = dlon(grid_id)*gdsdegr + dyval = dlat(grid_id)*gdsdegr ! if(mype==0) print*,'lonstart,latstart,dyval,dxval', & ! lonstart,lonlast,latstart,latlast,dyval,dxval - else if(trim(output_grid) == 'lambert_conformal') then + else if(trim(output_grid(grid_id)) == 'lambert_conformal') then MAPTYPE=1 GRIDTYPE='A' - if( cen_lon<0 ) then - cenlon = nint((cen_lon+360.)*gdsdegr) + if( cen_lon(grid_id)<0 ) then + cenlon = nint((cen_lon(grid_id)+360.)*gdsdegr) else - cenlon = nint(cen_lon*gdsdegr) + cenlon = nint(cen_lon(grid_id)*gdsdegr) endif - cenlat = cen_lat*gdsdegr - if( lon1<0 ) then - lonstart = nint((lon1+360.)*gdsdegr) + cenlat = cen_lat(grid_id)*gdsdegr + if( lon1(grid_id)<0 ) then + lonstart = nint((lon1(grid_id)+360.)*gdsdegr) else - lonstart = nint(lon1*gdsdegr) + lonstart = nint(lon1(grid_id)*gdsdegr) endif - latstart = nint(lat1*gdsdegr) + latstart = nint(lat1(grid_id)*gdsdegr) - truelat1 = nint(stdlat1*gdsdegr) - truelat2 = nint(stdlat2*gdsdegr) + truelat1 = nint(stdlat1(grid_id)*gdsdegr) + truelat2 = nint(stdlat2(grid_id)*gdsdegr) - if(dxin atm_int_state - call ESMF_GridCompSetInternalState(fcst_comp, wrap, rc) + call ESMF_VMGetCurrent(vm=vm,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! - call ESMF_VMGetCurrent(vm=VM,rc=RC) - call ESMF_VMGet(vm=VM, localPet=mype, mpiCommunicator=fcst_mpi_comm, & + + call ESMF_VMGet(vm=vm, localPet=mype, mpiCommunicator=fcst_mpi_comm, & petCount=fcst_ntasks, rc=rc) - if (mype == 0) write(0,*)'in fcst comp init, fcst_ntasks=',fcst_ntasks -! + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (mype == 0) write(*,*)'in fcst comp init, fcst_ntasks=',fcst_ntasks + CF = ESMF_ConfigCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_ConfigLoadFile(config=CF ,filename='model_configure' ,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! + num_restart_interval = ESMF_ConfigGetLen(config=CF, label ='restart_interval:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(mype == 0) print *,'af nems config,num_restart_interval=',num_restart_interval + if (mype == 0) print *,'af nems config,num_restart_interval=',num_restart_interval if (num_restart_interval<=0) num_restart_interval = 1 allocate(restart_interval(num_restart_interval)) restart_interval = 0 call ESMF_ConfigGetAttribute(CF,valueList=restart_interval,label='restart_interval:', & - count=num_restart_interval, rc=rc) + count=num_restart_interval, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(mype == 0) print *,'af nems config,restart_interval=',restart_interval - + if (mype == 0) print *,'af nems config,restart_interval=',restart_interval ! call fms_init(fcst_mpi_comm) call mpp_init() initClock = mpp_clock_id( 'Initialization' ) call mpp_clock_begin (initClock) !nesting problem - call fms_init call constants_init call sat_vapor_pres_init -! - if ( force_date_from_configure ) then - - select case( uppercase(trim(calendar)) ) - case( 'JULIAN' ) - calendar_type = JULIAN - case( 'GREGORIAN' ) - calendar_type = GREGORIAN - 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, 'fcst_initialize: calendar must be one of '// & - 'JULIAN|GREGORIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) - end select - endif -! - call set_calendar_type (calendar_type ) + select case( uppercase(trim(calendar)) ) + case( 'JULIAN' ) + calendar_type = JULIAN + case( 'GREGORIAN' ) + calendar_type = GREGORIAN + 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, 'fcst_initialize: calendar must be one of '// & + 'JULIAN|GREGORIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) + end select + + call set_calendar_type (calendar_type) ! !----------------------------------------------------------------------- !*** set atmos time @@ -293,61 +443,105 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call ESMF_ClockGet(clock, CurrTime=CurrTime, StartTime=StartTime, & StopTime=StopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - RunDuration = StopTime - CurrTime date_init = 0 call ESMF_TimeGet (StartTime, & YY=date_init(1), MM=date_init(2), DD=date_init(3), & - H=date_init(4), M =date_init(5), S =date_init(6), RC=rc) + H=date_init(4), M =date_init(5), S =date_init(6), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if ( date_init(1) == 0 ) date_init = date - atm_int_state%Time_init = set_date (date_init(1), date_init(2), date_init(3), & - date_init(4), date_init(5), date_init(6)) - if(mype==0) write(*,'(A,6I5)') 'StartTime=',date_init + Time_init = set_date (date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6)) + if (mype == 0) write(*,'(A,6I5)') 'StartTime=',date_init date=0 call ESMF_TimeGet (CurrTime, & YY=date(1), MM=date(2), DD=date(3), & - H=date(4), M =date(5), S =date(6), RC=rc ) + H=date(4), M =date(5), S =date(6), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(mype==0) write(*,'(A,6I5)') 'CurrTime =',date - - atm_int_state%Time_atmos = set_date (date(1), date(2), date(3), & - date(4), date(5), date(6)) + Time = set_date (date(1), date(2), date(3), & + date(4), date(5), date(6)) + if (mype == 0) write(*,'(A,6I5)') 'CurrTime =',date date_end=0 call ESMF_TimeGet (StopTime, & YY=date_end(1), MM=date_end(2), DD=date_end(3), & - H=date_end(4), M =date_end(5), S =date_end(6), RC=rc ) + H=date_end(4), M =date_end(5), S =date_end(6), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if ( date_end(1) == 0 ) date_end = date - atm_int_state%Time_end = set_date (date_end(1), date_end(2), date_end(3), & - date_end(4), date_end(5), date_end(6)) - if(mype==0) write(*,'(A,6I5)') 'StopTime =',date_end -! - call diag_manager_set_time_end(atm_int_state%Time_end) -! - CALL ESMF_TimeIntervalGet(RunDuration, S=Run_length, RC=rc) + Time_end = set_date (date_end(1), date_end(2), date_end(3), & + date_end(4), date_end(5), date_end(6)) + if (mype == 0) write(*,'(A,6I5)') 'StopTime =',date_end + +!------------------------------------------------------------------------ +! If this is a restarted run ('INPUT/coupler.res' file exists), +! compare date and date_init to the values in 'coupler.res' + + if (mype == 0) then + inquire(FILE='INPUT/coupler.res', EXIST=fexist) + if (fexist) then ! file exists, this is a restart run + + call ESMF_UtilIOUnitGet(unit=io_unit, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + open(unit=io_unit, file='INPUT/coupler.res', status='old', action='read', err=998) + read (io_unit,*,err=999) calendar_type_res + read (io_unit,*) date_init_res + read (io_unit,*) date_res + close(io_unit) + + if(date_res(1) == 0 .and. date_init_res(1) /= 0) date_res = date_init_res + + if(mype == 0) write(*,'(A,6(I4))') 'INPUT/coupler.res: date_init=',date_init_res + if(mype == 0) write(*,'(A,6(I4))') 'INPUT/coupler.res: date =',date_res + + if (calendar_type /= calendar_type_res) then + write(0,'(A)') 'fcst_initialize ERROR: calendar_type /= calendar_type_res' + write(0,'(A,6(I4))')' calendar_type = ', calendar_type + write(0,'(A,6(I4))')' calendar_type_res = ', calendar_type_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + + if (.not. ALL(date_init.EQ.date_init_res)) then + write(0,'(A)') 'fcst_initialize ERROR: date_init /= date_init_res' + write(0,'(A,6(I4))')' date_init = ', date_init + write(0,'(A,6(I4))')' date_init_res = ', date_init_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + + if (.not. ALL(date.EQ.date_res)) then + write(0,'(A)') 'fcst_initialize ERROR: date /= date_res' + write(0,'(A,6(I4))')' date = ', date + write(0,'(A,6(I4))')' date_res = ', date_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + + 999 continue + 998 continue + + endif ! fexist + endif ! mype == 0 + + RunDuration = StopTime - CurrTime + + CALL ESMF_TimeIntervalGet(RunDuration, S=Run_length, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! call diag_manager_init (TIME_INIT=date) - call diag_manager_set_time_end(atm_int_state%Time_end) + call diag_manager_set_time_end(Time_end) ! - atm_int_state%Time_step_atmos = set_time (dt_atmos,0) - atm_int_state%num_atmos_calls = Run_length / dt_atmos - atm_int_state%Time_atstart = atm_int_state%Time_atmos - if (mype == 0) write(0,*)'num_atmos_calls=',atm_int_state%num_atmos_calls,'time_init=', & - date_init,'time_atmos=',date,'time_end=',date_end,'dt_atmos=',dt_atmos, & + Time_step = set_time (dt_atmos,0) + num_atmos_calls = Run_length / dt_atmos + if (mype == 0) write(*,*)'num_atmos_calls=',num_atmos_calls,'time_init=', & + date_init,'time=',date,'time_end=',date_end,'dt_atmos=',dt_atmos, & 'Run_length=',Run_length ! set up forecast time array that controls when to write out restart files frestart = 0 - call get_time(atm_int_state%Time_end - atm_int_state%Time_init,total_inttime) + call get_time(Time_end - Time_init, total_inttime) ! set iau offset time - atm_int_state%Atm%iau_offset = iau_offset + Atmos%iau_offset = iau_offset if(iau_offset > 0 ) then iautime = set_time(iau_offset * 3600, 0) endif @@ -359,19 +553,19 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if(freq_restart) then if(restart_interval(1) >= 0) then tmpvar = restart_interval(1) * 3600 - atm_int_state%Time_step_restart = set_time (tmpvar, 0) + Time_step_restart = set_time (tmpvar, 0) if(iau_offset > 0 ) then - atm_int_state%Time_restart = atm_int_state%Time_init + iautime + atm_int_state%Time_step_restart + Time_restart = Time_init + iautime + Time_step_restart frestart(1) = tmpvar + iau_offset *3600 else - atm_int_state%Time_restart = atm_int_state%Time_init + atm_int_state%Time_step_restart + Time_restart = Time_init + Time_step_restart frestart(1) = tmpvar endif if(restart_interval(1) > 0) then i = 2 - do while ( atm_int_state%Time_restart < atm_int_state%Time_end ) + do while ( Time_restart < Time_end ) frestart(i) = frestart(i-1) + tmpvar - atm_int_state%Time_restart = atm_int_state%Time_restart + atm_int_state%Time_step_restart + Time_restart = Time_restart + Time_step_restart i = i + 1 enddo endif @@ -396,9 +590,9 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if ( ANY(frestart(:) == total_inttime) ) restart_endfcst = .true. if (mype == 0) print *,'frestart=',frestart(1:10)/3600, 'restart_endfcst=',restart_endfcst, & 'total_inttime=',total_inttime -! if there is restart writing during integration - atm_int_state%intrm_rst = 0 - if (frestart(1)>0) atm_int_state%intrm_rst = 1 +! if there is restart writing during integration + intrm_rst = 0 + if (frestart(1)>0) intrm_rst = 1 ! !----- write time stamps (for start time and end time) ------ @@ -412,14 +606,11 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! !------ initialize component models ------ - call atmos_model_init (atm_int_state%Atm, atm_int_state%Time_init, & - atm_int_state%Time_atmos, atm_int_state%Time_step_atmos) + call atmos_model_init (Atmos, Time_init, Time, Time_step) ! inquire(FILE='data_table', EXIST=fexist) if (fexist) then - call data_override_init ( ) ! Atm_domain_in = Atm%domain, & - ! Ice_domain_in = Ice%domain, & - ! Land_domain_in = Land%domain ) + call data_override_init() endif !----------------------------------------------------------------------- !---- open and close dummy file in restart dir to check if dir exists -- @@ -429,10 +620,8 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call mpp_close(unit, MPP_DELETE) endif ! -! !----------------------------------------------------------------------- -!*** create grid for output fields -!*** first try: Create cubed sphere grid from file +!*** create grid for output fields, using FV3 parameters !----------------------------------------------------------------------- ! call mpp_error(NOTE, 'before create fcst grid') @@ -443,157 +632,102 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call read_data("INPUT/grid_spec.nc", "atm_mosaic_file", gridfile) endif - if (mpp_pe() == mpp_root_pe()) & - write(*, *) 'create fcst grid: mype,regional,nested=',mype,atm_int_state%Atm%regional,atm_int_state%Atm%nested - - ! regional-only without nests - if( atm_int_state%Atm%regional .and. .not. atm_int_state%Atm%nested ) then - - call atmosphere_control_data (isc, iec, jsc, jec, nlev) - - domain = atm_int_state%Atm%domain - fcstNpes = atm_int_state%Atm%layout(1)*atm_int_state%Atm%layout(2) - allocate(isl(fcstNpes), iel(fcstNpes), jsl(fcstNpes), jel(fcstNpes)) - allocate(deBlockList(2,2,fcstNpes)) - call mpp_get_compute_domains(domain,xbegin=isl,xend=iel,ybegin=jsl,yend=jel) - do n=1,fcstNpes - deBlockList(:,1,n) = (/ isl(n),iel(n) /) - deBlockList(:,2,n) = (/ jsl(n),jel(n) /) - end do - delayout = ESMF_DELayoutCreate(petMap=(/(i,i=0,fcstNpes-1)/), rc=rc); ESMF_ERR_ABORT(rc) - distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), & - maxIndex=(/atm_int_state%Atm%mlon,atm_int_state%Atm%mlat/), & - delayout=delayout, & - deBlockList=deBlockList, rc=rc); ESMF_ERR_ABORT(rc) - - fcstGrid = ESMF_GridCreateNoPeriDim(regDecomp=(/atm_int_state%Atm%layout(1),atm_int_state%Atm%layout(2)/), & - minIndex=(/1,1/), & - maxIndex=(/atm_int_state%Atm%mlon,atm_int_state%Atm%mlat/), & - gridAlign=(/-1,-1/), & - decompflag=(/ESMF_DECOMP_SYMMEDGEMAX,ESMF_DECOMP_SYMMEDGEMAX/), & - name="fcst_grid", & - indexflag=ESMF_INDEX_DELOCAL, & - rc=rc); ESMF_ERR_ABORT(rc) - - ! add and define "center" coordinate values - call ESMF_GridAddCoord(fcstGrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc); ESMF_ERR_ABORT(rc) - call ESMF_GridGetCoord(fcstGrid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=glonPtr, rc=rc); ESMF_ERR_ABORT(rc) - call ESMF_GridGetCoord(fcstGrid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=glatPtr, rc=rc); ESMF_ERR_ABORT(rc) + ngrids = Atmos%ngrids + mygrid = Atmos%mygrid + allocate(grid_number_on_all_pets(fcst_ntasks)) + call mpi_allgather(mygrid, 1, MPI_INTEGER, & + grid_number_on_all_pets, 1, MPI_INTEGER, & + fcst_mpi_comm, rc) + + allocate (fcstGrid(ngrids),fcstGridComp(ngrids)) + do n=1,ngrids + + pelist => null() + call atmos_model_get_nth_domain_info(n, layout, nx, ny, pelist) + call ESMF_VMBroadcast(vm, bcstData=layout, count=2, rootPet=pelist(1), rc=rc); ESMF_ERR_ABORT(rc) + + if (n==1) then + ! on grid==1 (top level parent) determine if the domain is global or regional + top_parent_is_global = .true. + if(mygrid==1) then + if (Atmos%regional) top_parent_is_global = .false. + endif + call mpi_bcast(top_parent_is_global, 1, MPI_LOGICAL, 0, fcst_mpi_comm, rc) + endif - do j = jsc, jec - do i = isc, iec - glonPtr(i-isc+1,j-jsc+1) = atm_int_state%Atm%lon(i-isc+1,j-jsc+1) * dtor - glatPtr(i-isc+1,j-jsc+1) = atm_int_state%Atm%lat(i-isc+1,j-jsc+1) * dtor - enddo - enddo + if (n==1 .and. top_parent_is_global) then - ! add and define "corner" coordinate values - call ESMF_GridAddCoord(fcstGrid, staggerLoc=ESMF_STAGGERLOC_CORNER, & - rc=rc); ESMF_ERR_ABORT(rc) - call ESMF_GridGetCoord(fcstGrid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CORNER, & - totalLBound=tlb, totalUBound=tub, & - farrayPtr=glonPtr, rc=rc); ESMF_ERR_ABORT(rc) - glonPtr(tlb(1):tub(1),tlb(2):tub(2)) = & - atm_int_state%Atm%lon_bnd(tlb(1):tub(1),tlb(2):tub(2)) * dtor - call ESMF_GridGetCoord(fcstGrid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CORNER, & - totalLBound=tlb, totalUBound=tub, & - farrayPtr=glatPtr, rc=rc); ESMF_ERR_ABORT(rc) - glatPtr(tlb(1):tub(1),tlb(2):tub(2)) = & - atm_int_state%Atm%lat_bnd(tlb(1):tub(1),tlb(2):tub(2)) * dtor - - call mpp_error(NOTE, 'after create fcst grid for regional-only') - - else ! not regional only - - if (.not. atm_int_state%Atm%regional .and. .not. atm_int_state%Atm%nested ) then !! global only - - do tl=1,6 - decomptile(1,tl) = atm_int_state%Atm%layout(1) - decomptile(2,tl) = atm_int_state%Atm%layout(2) - decompflagPTile(:,tl) = (/ESMF_DECOMP_SYMMEDGEMAX,ESMF_DECOMP_SYMMEDGEMAX/) - enddo - fcstGrid = ESMF_GridCreateMosaic(filename="INPUT/"//trim(gridfile), & - regDecompPTile=decomptile,tileFilePath="INPUT/", & - decompflagPTile=decompflagPTile, & - staggerlocList=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), & - name='fcst_grid', rc=rc) + fcstGridComp(n) = ESMF_GridCompCreate(name="global", petList=pelist, rc=rc); ESMF_ERR_ABORT(rc) + + call ESMF_InfoGetFromHost(fcstGridComp(n), info=info, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_InfoSet(info, key="layout", values=layout, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_InfoSet(info, key="tilesize", value=Atmos%mlon, rc=rc); ESMF_ERR_ABORT(rc) + + call ESMF_GridCompSetServices(fcstGridComp(n), SetServicesNest, userrc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + + else - call mpp_error(NOTE, 'after create fcst grid for global-only with INPUT/'//trim(gridfile)) + allocate(petListNest(layout(1)*layout(2))) + k=pelist(1) + do j=1,layout(2) + do i=1,layout(1) + petListNest(k-pelist(1)+1) = k + k = k + 1 + end do + end do - else !! global-nesting or regional-nesting + fcstGridComp(n) = ESMF_GridCompCreate(name="nest", petList=petListNest, rc=rc); ESMF_ERR_ABORT(rc) - if (mype==0) TileLayout = atm_int_state%Atm%layout - call ESMF_VMBroadcast(vm, bcstData=TileLayout, count=2, & - rootPet=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_InfoGetFromHost(fcstGridComp(n), info=info, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_InfoSet(info, key="layout", values=layout, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_InfoSet(info, key="nx", value=nx, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_InfoSet(info, key="ny", value=ny, rc=rc); ESMF_ERR_ABORT(rc) - if (mype==0) npes(1) = mpp_npes() - call ESMF_VMBroadcast(vm, bcstData=npes, count=1, & - rootPet=0, rc=rc) + call ESMF_GridCompSetServices(fcstGridComp(n), SetServicesNest, userrc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - if ( npes(1) == TileLayout(1) * TileLayout(2) * 6 ) then - ! global-nesting - nestRootPet = npes(1) - gridfile="grid.nest02.tile7.nc" - else if ( npes(1) == TileLayout(1) * TileLayout(2) ) then - ! regional-nesting - nestRootPet = npes(1) - gridfile="grid.nest02.tile2.nc" - else - call mpp_error(FATAL, 'Inconsistent nestRootPet and Atm%layout') - endif - if (mype == nestRootPet) then - if (nestRootPet /= atm_int_state%Atm%pelist(1)) then - write(0,*)'error in fcst_initialize: nestRootPet /= atm_int_state%Atm%pelist(1)' - write(0,*)'error in fcst_initialize: nestRootPet = ',nestRootPet - write(0,*)'error in fcst_initialize: atm_int_state%Atm%pelist(1) = ',atm_int_state%Atm%pelist(1) - ESMF_ERR_ABORT(100) - endif - endif + deallocate(petListNest) - ! nest rootPet shares peList with others - if (mype == nestRootPet) peListSize(1) = size(atm_int_state%Atm%pelist) - call ESMF_VMBroadcast(vm, bcstData=peListSize, count=1, rootPet=nestRootPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + end if - ! nest rootPet shares layout with others - if (mype == nestRootPet) regDecomp = atm_int_state%Atm%layout - call ESMF_VMBroadcast(vm, bcstData=regDecomp, count=2, rootPet=nestRootPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_GridCompIsPetLocal(fcstGridComp(n), rc=rc)) then + call ESMF_GridCompGet(fcstGridComp(n), grid=fcstGrid(n), rc=rc); ESMF_ERR_ABORT(rc) - ! prepare petMap variable - allocate(petMap(peListSize(1))) - if (mype == nestRootPet) petMap = atm_int_state%Atm%pelist - ! do the actual broadcast of the petMap - call ESMF_VMBroadcast(vm, bcstData=petMap, count=peListSize(1), rootPet=nestRootPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridAddCoord(fcstGrid(n), staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc); ESMF_ERR_ABORT(rc) + call ESMF_GridAddCoord(fcstGrid(n), staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc); ESMF_ERR_ABORT(rc) - ! create the DELayout that maps DEs to the PETs in the petMap - delayout = ESMF_DELayoutCreate(petMap=petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! define "center" coordinate values + call ESMF_GridGetCoord(fcstGrid(n), coordDim=1, staggerLoc=ESMF_STAGGERLOC_CENTER, & + totalLBound=tlb, totalUBound=tub, & + farrayPtr=glonPtr, rc=rc); ESMF_ERR_ABORT(rc) + glonPtr(tlb(1):tub(1),tlb(2):tub(2)) = Atmos%lon(tlb(1):tub(1),tlb(2):tub(2)) - ! create the nest Grid by reading it from file but use DELayout - fcstGrid = ESMF_GridCreate(filename="INPUT/"//trim(gridfile), & - fileformat=ESMF_FILEFORMAT_GRIDSPEC, regDecomp=regDecomp, & - decompflag=(/ESMF_DECOMP_SYMMEDGEMAX,ESMF_DECOMP_SYMMEDGEMAX/), & - delayout=delayout, isSphere=.false., indexflag=ESMF_INDEX_DELOCAL, & - rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridGetCoord(fcstGrid(n), coordDim=2, staggerLoc=ESMF_STAGGERLOC_CENTER, & + totalLBound=tlb, totalUBound=tub, & + farrayPtr=glatPtr, rc=rc); ESMF_ERR_ABORT(rc) + glatPtr(tlb(1):tub(1),tlb(2):tub(2)) = Atmos%lat(tlb(1):tub(1),tlb(2):tub(2)) - call mpp_error(NOTE, 'after create fcst grid with INPUT/'//trim(gridfile)) + ! define "corner" coordinate values + call ESMF_GridGetCoord(fcstGrid(n), coordDim=1, staggerLoc=ESMF_STAGGERLOC_CORNER, & + totalLBound=tlb, totalUBound=tub, & + farrayPtr=glonPtr, rc=rc); ESMF_ERR_ABORT(rc) + glonPtr(tlb(1):tub(1),tlb(2):tub(2)) = Atmos%lon_bnd(tlb(1):tub(1),tlb(2):tub(2)) - endif + call ESMF_GridGetCoord(fcstGrid(n), coordDim=2, staggerLoc=ESMF_STAGGERLOC_CORNER, & + totalLBound=tlb, totalUBound=tub, & + farrayPtr=glatPtr, rc=rc); ESMF_ERR_ABORT(rc) + glatPtr(tlb(1):tub(1),tlb(2):tub(2)) = Atmos%lat_bnd(tlb(1):tub(1),tlb(2):tub(2)) + end if ! IsPetLocal - endif + end do ! !! FIXME - if ( .not. atm_int_state%Atm%nested ) then !! global only - call addLsmask2grid(fcstGrid, rc=rc) + if ( .not. Atmos%nested ) then !! global only + call addLsmask2grid(fcstGrid(mygrid), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! print *,'call addLsmask2grid after fcstGrid, rc=',rc endif @@ -607,7 +741,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! ! Write grid to netcdf file if( cplprint_flag ) then - call wrt_fcst_grid(fcstGrid, "diagnostic_FV3_fcstGrid.nc", & + call wrt_fcst_grid(fcstGrid(mygrid), "diagnostic_FV3_fcstGrid.nc", & regridArea=.TRUE., rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif @@ -621,15 +755,39 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) name="gridfile", value=trim(gridfile), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return +! Add total number of domains(grids) Attribute to the exportState + call ESMF_AttributeAdd(exportState, convention="NetCDF", purpose="FV3", & + attrList=(/"ngrids"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & + name="ngrids", value=ngrids, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + +! Add top_parent_is_global Attribute to the exportState + call ESMF_AttributeAdd(exportState, convention="NetCDF", purpose="FV3", & + attrList=(/"top_parent_is_global"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & + name="top_parent_is_global", value=top_parent_is_global, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! Add dimension Attributes to Grid - call ESMF_AttributeAdd(fcstGrid, convention="NetCDF", purpose="FV3", & + do n=1,ngrids + if (ESMF_GridCompIsPetLocal(fcstGridComp(n), rc=rc)) then + + call ESMF_AttributeAdd(fcstGrid(n), convention="NetCDF", purpose="FV3", & attrList=(/"ESMF:gridded_dim_labels"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_AttributeSet(fcstGrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeSet(fcstGrid(n), convention="NetCDF", purpose="FV3", & name="ESMF:gridded_dim_labels", valueList=(/"grid_xt", "grid_yt"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + endif + end do + ! Add time Attribute to the exportState call ESMF_AttributeAdd(exportState, convention="NetCDF", purpose="FV3", & attrList=(/ "time ", & @@ -653,11 +811,10 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) dateS="hours since "//dateSY//'-'//dateSM//'-'//dateSD//' '//dateSH//':'// & dateSN//":"//dateSS - if (mype == 0) write(0,*)'dateS=',trim(dateS),'date_init=',date_init + if (mype == 0) write(*,*)'dateS=',trim(dateS),'date_init=',date_init call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:units", value=trim(dateS), rc=rc) -! name="time:units", value="hours since 2016-10-03 00:00:00", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & @@ -679,49 +836,73 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! Create FieldBundle for Fields that need to be regridded bilinear if( quilting ) then + allocate(fieldbundle(ngrids)) + nbdlphys = 2 + allocate(fieldbundlephys(nbdlphys,ngrids)) + + do n=1,ngrids + bundle_grid='' + if (ngrids > 1 .and. n >= 2) then + write(bundle_grid,'(A5,I2.2,A1)') '.nest', n, '.' + endif + do i=1,num_files ! - name_FB = filename_base(i) + tempState = ESMF_StateCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + name_FB = trim(filename_base(i)) // trim(bundle_grid) ! if( i==1 ) then ! for dyn name_FB1 = trim(name_FB)//'_bilinear' - fieldbundle = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) - if (mype == 0) write(0,*)'af create fcst fieldbundle, name=',trim(name_FB),'rc=',rc + fieldbundle(n) = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeAdd(fieldbundle(n), convention="NetCDF", purpose="FV3", & + attrList=(/"grid_id"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeSet(fieldbundle(n), convention="NetCDF", purpose="FV3", & + name="grid_id", value=n, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call fv_dyn_bundle_setup(atm_int_state%Atm%axes, & - fieldbundle, fcstGrid, quilting, rc=rc) + call ESMF_StateAdd(tempState, (/fieldbundle(n)/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! Add the field to the importState so parent can connect to it - call ESMF_StateAdd(exportState, (/fieldbundle/), rc=rc) + call ESMF_GridCompInitialize(fcstGridComp(n), importState=tempState,& + exportState=exportState, phase=1, userrc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return else if( i==2 ) then ! for phys - nbdlphys = 2 - allocate(fieldbundlephys(nbdlphys)) do j=1, nbdlphys if( j==1 ) then name_FB1 = trim(name_FB)//'_nearest_stod' else name_FB1 = trim(name_FB)//'_bilinear' endif - fieldbundlephys(j) = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) - if (mype == 0) write(0,*)'af create fcst fieldbundle, name=',trim(name_FB1),'rc=',rc + fieldbundlephys(j,n) = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - enddo -! - call fv_phys_bundle_setup(atm_int_state%Atm%diag, atm_int_state%Atm%axes, & - fieldbundlephys, fcstGrid, quilting, nbdlphys) -! - ! Add the field to the importState so parent can connect to it - do j=1,nbdlphys - call ESMF_StateAdd(exportState, (/fieldbundlephys(j)/), rc=rc) + + call ESMF_AttributeAdd(fieldbundlephys(j,n), convention="NetCDF", purpose="FV3", & + attrList=(/"grid_id"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeSet(fieldbundlephys(j,n), convention="NetCDF", purpose="FV3", & + name="grid_id", value=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_StateAdd(tempState, (/fieldbundlephys(j,n)/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return enddo + call ESMF_GridCompInitialize(fcstGridComp(n), importState=tempState,& + exportState=exportState, phase=2, userrc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + else write(0,*)' unknown name_FB ', trim(name_FB) @@ -729,7 +910,11 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) endif ! - enddo + call ESMF_StateDestroy(tempState, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + enddo ! num_files + enddo ! ngrids !end qulting endif @@ -737,16 +922,8 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call get_atmos_model_ungridded_dim(nlev=numLevels, & nsoillev=numSoilLayers, & ntracers=numTracers) -! -!----------------------------------------------------------------------- -! - IF(rc /= ESMF_SUCCESS) THEN - WRITE(0,*)"FAIL: Fcst_Initialize." -! ELSE -! WRITE(0,*)"PASS: Fcst_Initialize." - ENDIF -! - if (mype == 0) write(0,*)'in fcst,init total time: ', mpi_wtime() - timeis + + if (mype == 0) write(*,*)'fcst_initialize total time: ', mpi_wtime() - timeis ! !----------------------------------------------------------------------- ! @@ -767,30 +944,22 @@ subroutine fcst_run_phase_1(fcst_comp, importState, exportState,clock,rc) type(ESMF_Clock) :: clock integer,intent(out) :: rc ! -!----------------------------------------------------------------------- !*** local variables ! - integer :: i,j, mype, na, date(6) - character(20) :: compname - - type(ESMF_Time) :: currtime + integer :: mype, na integer(kind=ESMF_KIND_I8) :: ntimestep_esmf - character(len=64) :: timestamp -! -!----------------------------------------------------------------------- -! - real(kind=8) :: mpi_wtime, tbeg1 + real(kind=8) :: mpi_wtime, tbeg1 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! tbeg1 = mpi_wtime() - rc = esmf_success + rc = ESMF_SUCCESS ! !----------------------------------------------------------------------- ! - call ESMF_GridCompGet(fcst_comp, name=compname, localpet=mype, rc=rc) + call ESMF_GridCompGet(fcst_comp, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! call ESMF_ClockGet(clock, advanceCount=NTIMESTEP_ESMF, rc=rc) @@ -801,31 +970,21 @@ subroutine fcst_run_phase_1(fcst_comp, importState, exportState,clock,rc) !----------------------------------------------------------------------- ! *** call fcst integration subroutines - call get_date (atm_int_state%Time_atmos, date(1), date(2), date(3), & - date(4), date(5), date(6)) - atm_int_state%Time_atmos = atm_int_state%Time_atmos + atm_int_state%Time_step_atmos - - call update_atmos_model_dynamics (atm_int_state%Atm) + call update_atmos_model_dynamics (Atmos) - call update_atmos_radiation_physics (atm_int_state%Atm) + call update_atmos_radiation_physics (Atmos) - call atmos_model_exchange_phase_1 (atm_int_state%Atm, rc=rc) + call atmos_model_exchange_phase_1 (Atmos, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -!----------------------------------------------------------------------- -! -! IF(RC /= ESMF_SUCCESS) THEN -! if(mype==0) WRITE(0,*)"FAIL: fcst_RUN" -! ELSE - if(mype==0) WRITE(*,*)"PASS: fcstRUN phase 1, na = ",na, ' time is ', mpi_wtime()-tbeg1 -! ENDIF + if (mype == 0) write(*,*)"PASS: fcstRUN phase 1, na = ",na, ' time is ', mpi_wtime()-tbeg1 ! !----------------------------------------------------------------------- ! end subroutine fcst_run_phase_1 ! !----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!####################################################################### !----------------------------------------------------------------------- ! subroutine fcst_run_phase_2(fcst_comp, importState, exportState,clock,rc) @@ -839,78 +998,78 @@ subroutine fcst_run_phase_2(fcst_comp, importState, exportState,clock,rc) type(ESMF_Clock) :: clock integer,intent(out) :: rc ! -!----------------------------------------------------------------------- !*** local variables ! - integer :: i,j, mype, na, date(6), seconds - character(20) :: compname - - type(time_type) :: restart_inctime - type(ESMF_Time) :: currtime + integer :: mype, na, date(6), seconds integer(kind=ESMF_KIND_I8) :: ntimestep_esmf character(len=64) :: timestamp -! -!----------------------------------------------------------------------- -! - real(kind=8) :: mpi_wtime, tbeg1 + integer :: unit + real(kind=8) :: mpi_wtime, tbeg1 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! tbeg1 = mpi_wtime() - rc = esmf_success + rc = ESMF_SUCCESS ! !----------------------------------------------------------------------- ! - call ESMF_GridCompGet(fcst_comp, name=compname, localpet=mype, rc=rc) + call ESMF_GridCompGet(fcst_comp, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! + call ESMF_ClockGet(clock, advanceCount=NTIMESTEP_ESMF, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return na = NTIMESTEP_ESMF - if (mype == 0) write(0,*)'in fcst run phase 2, na=',na ! !----------------------------------------------------------------------- ! *** call fcst integration subroutines - call atmos_model_exchange_phase_2 (atm_int_state%Atm, rc=rc) + call atmos_model_exchange_phase_2 (Atmos, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call update_atmos_model_state (atm_int_state%Atm, rc=rc) + call update_atmos_model_state (Atmos, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -!--- intermediate restart - if (atm_int_state%intrm_rst>0) then - if (na /= atm_int_state%num_atmos_calls-1) then - call get_time(atm_int_state%Time_atmos - atm_int_state%Time_init, seconds) + !--- intermediate restart + if (intrm_rst>0) then + if (na /= num_atmos_calls-1) then + call get_time(Atmos%Time - Atmos%Time_init, seconds) if (ANY(frestart(:) == seconds)) then - if (mype == 0) write(0,*)'write out restart at na=',na,' seconds=',seconds, & - 'integration lenght=',na*dt_atmos/3600. - timestamp = date_to_string (atm_int_state%Time_atmos) - call atmos_model_restart(atm_int_state%Atm, timestamp) + if (mype == 0) write(*,*)'write out restart at na=',na,' seconds=',seconds, & + 'integration lenght=',na*dt_atmos/3600. + + timestamp = date_to_string (Atmos%Time) + call atmos_model_restart(Atmos, timestamp) call write_stoch_restart_atm('RESTART/'//trim(timestamp)//'.atm_stoch.res.nc') - call wrt_atmres_timestamp(atm_int_state,timestamp) + !----- write restart file ------ + if (mpp_pe() == mpp_root_pe())then + call get_date (Atmos%Time, date(1), date(2), date(3), & + date(4), date(5), date(6)) + call mpp_open( unit, 'RESTART/'//trim(timestamp)//'.coupler.res', nohdrs=.TRUE. ) + write( unit, '(i6,8x,a)' )calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + write( unit, '(6i6,8x,a)' )date_init, & + 'Model start time: year, month, day, hour, minute, second' + write( unit, '(6i6,8x,a)' )date, & + 'Current model time: year, month, day, hour, minute, second' + call mpp_close(unit) + endif endif endif endif -! -!----------------------------------------------------------------------- -! -! IF(RC /= ESMF_SUCCESS) THEN -! if(mype==0) WRITE(0,*)"FAIL: fcst_RUN" -! ELSE - if(mype==0) WRITE(*,*)"PASS: fcstRUN phase 2, na = ",na, ' time is ', mpi_wtime()-tbeg1 -! ENDIF + + if (mype == 0) write(*,*)"PASS: fcstRUN phase 2, na = ",na, ' time is ', mpi_wtime()-tbeg1 ! !----------------------------------------------------------------------- ! end subroutine fcst_run_phase_2 ! !----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!####################################################################### !----------------------------------------------------------------------- ! subroutine fcst_finalize(fcst_comp, importState, exportState,clock,rc) @@ -919,45 +1078,33 @@ subroutine fcst_finalize(fcst_comp, importState, exportState,clock,rc) !*** finalize the forecast grid component. !----------------------------------------------------------------------- ! - type(ESMF_GridComp) :: fcst_comp - type(ESMF_State) :: importState, exportState - type(ESMF_Clock) :: clock - integer,intent(out) :: rc + type(ESMF_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer,intent(out) :: rc ! !*** local variables ! - integer :: unit - integer,dimension(6) :: date - - real(8) mpi_wtime, tfs, tfe + integer :: mype + integer :: unit + integer,dimension(6) :: date + real(kind=8) :: mpi_wtime, tbeg1 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! - tfs = mpi_wtime() - rc = ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** retrieve the fcst component's esmf internal state -!----------------------------------------------------------------------- -! - call ESMF_GridCompGetInternalState(fcst_comp, wrap, rc) - atm_int_state => wrap%ptr -! -!----------------------------------------------------------------------- -! - call atmos_model_end (atm_int_state%atm) -! -!*** check time versus expected ending time + tbeg1 = mpi_wtime() + rc = ESMF_SUCCESS - if (atm_int_state%Time_atmos /= atm_int_state%Time_end) & - call error_mesg ('program coupler', & - 'final time does not match expected ending time', WARNING) + call ESMF_GridCompGet(fcst_comp, localpet=mype, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call atmos_model_end (Atmos) !*** write restart file if( restart_endfcst ) then - call get_date (atm_int_state%Time_atmos, date(1), date(2), date(3), & + call get_date (Atmos%Time, date(1), date(2), date(3), & date(4), date(5), date(6)) call mpp_open( unit, 'RESTART/coupler.res', nohdrs=.TRUE. ) if (mpp_pe() == mpp_root_pe())then @@ -971,56 +1118,18 @@ subroutine fcst_finalize(fcst_comp, importState, exportState,clock,rc) endif call mpp_close(unit) endif -! - call diag_manager_end(atm_int_state%Time_atmos ) + + call diag_manager_end (Atmos%Time) call fms_end + + if (mype == 0) write(*,*)'fcst_finalize total time: ', mpi_wtime() - tbeg1 ! !----------------------------------------------------------------------- -! - IF(RC /= ESMF_SUCCESS)THEN - WRITE(0,*)'FAIL: Write_Finalize.' -! ELSE -! WRITE(0,*)'PASS: Write_Finalize.' - ENDIF -! - tfe = mpi_wtime() -! print *,'fms end time: ', tfe-tfs -!----------------------------------------------------------------------- ! end subroutine fcst_finalize ! !####################################################################### -!-- change name from coupler_res to wrt_res_stamp to avoid confusion, -!-- here we only write out atmos restart time stamp -! - subroutine wrt_atmres_timestamp(atm_int_state,timestamp) - type(atmos_internalstate_type), intent(in) :: atm_int_state - character(len=32), intent(in) :: timestamp - - integer :: unit, date(6) - -!----- compute current date ------ - - call get_date (atm_int_state%Time_atmos, date(1), date(2), date(3), & - date(4), date(5), date(6)) - -!----- write restart file ------ - - if (mpp_pe() == mpp_root_pe())then - call mpp_open( unit, 'RESTART/'//trim(timestamp)//'.coupler.res', nohdrs=.TRUE. ) - write( unit, '(i6,8x,a)' )calendar_type, & - '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - - write( unit, '(6i6,8x,a)' )date_init, & - 'Model start time: year, month, day, hour, minute, second' - write( unit, '(6i6,8x,a)' )date, & - 'Current model time: year, month, day, hour, minute, second' - call mpp_close(unit) - endif - end subroutine wrt_atmres_timestamp -! -!####################################################################### !-- write forecast grid to NetCDF file for diagnostics ! subroutine wrt_fcst_grid(grid, fileName, relaxedflag, regridArea, rc) @@ -1030,7 +1139,6 @@ subroutine wrt_fcst_grid(grid, fileName, relaxedflag, regridArea, rc) logical, intent(in), optional :: regridArea integer, intent(out) :: rc ! -!----------------------------------------------------------------------- !*** local variables ! logical :: ioCapable @@ -1040,7 +1148,6 @@ subroutine wrt_fcst_grid(grid, fileName, relaxedflag, regridArea, rc) type(ESMF_Array) :: array type(ESMF_ArrayBundle) :: arraybundle logical :: isPresent - integer :: stat logical :: hasCorners logical :: lRegridArea type(ESMF_Field) :: areaField diff --git a/module_fv3_config.F90 b/module_fv3_config.F90 index 53963b488..64522ec8e 100644 --- a/module_fv3_config.F90 +++ b/module_fv3_config.F90 @@ -2,7 +2,7 @@ module module_fv3_config !------------------------------------------------------------------------ ! -!*** fv3 configure variablse from model_configure +!*** fv3 configure variables from model_configure ! ! revision history ! 01/2017 Jun Wang Initial code @@ -14,21 +14,15 @@ module module_fv3_config implicit none ! integer :: nfhout, nfhout_hf, nsout, dt_atmos - integer :: nfhmax_hf, first_kdt + integer :: first_kdt integer :: fcst_mpi_comm, fcst_ntasks - real :: nfhmax - type(ESMF_Alarm) :: alarm_output_hf, alarm_output - type(ESMF_TimeInterval) :: output_hfmax - type(ESMF_TimeInterval) :: output_interval,output_interval_hf ! logical :: cplprint_flag logical :: quilting, output_1st_tstep_rst - logical :: force_date_from_configure logical :: restart_endfcst ! real,dimension(:),allocatable :: output_fh character(esmf_maxstr),dimension(:),allocatable :: filename_base character(17) :: calendar=' ' - integer :: calendar_type = -99 ! end module module_fv3_config diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90 index 45e8532a8..ae67c0daf 100644 --- a/stochastic_physics/stochastic_physics_wrapper.F90 +++ b/stochastic_physics/stochastic_physics_wrapper.F90 @@ -12,6 +12,7 @@ module stochastic_physics_wrapper_mod real(kind=kind_phys), dimension(:,:,:), allocatable, save :: skebu_wts real(kind=kind_phys), dimension(:,:,:), allocatable, save :: skebv_wts real(kind=kind_phys), dimension(:,:,:), allocatable, save :: sfc_wts + real(kind=kind_phys), dimension(:,:,:,:), allocatable, save :: spp_wts logical, save :: is_initialized = .false. integer, save :: lsoil = -999 @@ -78,7 +79,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) type(block_control_type), intent(inout) :: Atm_block integer, intent(out) :: ierr - integer :: nthreads, nb, levs, maxblk, nblks + integer :: nthreads, nb, levs, maxblk, nblks, n logical :: param_update_flag #ifdef _OPENMP @@ -96,7 +97,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) initalize_stochastic_physics: if (.not. is_initialized) then - if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type > 0) ) then + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type > 0) .OR. GFS_Control%do_spp) then allocate(xlat(1:nblks,maxblk)) allocate(xlon(1:nblks,maxblk)) do nb=1,nblks @@ -108,6 +109,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) GFS_Control%input_nml_file, GFS_Control%fn_nml, GFS_Control%nlunit, xlon, xlat, GFS_Control%do_sppt, GFS_Control%do_shum, & GFS_Control%do_skeb, GFS_Control%lndp_type, GFS_Control%n_var_lndp, GFS_Control%use_zmtnblck, GFS_Control%skeb_npass, & GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & + GFS_Control%n_var_spp, GFS_Control%spp_var_list, GFS_Control%spp_prt_list, GFS_Control%do_spp, & GFS_Control%ak, GFS_Control%bk, nthreads, GFS_Control%master, GFS_Control%communicator, ierr) if (ierr/=0) then write(6,*) 'call to init_stochastic_physics failed' @@ -124,6 +126,23 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) allocate(skebu_wts(1:nblks,maxblk,1:levs)) allocate(skebv_wts(1:nblks,maxblk,1:levs)) end if + if ( GFS_Control%do_spp ) then + allocate(spp_wts(1:nblks,maxblk,1:levs,1:GFS_Control%n_var_spp)) + do n=1,GFS_Control%n_var_spp + select case (trim(GFS_Control%spp_var_list(n))) + case('pbl') + GFS_Control%spp_pbl = 1 + case('sfc') + GFS_Control%spp_sfc = 1 + case('mp') + GFS_Control%spp_mp = 7 + case('rad') + GFS_Control%spp_rad = 1 + case('gwd') + GFS_Control%spp_gwd = 1 + end select + end do + end if if ( GFS_Control%lndp_type == 2 ) then ! this scheme updates through forecast allocate(sfc_wts(1:nblks,maxblk,1:GFS_Control%n_var_lndp)) end if @@ -154,7 +173,8 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) allocate(sfc_wts(1:nblks, maxblk, GFS_Control%n_var_lndp)) call run_stochastic_physics(levs, GFS_Control%kdt, GFS_Control%fhour, GFS_Control%blksz, & sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, & - skebv_wts=skebv_wts, sfc_wts=sfc_wts, nthreads=nthreads) + skebv_wts=skebv_wts, sfc_wts=sfc_wts, & + spp_wts=spp_wts, nthreads=nthreads) ! Copy contiguous data back do nb=1,nblks GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) @@ -188,10 +208,10 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) is_initialized = .true. else initalize_stochastic_physics - if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type == 2) ) then + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type == 2) .OR. GFS_Control%do_spp) then call run_stochastic_physics(levs, GFS_Control%kdt, GFS_Control%fhour, GFS_Control%blksz, & sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & - nthreads=nthreads) + spp_wts=spp_wts, nthreads=nthreads) ! Copy contiguous data back if (GFS_Control%do_sppt) then do nb=1,nblks @@ -209,6 +229,32 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) GFS_Data(nb)%Coupling%skebv_wts(:,:) = skebv_wts(nb,1:GFS_Control%blksz(nb),:) end do end if + if (GFS_Control%do_spp) then + do n=1,GFS_Control%n_var_spp + select case (trim(GFS_Control%spp_var_list(n))) + case('pbl') + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%spp_wts_pbl(:,:) = spp_wts(nb,1:GFS_Control%blksz(nb),:,n) + end do + case('sfc') + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%spp_wts_sfc(:,:) = spp_wts(nb,1:GFS_Control%blksz(nb),:,n) + end do + case('mp') + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%spp_wts_mp(:,:) = spp_wts(nb,1:GFS_Control%blksz(nb),:,n) + end do + case('gwd') + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%spp_wts_gwd(:,:) = spp_wts(nb,1:GFS_Control%blksz(nb),:,n) + end do + case('rad') + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%spp_wts_rad(:,:) = spp_wts(nb,1:GFS_Control%blksz(nb),:,n) + end do + end select + end do + end if if (GFS_Control%lndp_type == 2) then ! save wts, and apply lndp scheme do nb=1,nblks GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) @@ -347,7 +393,7 @@ subroutine stochastic_physics_wrapper_end (GFS_Control) type(GFS_control_type), intent(inout) :: GFS_Control - if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type > 0) ) then + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type > 0) .OR. GFS_Control%do_spp) then if (allocated(xlat)) deallocate(xlat) if (allocated(xlon)) deallocate(xlon) if (GFS_Control%do_sppt) then @@ -360,6 +406,9 @@ subroutine stochastic_physics_wrapper_end (GFS_Control) if (allocated(skebu_wts)) deallocate(skebu_wts) if (allocated(skebv_wts)) deallocate(skebv_wts) end if + if (GFS_Control%do_spp) then + if (allocated(spp_wts)) deallocate(spp_wts) + end if if ( GFS_Control%lndp_type == 2 ) then ! this scheme updates through forecast lsoil = -999 if (allocated(sfc_wts)) deallocate(sfc_wts) diff --git a/time_utils.F90 b/time_utils.F90 deleted file mode 100644 index 69aafcb60..000000000 --- a/time_utils.F90 +++ /dev/null @@ -1,170 +0,0 @@ -module time_utils_mod - - use fms_mod, only: uppercase - use mpp_mod, only: mpp_error, FATAL - use time_manager_mod, only: time_type, set_time, set_date, get_date - use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR - use time_manager_mod, only: fms_get_calendar_type => get_calendar_type - use ESMF - - implicit none - private - - !-------------------- interface blocks --------------------- - interface fms2esmf_cal - module procedure fms2esmf_cal_c - module procedure fms2esmf_cal_i - end interface fms2esmf_cal - interface esmf2fms_time - module procedure esmf2fms_time_t - module procedure esmf2fms_timestep - end interface esmf2fms_time - - public fms2esmf_cal - public esmf2fms_time - public fms2esmf_time - public string_to_date - - contains - - !-------------------- module code --------------------- - - function fms2esmf_cal_c(calendar) -! ! Return Value: - type(ESMF_CALKIND_FLAG) :: fms2esmf_cal_c -! ! Arguments: - character(len=*), intent(in) :: calendar - - select case( uppercase(trim(calendar)) ) - case( 'GREGORIAN' ) - fms2esmf_cal_c = ESMF_CALKIND_GREGORIAN - case( 'JULIAN' ) - fms2esmf_cal_c = ESMF_CALKIND_JULIAN - case( 'NOLEAP' ) - fms2esmf_cal_c = ESMF_CALKIND_NOLEAP - case( 'THIRTY_DAY' ) - fms2esmf_cal_c = ESMF_CALKIND_360DAY - case( 'NO_CALENDAR' ) - fms2esmf_cal_c = ESMF_CALKIND_NOCALENDAR - case default - call mpp_error(FATAL, & - 'ocean_solo: ocean_solo_nml entry calendar must be one of GREGORIAN|JULIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) - end select - end function fms2esmf_cal_c - - function fms2esmf_cal_i(calendar) -! ! Return Value: - type(ESMF_CALKIND_FLAG) :: fms2esmf_cal_i -! ! Arguments: - integer, intent(in) :: calendar - - select case(calendar) - case(THIRTY_DAY_MONTHS) - fms2esmf_cal_i = ESMF_CALKIND_360DAY - case(GREGORIAN) - fms2esmf_cal_i = ESMF_CALKIND_GREGORIAN - case(JULIAN) - fms2esmf_cal_i = ESMF_CALKIND_JULIAN - case(NOLEAP) - fms2esmf_cal_i = ESMF_CALKIND_NOLEAP - case(NO_CALENDAR) - fms2esmf_cal_i = ESMF_CALKIND_NOCALENDAR - end select - end function fms2esmf_cal_i - - function esmf2fms_time_t(time) - ! Return Value - type(Time_type) :: esmf2fms_time_t - ! Input Arguments - type(ESMF_Time), intent(in) :: time - ! Local Variables - integer :: yy, mm, dd, h, m, s - type(ESMF_CALKIND_FLAG) :: calkind - - integer :: rc - - call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, & - calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - esmf2fms_time_t = Set_date(yy, mm, dd, h, m, s) - - end function esmf2fms_time_t - - function esmf2fms_timestep(timestep) - ! Return Value - type(Time_type) :: esmf2fms_timestep - ! Input Arguments - type(ESMF_TimeInterval), intent(in):: timestep - ! Local Variables - integer :: s - type(ESMF_CALKIND_FLAG) :: calkind - - integer :: rc - - call ESMF_TimeIntervalGet(timestep, s=s, calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - esmf2fms_timestep = set_time(s, 0) - - end function esmf2fms_timestep - - function fms2esmf_time(time, calkind) - ! Return Value - type(ESMF_Time) :: fms2esmf_time - ! Input Arguments - type(Time_type), intent(in) :: time - type(ESMF_CALKIND_FLAG), intent(in), optional :: calkind - ! Local Variables - integer :: yy, mm, d, h, m, s - type(ESMF_CALKIND_FLAG) :: l_calkind - - integer :: rc - - integer :: yy1, mm1, d1, h1, m1, s1 - - if(present(calkind)) then - l_calkind = calkind - else - l_calkind = fms2esmf_cal(fms_get_calendar_type()) - endif - - call get_date(time, yy, mm, d, h, m, s) - print *,'in fms2esmf_time,time=',yy,mm,d,h,m,s,'calendar_type=', & - fms_get_calendar_type() - - call ESMF_TimeSet(fms2esmf_time, yy=yy, mm=mm, d=d, h=h, m=m, s=s, rc=rc) -! call ESMF_TimeSet(fms2esmf_time, yy=yy, mm=mm, d=d, h=h, m=m, s=s, & -! calkindflag=l_calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - -!test - call ESMF_TimeGet(fms2esmf_time,yy=yy1, mm=mm1, d=d1, h=h1, m=m1, s=s1,rc=rc) - print *,'in fms2esmf_time,test time=',yy1,mm1,d1,h1,m1,s1 - - end function fms2esmf_time - - function string_to_date(string, rc) - character(len=15), intent(in) :: string - integer, intent(out), optional :: rc - type(time_type) :: string_to_date - - integer :: yr,mon,day,hr,min,sec - - if(present(rc)) rc = ESMF_SUCCESS - - read(string, '(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec - string_to_date = set_date(yr, mon, day, hr, min, sec) - - end function string_to_date - -end module time_utils_mod diff --git a/upp b/upp index c939eae6b..0dc3c0c1d 160000 --- a/upp +++ b/upp @@ -1 +1 @@ -Subproject commit c939eae6bacb3c2a93753bba54b8646f32a0a7ab +Subproject commit 0dc3c0c1dbdcdc5025dff0c6b06b16aa2a7ddda9 From b82d5c6a29722c24a6369f8cf521c9700ccd0ae1 Mon Sep 17 00:00:00 2001 From: Hannah C Barnes <38660891+hannahcbarnes@users.noreply.github.com> Date: Wed, 9 Mar 2022 12:36:01 -0700 Subject: [PATCH 087/115] Remove GF Consistency Check & Add SDFs - V2 (#127) * - Removes consistency check in GF, allows GF to run with different or no shallow scheme - Add additional RAP based SDF * Point to gsl/develop for ccpp/physics Co-authored-by: Samuel Trahan --- ccpp/physics | 2 +- .../suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml | 94 +++++++++++++++++++ ...uite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml | 90 ++++++++++++++++++ 3 files changed, 185 insertions(+), 1 deletion(-) create mode 100644 ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml create mode 100644 ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml diff --git a/ccpp/physics b/ccpp/physics index 8c2450b4c..278a6d25b 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8c2450b4c7d2791f80128538bdb18940b3c40b9b +Subproject commit 278a6d25bda3aa434bb3dd6f67c389ecae657fdb diff --git a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml new file mode 100644 index 000000000..924398609 --- /dev/null +++ b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml @@ -0,0 +1,94 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + ugwpv1_gsldrag + ugwpv1_gsldrag_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + cu_gf_driver_pre + cu_gf_driver + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + + + mp_thompson + + + mp_thompson_post + GFS_MP_generic_post + cu_gf_driver_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml new file mode 100644 index 000000000..f639f233f --- /dev/null +++ b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml @@ -0,0 +1,90 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + unified_ugwp + unified_ugwp_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + cu_gf_driver_pre + cu_gf_driver + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + cu_gf_driver_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + From ae7feac6f416af5db9ea9148e494628498e95c03 Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Thu, 10 Mar 2022 12:27:14 -0700 Subject: [PATCH 088/115] Update to top of gsl/physics to get codeowners (#130) --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 278a6d25b..791fab61a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 278a6d25bda3aa434bb3dd6f67c389ecae657fdb +Subproject commit 791fab61a61ae6189a450c2343af6665f58d360d From 036f0b3e620bef227ba8571612f82658d3ae3761 Mon Sep 17 00:00:00 2001 From: Joseph Olson Date: Thu, 24 Mar 2022 11:41:13 -0600 Subject: [PATCH 089/115] updates related to MYNN-EDMF (#135) * adding new variable (Sm3D) stability function for momentum * update submodule pointer for ccpp-physics * Point to gsl/develop for ccpp/physics Co-authored-by: samuel.trahan --- ccpp/data/GFS_typedefs.F90 | 3 +++ ccpp/data/GFS_typedefs.meta | 8 ++++++++ ccpp/physics | 2 +- 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 1dd3a1cc3..84302cac4 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1465,6 +1465,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: QI_BL (:,:) => null() ! real (kind=kind_phys), pointer :: el_pbl (:,:) => null() ! real (kind=kind_phys), pointer :: Sh3D (:,:) => null() ! + real (kind=kind_phys), pointer :: Sm3D (:,:) => null() ! real (kind=kind_phys), pointer :: qke (:,:) => null() ! real (kind=kind_phys), pointer :: tsq (:,:) => null() ! real (kind=kind_phys), pointer :: qsq (:,:) => null() ! @@ -6241,6 +6242,7 @@ subroutine tbd_create (Tbd, IM, Model) allocate (Tbd%qi_bl (IM,Model%levs)) allocate (Tbd%el_pbl (IM,Model%levs)) allocate (Tbd%sh3d (IM,Model%levs)) + allocate (Tbd%sm3d (IM,Model%levs)) allocate (Tbd%qke (IM,Model%levs)) allocate (Tbd%tsq (IM,Model%levs)) allocate (Tbd%qsq (IM,Model%levs)) @@ -6251,6 +6253,7 @@ subroutine tbd_create (Tbd, IM, Model) Tbd%qi_bl = clear_val Tbd%el_pbl = clear_val Tbd%sh3d = clear_val + Tbd%sm3d = clear_val Tbd%qke = zero Tbd%tsq = clear_val Tbd%qsq = clear_val diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 3c3b31c0c..4cec6d322 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -6268,6 +6268,14 @@ type = real kind = kind_phys active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme) +[Sm3D] + standard_name = stability_function_for_momentum + long_name = stability function for momentum + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme) [qke] standard_name = nonadvected_turbulent_kinetic_energy_multiplied_by_2 long_name = 2 x tke at mass points diff --git a/ccpp/physics b/ccpp/physics index 791fab61a..54f769cf5 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 791fab61a61ae6189a450c2343af6665f58d360d +Subproject commit 54f769cf52c0beb7b49c2fb8b5d4fd28a95e5cc5 From 5d9f22186624ca6549c5226189c6772193c3caef Mon Sep 17 00:00:00 2001 From: mdtoyNOAA <73618848+mdtoyNOAA@users.noreply.github.com> Date: Fri, 25 Mar 2022 14:46:41 -0600 Subject: [PATCH 090/115] GWD, LSM and MYNN physics updates from RRFS_dev branch (#136) * GWD, LSM and MYNN physics updates from RRFS_dev branch * Point to gsl/develop for ccpp/physics Co-authored-by: samuel.trahan --- ccpp/physics | 2 +- ccpp/suites/suite_FV3_HRRR.xml | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 54f769cf5..5f250c1b9 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 54f769cf52c0beb7b49c2fb8b5d4fd28a95e5cc5 +Subproject commit 5f250c1b95039944ae69c77de42fdfbc705d5cf9 diff --git a/ccpp/suites/suite_FV3_HRRR.xml b/ccpp/suites/suite_FV3_HRRR.xml index d3408f0ba..b5842046f 100644 --- a/ccpp/suites/suite_FV3_HRRR.xml +++ b/ccpp/suites/suite_FV3_HRRR.xml @@ -42,10 +42,8 @@ mynnsfc_wrapper GFS_surface_loop_control_part1 - sfc_nst_pre - sfc_nst - sfc_nst_post lsm_ruc + flake_driver GFS_surface_loop_control_part2 From dd68016fb1ba15c4ead1ba9206bbbcabe515f299 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 25 Mar 2022 22:11:27 +0000 Subject: [PATCH 091/115] move some parameters in mynn surface layer to namelist options --- ccpp/data/GFS_typedefs.F90 | 25 ++++++++++++++++++++++++- ccpp/data/GFS_typedefs.meta | 24 ++++++++++++++++++++++++ ccpp/physics | 2 +- 3 files changed, 49 insertions(+), 2 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 84302cac4..f8770bc94 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1044,6 +1044,10 @@ module GFS_typedefs integer :: bl_mynn_output !< flag to initialize and write out extra 3D arrays integer :: icloud_bl !< flag for coupling sgs clouds to radiation real(kind=kind_phys) :: bl_mynn_closure !< flag to determine closure level of MYNN + logical :: sfclay_compute_flux!< flag for thermal roughness lengths over water in mynnsfclay + logical :: sfclay_compute_diag!< flag for computing surface diagnostics in mynnsfclay + integer :: isftcflx !< flag for thermal roughness lengths over water in mynnsfclay + integer :: iz0tlnd !< flag for thermal roughness lengths over land in mynnsfclay real(kind=kind_phys) :: var_ric real(kind=kind_phys) :: coef_ric_l real(kind=kind_phys) :: coef_ric_s @@ -3419,6 +3423,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: bl_mynn_closure = 2.6 !< <= 2.5 only prognose tke !< 2.5 < and < 3.0, prognose tke and q'2 !< >= 3.0, prognose tke, q'2, T'2, and T'q' + logical :: sfclay_compute_diag = .false. + logical :: sfclay_compute_flux = .false. + integer :: isftcflx = 0 + integer :: iz0tlnd = 0 real(kind=kind_phys) :: var_ric = 1.0 real(kind=kind_phys) :: coef_ric_l = 0.16 real(kind=kind_phys) :: coef_ric_s = 0.25 @@ -3675,6 +3683,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & bl_mynn_edmf_tke, bl_mynn_mixlength, bl_mynn_cloudmix, & bl_mynn_mixqt, bl_mynn_output, icloud_bl, bl_mynn_tkeadvect, & bl_mynn_closure, bl_mynn_tkebudget, & + isftcflx, iz0tlnd, sfclay_compute_flux, sfclay_compute_diag, & ! *DH gwd_opt, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, & @@ -4370,6 +4379,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%bl_mynn_closure = bl_mynn_closure Model%bl_mynn_tkebudget = bl_mynn_tkebudget Model%icloud_bl = icloud_bl + Model%isftcflx = isftcflx + Model%iz0tlnd = iz0tlnd + Model%sfclay_compute_flux = sfclay_compute_flux + Model%sfclay_compute_diag = sfclay_compute_diag Model%var_ric = var_ric Model%coef_ric_l = coef_ric_l Model%coef_ric_s = coef_ric_s @@ -4953,9 +4966,19 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' bl_mynn_cloudpdf=',Model%bl_mynn_cloudpdf, & ' bl_mynn_mixlength=',Model%bl_mynn_mixlength, & ' bl_mynn_edmf=',Model%bl_mynn_edmf, & - ' bl_mynn_output=',Model%bl_mynn_output + ' bl_mynn_output=',Model%bl_mynn_output, & + ' bl_mynn_closure=',Model%bl_mynn_closure endif + !--- mynn surface layer scheme + if (Model%do_mynnsfclay) then + if (Model%me == Model%master) print *,' MYNN surface layer scheme is used:', & + ' isftcflx=',Model%isftcflx, & + ' iz0tlnd=',Model%iz0tlnd, & + ' sfclay_compute_diag=',Model%sfclay_compute_diag, & + ' sfclay_compute_flux=',Model%sfclay_compute_flux + end if + !--- set number of cloud types if (Model%cscnv) then Model%nctp = nint(Model%cs_parm(5)) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 4cec6d322..b9eaa8fc5 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5526,6 +5526,30 @@ units = flag dimensions = () type = integer +[isftcflx] + standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + long_name = flag for thermal roughness lengths over water in mynnsfclay + units = flag + dimensions = () + type = integer +[iz0tlnd] + standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + long_name = flag for thermal roughness lengths over land in mynnsfclay + units = flag + dimensions = () + type = integer +[sfclay_compute_flux] + standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + long_name = flag for computing surface scalar fluxes in mynnsfclay + units = flag + dimensions = () + type = logical +[sfclay_compute_diag] + standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + long_name = flag for computing surface diagnostics in mynnsfclay + units = flag + dimensions = () + type = logical [var_ric] standard_name = control_for_variable_bulk_richardson_number long_name = flag for calculating variable bulk richardson number for hurricane PBL diff --git a/ccpp/physics b/ccpp/physics index 5f250c1b9..9b783f400 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5f250c1b95039944ae69c77de42fdfbc705d5cf9 +Subproject commit 9b783f400f656f981ce435f8cb988c18ab5682df From 6f60c52ff1370d3e7932baec2746aec25b9ea624 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 29 Mar 2022 01:01:27 +0000 Subject: [PATCH 092/115] Point to top of gsl/develop for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 5f250c1b9..8293f36e8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5f250c1b95039944ae69c77de42fdfbc705d5cf9 +Subproject commit 8293f36e86e09103d44cce5c23e2b3db30894ce5 From ae22dce5acb3622d5b3e47c3d0d619c853d6233a Mon Sep 17 00:00:00 2001 From: haiqinli <38666296+haiqinli@users.noreply.github.com> Date: Wed, 20 Apr 2022 19:14:52 -0600 Subject: [PATCH 093/115] gsl/develop RRFS-Smoke (#141) * "add for smoke" * "update to pass GNU compiler" * "following Joe's comments to add nchem,ndvel as input to MYNN" * "update fv3atm to point to gsl/develop-smoke" * "to point to physics branch of gsl/develop-smoke" * Point to gsl/develop-smoke for ccpp-physics * "point ot gsl/develop-smoke branch" * "update GFS_typedefs.meta with rrfs_smoke active flag" * "update the 3rd dimension readin of GBBEPx for smoke" * Remove an extra read that went out of bounds * Point to NOAA-GSL gsl/develop for ccpp-physics Co-authored-by: samuel.trahan --- ccpp/config/ccpp_prebuild_config.py | 4 + ccpp/data/GFS_typedefs.F90 | 153 +++++++++++++- ccpp/data/GFS_typedefs.meta | 294 +++++++++++++++++++++++++++ ccpp/driver/GFS_diagnostics.F90 | 160 +++++++++++++++ ccpp/suites/suite_FV3_HRRR_smoke.xml | 83 ++++++++ io/FV3GFS_io.F90 | 163 ++++++++++++++- 6 files changed, 854 insertions(+), 3 deletions(-) create mode 100644 ccpp/suites/suite_FV3_HRRR_smoke.xml diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index bbc7da433..8723f89b1 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -187,6 +187,10 @@ 'physics/physics/sfc_sice.f', # HAFS FER_HIRES 'physics/physics/mp_fer_hires.F90', + # SMOKE + 'physics/smoke/rrfs_smoke_wrapper.F90', + 'physics/smoke/rrfs_smoke_postpbl.F90', + 'physics/smoke/rrfs_smoke_lsdep_wrapper.F90', # RRTMGP 'physics/physics/rrtmgp_lw_gas_optics.F90', 'physics/physics/rrtmgp_lw_cloud_optics.F90', diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 84302cac4..a5d7fda42 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -247,6 +247,9 @@ module GFS_typedefs real (kind=kind_phys), pointer :: snodi (:) => null() !< snow depth over ice real (kind=kind_phys), pointer :: weasdi (:) => null() !< weasd over ice real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics + real (kind=kind_phys), pointer :: dust12m_in (:,:,:) => null() !< fengsha dust input + real (kind=kind_phys), pointer :: emi_in (:,:) => null() !< anthropogenic background input + real (kind=kind_phys), pointer :: smoke_GBBEPx(:,:,:) => null() !< GBBEPx fire input real (kind=kind_phys), pointer :: z0base (:) => null() !< background or baseline surface roughness length in m real (kind=kind_phys), pointer :: semisbase(:) => null() !< background surface emissivity real (kind=kind_phys), pointer :: sfalb_lnd (:) => null() !< surface albedo over land for LSM @@ -551,12 +554,42 @@ module GFS_typedefs real (kind=kind_phys), pointer :: nwfa2d (:) => null() !< instantaneous water-friendly sfc aerosol source real (kind=kind_phys), pointer :: nifa2d (:) => null() !< instantaneous ice-friendly sfc aerosol source + !--- aerosol surface emissions for Thompson microphysics & smoke + real (kind=kind_phys), pointer :: emdust (:) => null() !< instantaneous dust emission + real (kind=kind_phys), pointer :: emseas (:) => null() !< instantaneous sea salt emission + real (kind=kind_phys), pointer :: emanoc (:) => null() !< instantaneous anthro. oc emission + + !--- These 3 arrays are hourly, so their dimension is imx24 (output is hourly) + real (kind=kind_phys), pointer :: ebb_smoke_hr(:) => null() !< hourly smoke emission + real (kind=kind_phys), pointer :: frp_hr (:) => null() !< hourly FRP + real (kind=kind_phys), pointer :: frp_std_hr (:) => null() !< hourly std. FRP + + !--- For fire diurnal cycle + real (kind=kind_phys), pointer :: fhist (:) => null() !< instantaneous fire coef_bb + real (kind=kind_phys), pointer :: coef_bb_dc (:) => null() !< instantaneous fire coef_bb + real (kind=kind_phys), pointer :: ebu_smoke (:,:) => null() !< 3D ebu array + + !--- For smoke and dust optical extinction + real (kind=kind_phys), pointer :: smoke_ext (:,:) => null() !< 3D aod array + real (kind=kind_phys), pointer :: dust_ext (:,:) => null() !< 3D aod array + !--- For MYNN PBL transport of smoke and dust + real (kind=kind_phys), pointer :: chem3d (:,:,:) => null() !< 3D aod array + + !--- Fire plume rise diagnostics + real (kind=kind_phys), pointer :: min_fplume (:) => null() !< minimum plume rise level + real (kind=kind_phys), pointer :: max_fplume (:) => null() !< maximum plume rise level + !--- hourly fire potential index + real (kind=kind_phys), pointer :: rrfs_hwp (:) => null() !< hourly fire potential index + !--- instantaneous quantities for chemistry coupling real (kind=kind_phys), pointer :: ushfsfci(:) => null() !< instantaneous upward sensible heat flux (w/m**2) real (kind=kind_phys), pointer :: qci_conv(:,:) => null() !< convective cloud condesate after rainout real (kind=kind_phys), pointer :: pfi_lsan(:,:) => null() !< instantaneous 3D flux of ice nonconvective precipitation (kg m-2 s-1) real (kind=kind_phys), pointer :: pfl_lsan(:,:) => null() !< instantaneous 3D flux of liquid nonconvective precipitation (kg m-2 s-1) + !--- instantaneous total moisture tendency for smoke coupling: + real (kind=kind_phys), pointer :: dqdti (:,:) => null() !< rrfs_smoke=true only; instantaneous total moisture tendency (kg/kg/s) + contains procedure :: create => coupling_create !< allocate array data end type GFS_coupling_type @@ -648,6 +681,7 @@ module GFS_typedefs logical :: cplwav !< default no cplwav collection logical :: cplwav2atm !< default no wav->atm coupling logical :: cplchm !< default no cplchm collection + logical :: rrfs_smoke !< default no rrfs_smoke collection logical :: use_cice_alb !< default .false. - i.e. don't use albedo imported from the ice model logical :: cpl_imp_mrg !< default no merge import with internal forcings logical :: cpl_imp_dbg !< default no write import data to file post merge @@ -1246,6 +1280,10 @@ module GFS_typedefs integer :: nto2 !< tracer index for oxygen integer :: ntwa !< tracer index for water friendly aerosol integer :: ntia !< tracer index for ice friendly aerosol + integer :: ntsmoke !< tracer index for smoke + integer :: ntdust !< tracer index for dust + integer :: nchem !< number of prognostic chemical species (vertically mixied) + integer :: ndvel !< number of prognostic chemical species (which are deposited, usually =nchem) integer :: ntchm !< number of prognostic chemical tracers (advected) integer :: ntchs !< tracer index for first prognostic chemical tracer integer :: ntche !< tracer index for last prognostic chemical tracer @@ -1284,6 +1322,22 @@ module GFS_typedefs integer :: npsdelt !< the index of surface air pressure at the previous timestep for Z-C MP in phy_f2d integer :: ncnvwind !< the index of surface wind enhancement due to convection for MYNN SFC and RAS CNV in phy f2d +!-- chem nml variables for RRFS-Smoke + integer :: seas_opt + integer :: dust_opt + integer :: biomass_burn_opt + integer :: drydep_opt + integer :: wetdep_ls_opt + logical :: do_plumerise + integer :: addsmoke_flag + integer :: plumerisefire_frq + logical :: smoke_forecast + logical :: aero_ind_fdb ! WFA/IFA indirect + logical :: aero_dir_fdb ! smoke/dust direct + logical :: rrfs_smoke_debug + logical :: mix_chem + logical :: fire_turb + !--- debug flags logical :: debug logical :: pre_rad !< flag for testing purpose @@ -2379,6 +2433,9 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%snodi (IM)) allocate (Sfcprop%weasdi (IM)) allocate (Sfcprop%hprime (IM,Model%nmtvr)) + allocate (Sfcprop%dust12m_in (IM,12,5)) + allocate (Sfcprop%smoke_GBBEPx(IM,24,3)) + allocate (Sfcprop%emi_in (IM,1)) allocate(Sfcprop%albdirvis_lnd (IM)) allocate(Sfcprop%albdirnir_lnd (IM)) allocate(Sfcprop%albdifvis_lnd (IM)) @@ -2409,6 +2466,9 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%snodi = clear_val Sfcprop%weasdi = clear_val Sfcprop%hprime = clear_val + Sfcprop%dust12m_in= clear_val + Sfcprop%emi_in = clear_val + Sfcprop%smoke_GBBEPx = clear_val Sfcprop%albdirvis_lnd = clear_val Sfcprop%albdirnir_lnd = clear_val Sfcprop%albdifvis_lnd = clear_val @@ -2976,7 +3036,7 @@ subroutine coupling_create (Coupling, IM, Model) endif ! -- Aerosols coupling options - if (Model%cplchm) then + if (Model%cplchm .or. Model%rrfs_smoke) then !--- outgoing instantaneous quantities allocate (Coupling%ushfsfci (IM)) !--- accumulated convective rainfall @@ -3039,6 +3099,42 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%nifa2d = clear_val endif + if(Model%rrfs_smoke) then + !--- needed for smoke aerosol option + allocate (Coupling%emdust (IM)) + allocate (Coupling%emseas (IM)) + allocate (Coupling%emanoc (IM)) + allocate (Coupling%ebb_smoke_hr (IM)) + allocate (Coupling%frp_hr (IM)) + allocate (Coupling%frp_std_hr(IM)) + allocate (Coupling%fhist (IM)) + allocate (Coupling%coef_bb_dc(IM)) + allocate (Coupling%ebu_smoke (IM,Model%levs)) + allocate (Coupling%smoke_ext (IM,Model%levs)) + allocate (Coupling%dust_ext (IM,Model%levs)) + allocate (Coupling%chem3d (IM,Model%levs,2)) + allocate (Coupling%min_fplume(IM)) + allocate (Coupling%max_fplume(IM)) + allocate (Coupling%rrfs_hwp (IM)) + allocate (Coupling%dqdti (IM,Model%levs)) + Coupling%emdust = clear_val + Coupling%emseas = clear_val + Coupling%emanoc = clear_val + Coupling%ebb_smoke_hr = clear_val + Coupling%frp_hr = clear_val + Coupling%frp_std_hr = clear_val + Coupling%fhist = 1. + Coupling%coef_bb_dc = clear_val + Coupling%ebu_smoke = clear_val + Coupling%smoke_ext = clear_val + Coupling%dust_ext = clear_val + Coupling%chem3d = clear_val + Coupling%min_fplume = clear_val + Coupling%max_fplume = clear_val + Coupling%rrfs_hwp = clear_val + Coupling%dqdti = clear_val + endif + if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then allocate (Coupling%qci_conv (IM,Model%levs)) Coupling%qci_conv = clear_val @@ -3134,6 +3230,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: cplwav = .false. !< default no cplwav collection logical :: cplwav2atm = .false. !< default no cplwav2atm coupling logical :: cplchm = .false. !< default no cplchm collection + logical :: rrfs_smoke = .false. !< default no rrfs_smoke collection logical :: use_cice_alb = .false. !< default no cice albedo logical :: cpl_imp_mrg = .false. !< default no merge import with internal forcings logical :: cpl_imp_dbg = .false. !< default no write import data to file post merge @@ -3601,6 +3698,22 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: spp_gwd = 0 logical :: do_spp = .false. +!-- chem nml variables for RRFS-Smoke + integer :: seas_opt = 2 + integer :: dust_opt = 5 + integer :: biomass_burn_opt = 1 + integer :: drydep_opt = 1 + integer :: wetdep_ls_opt = 1 + logical :: do_plumerise = .false. + integer :: addsmoke_flag = 1 + integer :: plumerisefire_frq = 60 + logical :: smoke_forecast = .false. ! RRFS-smoke diurnal + logical :: aero_ind_fdb = .false. ! RRFS-smoke wfa/ifa emission + logical :: aero_dir_fdb = .false. ! RRFS-smoke smoke/dust radiation feedback + logical :: rrfs_smoke_debug = .false. ! RRFS-smoke plumerise debug + logical :: mix_chem = .false. ! tracer mixing option by MYNN PBL + logical :: fire_turb = .false. ! enh vertmix option by MYNN PBL + !--- aerosol scavenging factors integer, parameter :: max_scav_factors = 25 character(len=40) :: fscav_aero(max_scav_factors) @@ -3617,7 +3730,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & thermodyn_id, sfcpress_id, & !--- coupling parameters cplflx, cplice, cplocn2atm, cplwav, cplwav2atm, cplchm, & - cpl_imp_mrg, cpl_imp_dbg, & + cpl_imp_mrg, cpl_imp_dbg, rrfs_smoke, & use_cice_alb, & #ifdef IDEA_PHYS lsidea, weimer_model, f107_kp_size, f107_kp_interval, & @@ -3731,6 +3844,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & phys_version, & !--- aerosol scavenging factors ('name:value' string array) fscav_aero, & + !--- RRFS smoke namelist + seas_opt, dust_opt, biomass_burn_opt, drydep_opt, & + wetdep_ls_opt, smoke_forecast, aero_ind_fdb, aero_dir_fdb, & + rrfs_smoke_debug, do_plumerise, plumerisefire_frq, & + addsmoke_flag, fire_turb, mix_chem, & !--- (DFI) time ranges with radar-prescribed microphysics tendencies ! and (maybe) convection suppression fh_dfi_radar, radar_tten_limits, do_cap_suppress @@ -3933,6 +4051,23 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%cpl_imp_mrg = cpl_imp_mrg Model%cpl_imp_dbg = cpl_imp_dbg +!--- RRFS Smoke + Model%rrfs_smoke = rrfs_smoke + Model%seas_opt = seas_opt + Model%dust_opt = dust_opt + Model%biomass_burn_opt = biomass_burn_opt + Model%drydep_opt = drydep_opt + Model%wetdep_ls_opt = wetdep_ls_opt + Model%do_plumerise = do_plumerise + Model%plumerisefire_frq = plumerisefire_frq + Model%addsmoke_flag = addsmoke_flag + Model%smoke_forecast = smoke_forecast + Model%aero_ind_fdb = aero_ind_fdb + Model%aero_dir_fdb = aero_dir_fdb + Model%rrfs_smoke_debug = rrfs_smoke_debug + Model%mix_chem = mix_chem + Model%fire_turb = fire_turb + !--- integrated dynamics through earth's atmosphere Model%lsidea = lsidea if (Model%lsidea) then @@ -4572,6 +4707,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%nqrimef = get_tracer_index(Model%tracer_names, 'q_rimef', 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%ntsmoke = get_tracer_index(Model%tracer_names, 'smoke', Model%me, Model%master, Model%debug) + Model%ntdust = get_tracer_index(Model%tracer_names, 'dust', Model%me, Model%master, Model%debug) !--- initialize parameters for atmospheric chemistry tracers call Model%init_chemistry(tracer_types) @@ -5471,6 +5608,8 @@ subroutine control_chemistry_initialize(Model, tracer_types) integer :: n !--- begin + Model%nchem = 0 + Model%ndvel = 0 Model%ntchm = 0 Model%ntchs = NO_TRACER Model%ntche = NO_TRACER @@ -5478,6 +5617,11 @@ subroutine control_chemistry_initialize(Model, tracer_types) Model%ndchs = NO_TRACER Model%ndche = NO_TRACER + if (Model%rrfs_smoke) then + Model%nchem = 2 + Model%ndvel = 2 + endif + do n = 1, size(tracer_types) select case (tracer_types(n)) case (1) @@ -5608,6 +5752,7 @@ subroutine control_print(Model) print *, ' cplwav : ', Model%cplwav print *, ' cplwav2atm : ', Model%cplwav2atm print *, ' cplchm : ', Model%cplchm + print *, ' rrfs_smoke : ', Model%rrfs_smoke print *, ' use_cice_alb : ', Model%use_cice_alb print *, ' cpl_imp_mrg : ', Model%cpl_imp_mrg print *, ' cpl_imp_dbg : ', Model%cpl_imp_dbg @@ -5976,6 +6121,10 @@ subroutine control_print(Model) print *, ' nto2 : ', Model%nto2 print *, ' ntwa : ', Model%ntwa print *, ' ntia : ', Model%ntia + print *, ' ntsmoke : ', Model%ntsmoke + print *, ' ntdust : ', Model%ntdust + print *, ' nchem : ', Model%nchem + print *, ' ndvel : ', Model%ndvel print *, ' ntchm : ', Model%ntchm print *, ' ntchs : ', Model%ntchs print *, ' ntche : ', Model%ntche diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 4cec6d322..ec4a18432 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -261,6 +261,20 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys +[qgrs(:,:,index_for_smoke)] + standard_name = smoke_tracer_concentration + long_name = concentration of smoke + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys +[qgrs(:,:,index_for_dust)] + standard_name = dust_tracer_concentration + long_name = concentration of dust + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys [diss_est] standard_name = dissipation_estimate_of_air_temperature_at_model_layers long_name = dissipation estimate model layer mean temperature @@ -620,6 +634,30 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys +[dust12m_in] + standard_name = fengsha_dust12m_input + long_name = fengsha dust input + units = various + dimensions = (horizontal_dimension,12,5) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[emi_in] + standard_name = anthropogenic_background_input + long_name = anthropogenic background input + units = various + dimensions = (horizontal_dimension,1) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[smoke_GBBEPx] + standard_name = emission_smoke_GBBEPx + long_name = emission fire GBBEPx + units = various + dimensions = (horizontal_dimension,24,3) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) [z0base] standard_name = baseline_surface_roughness_length long_name = baseline surface roughness length for momentum in meter @@ -2292,6 +2330,14 @@ type = real kind = kind_phys active = (control_for_stochastic_land_surface_perturbation /= 0) +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) [nwfa2d] standard_name = tendency_of_hygroscopic_aerosols_at_surface_adjacent_layer long_name = instantaneous water-friendly sfc aerosol source @@ -2308,6 +2354,126 @@ type = real kind = kind_phys active = (control_for_microphysics_scheme == identifier_for_thompson_microphysics_scheme .and. flag_for_aerosol_physics) +[emdust] + standard_name = emission_of_dust_for_smoke + long_name = emission of dust for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[emseas] + standard_name = emission_of_seas_for_smoke + long_name = emission of seas for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[emanoc] + standard_name = emission_of_anoc_for_thompson_mp + long_name = emission of anoc for thompson mp + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[ebb_smoke_hr] + standard_name = surfce_emission_of_smoke + long_name = emission of surface smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[frp_hr] + standard_name = frp_hourly + long_name = hourly frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[frp_std_hr] + standard_name = frp_std_hourly + long_name = hourly std frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[fhist] + standard_name = fhist + long_name = fire hist + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[coef_bb_dc] + standard_name = coef_bb_dc + long_name = coef bb dc from plumerise + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[ebu_smoke] + standard_name = ebu_smoke + long_name = smoke buffer of ebu + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[smoke_ext] + standard_name = smoke_ext + long_name = smoke optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[dust_ext] + standard_name = dust_ext + long_name = dust optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[min_fplume] + standard_name = min_fplume + long_name = miminum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[max_fplume] + standard_name = max_fplume + long_name = maximum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) +[rrfs_hwp] + standard_name = rrfs_hwp + long_name = rrfs hourly fire weather potential + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + active = (flag_for_rrfs_smoke_coupling) [ushfsfci] standard_name = surface_upward_sensible_heat_flux_for_chemistry_coupling long_name = instantaneous upward sensible heat flux for chemistry coupling @@ -2657,6 +2823,12 @@ units = flag dimensions = () type = logical +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical [cpl_imp_mrg] standard_name = flag_for_merging_imported_data long_name = flag controlling cpl_imp_mrg for imported data (default off) @@ -5010,6 +5182,30 @@ units = index dimensions = () type = integer +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical vertically mixed + units = count + dimensions = () + type = integer +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer [ntchm] standard_name = number_of_chemical_tracers long_name = number of chemical tracers @@ -5107,6 +5303,104 @@ units = index dimensions = () type = integer +[mix_chem] + standard_name = rrfs_smoke_mynn_tracer_mixing + long_name = flag for rrfs smoke mynn tracer mixing + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[fire_turb] + standard_name = rrfs_smoke_mynn_enh_vermix + long_name = flag for rrfs smoke mynn enh vermix + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[seas_opt] + standard_name = rrfs_smoke_sea_salt_opt + long_name = rrfs smoke sea salt emission option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[dust_opt] + standard_name = rrfs_smoke_dust_opt + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[biomass_burn_opt] + standard_name = rrfs_smoke_biomass_burn_opt + long_name = rrfs smoke biomass burning option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[drydep_opt] + standard_name = rrfs_smoke_drydep_opt + long_name = rrfs smoke dry deposition option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[wetdep_ls_opt] + standard_name = rrfs_smoke_wetdep_ls_opt + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[do_plumerise] + standard_name = rrfs_smoke_plumerise_flag + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[plumerisefire_frq] + standard_name = rrfs_smoke_plumerisefire_frq + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[addsmoke_flag] + standard_name = rrfs_smoke_addsmoke_flag + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + active = (flag_for_rrfs_smoke_coupling) +[smoke_forecast] + standard_name = rrfs_smoke_smoke_forecast_opt + long_name = flag for rrfs smoke forecast + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[aero_ind_fdb] + standard_name = rrfs_smoke_aero_ind_fdb_opt + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[aero_dir_fdb] + standard_name = rrfs_smoke_dust_rad_fdb_opt + long_name = flag for rrfs smoke dust rad feedback + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) +[rrfs_smoke_debug] + standard_name = rrfs_smoke_plumerise_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + active = (flag_for_rrfs_smoke_coupling) [ncnvcld3d] standard_name = number_of_convective_cloud_variables_in_xyz_dimensioned_restart_array long_name = number of convective 3d clouds fields diff --git a/ccpp/driver/GFS_diagnostics.F90 b/ccpp/driver/GFS_diagnostics.F90 index 6e4b62337..8b4954e60 100644 --- a/ccpp/driver/GFS_diagnostics.F90 +++ b/ccpp/driver/GFS_diagnostics.F90 @@ -1764,6 +1764,20 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ! if(mpp_pe()==mpp_root_pe())print *,'in gfdl_diag_register,af totgrp,idx=',idx +!--- RRFS Smoke --- + if (Model%rrfs_smoke) then + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'dqdti' + ExtDiag(idx)%desc = 'dqdti' + ExtDiag(idx)%unit = 'kg kg-1 s-1' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%dqdti(:,:) + enddo + endif + !--- physics instantaneous diagnostics --- idx = idx + 1 ExtDiag(idx)%axes = 2 @@ -3541,6 +3555,152 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop enddo end if thompson_extended_diagnostics + if (Model%rrfs_smoke .and. Model%ntsmoke>0) then + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'emdust' + ExtDiag(idx)%desc = 'emission of dust for smoke' + ExtDiag(idx)%unit = 'ug m-2 s-1' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%emdust + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'emseas' + ExtDiag(idx)%desc = 'emission of seas for smoke' + ExtDiag(idx)%unit = 'ug m-2 s-1' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%emseas + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'emanoc' + ExtDiag(idx)%desc = 'emission of anoc for thompson mp' + ExtDiag(idx)%unit = 'ug m-2 s-1' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%emanoc + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'coef_bb_dc' + ExtDiag(idx)%desc = 'coeff bb for smoke' + ExtDiag(idx)%unit = '' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%coef_bb_dc + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'min_fplume' + ExtDiag(idx)%desc = 'minimum smoke plume height' + ExtDiag(idx)%unit = '' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%min_fplume + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'max_fplume' + ExtDiag(idx)%desc = 'maximum smoke plume height' + ExtDiag(idx)%unit = '' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%max_fplume + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'HWP' + ExtDiag(idx)%desc = 'hourly fire weather potential' + ExtDiag(idx)%unit = ' ' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%rrfs_hwp + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'ebb_smoke_hr' + ExtDiag(idx)%desc = 'hourly smoke emission' + ExtDiag(idx)%unit = 'ug m-2 s-1' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%ebb_smoke_hr + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'frp_hr' + ExtDiag(idx)%desc = 'hourly frp' + ExtDiag(idx)%unit = 'mw' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%frp_hr + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 2 + ExtDiag(idx)%name = 'frp_std_hr' + ExtDiag(idx)%desc = 'hourly std frp' + ExtDiag(idx)%unit = 'mw' + ExtDiag(idx)%mod_name = 'gfs_sfc' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var2 => Coupling(nb)%frp_std_hr + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'ebu_smoke' + ExtDiag(idx)%desc = 'smoke emission' + ExtDiag(idx)%unit = 'ug/m2/s' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%ebu_smoke(:,:) + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'smoke_ext' + ExtDiag(idx)%desc = 'smoke extinction at 550nm' + ExtDiag(idx)%unit = ' ' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%smoke_ext(:,:) + enddo + + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'dust_ext' + ExtDiag(idx)%desc = 'dust extinction at 550nm' + ExtDiag(idx)%unit = ' ' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => Coupling(nb)%dust_ext(:,:) + enddo + + endif + do i=1,Model%num_dfi_radar idx = idx + 1 ExtDiag(idx)%axes = 3 diff --git a/ccpp/suites/suite_FV3_HRRR_smoke.xml b/ccpp/suites/suite_FV3_HRRR_smoke.xml new file mode 100644 index 000000000..450007623 --- /dev/null +++ b/ccpp/suites/suite_FV3_HRRR_smoke.xml @@ -0,0 +1,83 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + mynnsfc_wrapper + GFS_surface_loop_control_part1 + lsm_ruc + flake_driver + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + rrfs_smoke_wrapper + mynnedmf_wrapper + rrfs_smoke_postpbl + GFS_GWD_generic_pre + drag_suite + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_suite_interstitial_4 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + rrfs_smoke_lsdep_wrapper + phys_tend + + + + + GFS_stochastics + + + + diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 041a2d46b..ef7cbf008 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -60,9 +60,12 @@ module FV3GFS_io_mod character(len=32) :: fn_oro_ss = 'oro_data_ss.nc' character(len=32) :: fn_srf = 'sfc_data.nc' character(len=32) :: fn_phy = 'phy_data.nc' + character(len=32) :: fn_dust12m= 'dust12m_data.nc' + character(len=32) :: fn_emi = 'emi_data.nc' + character(len=32) :: fn_gbbepx = 'SMOKE_GBBEPx_data.nc' !--- GFDL FMS netcdf restart data types defined in fms2_io - type(FmsNetcdfDomainFile_t) :: Oro_restart, Sfc_restart, Phy_restart + type(FmsNetcdfDomainFile_t) :: Oro_restart, Sfc_restart, Phy_restart, dust12m_restart, emi_restart, gbbepx_restart type(FmsNetcdfDomainFile_t) :: Oro_ls_restart, Oro_ss_restart !--- GFDL FMS restart containers @@ -71,6 +74,10 @@ module FV3GFS_io_mod character(len=32), allocatable, dimension(:) :: oro_ls_ss_name real(kind=kind_phys), allocatable, target, dimension(:,:,:) :: oro_ls_var, oro_ss_var real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3, phy_var3 + character(len=32), allocatable, dimension(:) :: dust12m_name, emi_name, gbbepx_name + real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: gbbepx_var + real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: dust12m_var + real(kind=kind_phys), allocatable, target, dimension(:,:,:) :: emi_var !--- Noah MP restart containers real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3sn,sfc_var3eq,sfc_var3zn @@ -515,6 +522,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta integer :: nvar_o2, nvar_s2m, nvar_s2o, nvar_s3 integer :: nvar_oro_ls_ss integer :: nvar_s2r, nvar_s2mp, nvar_s3mp, isnow + integer :: nvar_emi, nvar_dust12m, nvar_gbbepx real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p1 => NULL() @@ -534,6 +542,15 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta nvar_o2 = 19 nvar_oro_ls_ss = 10 nvar_s2o = 18 + if(Model%rrfs_smoke) then + nvar_dust12m = 5 + nvar_gbbepx = 3 + nvar_emi = 1 + else + nvar_dust12m = 0 + nvar_gbbepx = 0 + nvar_emi = 0 + endif if (Model%lsm == Model%lsm_ruc .and. warm_start) then if(Model%rdlai) then @@ -675,6 +692,150 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, warm_sta !--- deallocate containers and free restart container deallocate(oro_name2, oro_var2) + if_smoke: if(Model%rrfs_smoke) then ! for RRFS-Smoke + + !--- Dust input FILE + !--- open file + infile=trim(indir)//'/'//trim(fn_dust12m) + amiopen=open_file(dust12m_restart, trim(infile), 'read', domain=fv_domain, is_restart=.true., dont_add_res_to_filename=.true.) + if (.not.amiopen) call mpp_error( FATAL, 'Error with opening file'//trim(infile) ) + + if (.not. allocated(dust12m_name)) then + !--- allocate the various containers needed for fengsha dust12m data + allocate(dust12m_name(nvar_dust12m)) + allocate(dust12m_var(nx,ny,12,nvar_dust12m)) + + dust12m_name(1) = 'clay' + dust12m_name(2) = 'rdrag' + dust12m_name(3) = 'sand' + dust12m_name(4) = 'ssm' + dust12m_name(5) = 'uthr' + + !--- register axis + call register_axis(dust12m_restart, 'lon', 'X') + call register_axis(dust12m_restart, 'lat', 'Y') + call register_axis(dust12m_restart, 'time', 12) + !--- register the 3D fields + do num = 1,nvar_dust12m + var3_p2 => dust12m_var(:,:,:,num) + call register_restart_field(dust12m_restart, dust12m_name(num), var3_p2, dimensions=(/'time', 'lat ', 'lon '/),& + &is_optional=.not.mand) + enddo + nullify(var3_p2) + endif + + !--- read new GSL created dust12m restart/data + call mpp_error(NOTE,'reading dust12m information from INPUT/dust12m_data.tile*.nc') + call read_restart(dust12m_restart) + call close_file(dust12m_restart) + + do nb = 1, Atm_block%nblks + !--- 3D 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 + do k = 1, 12 + Sfcprop(nb)%dust12m_in(ix,k,1) = dust12m_var(i,j,k,1) + Sfcprop(nb)%dust12m_in(ix,k,2) = dust12m_var(i,j,k,2) + Sfcprop(nb)%dust12m_in(ix,k,3) = dust12m_var(i,j,k,3) + Sfcprop(nb)%dust12m_in(ix,k,4) = dust12m_var(i,j,k,4) + Sfcprop(nb)%dust12m_in(ix,k,5) = dust12m_var(i,j,k,5) + enddo + enddo + enddo + + deallocate(dust12m_name,dust12m_var) + + !--- open anthropogenic emission file + infile=trim(indir)//'/'//trim(fn_emi) + amiopen=open_file(emi_restart, trim(infile), 'read', domain=fv_domain, is_restart=.true., dont_add_res_to_filename=.true.) + if (.not.amiopen) call mpp_error( FATAL, 'Error with opening file'//trim(infile) ) + + if (.not. allocated(emi_name)) then + !--- allocate the various containers needed for anthropogenic emission data + allocate(emi_name(nvar_emi)) + allocate(emi_var(nx,ny,nvar_emi)) + + emi_name(1) = 'e_oc' + !--- register axis + call register_axis( emi_restart, "grid_xt", 'X' ) + call register_axis( emi_restart, "grid_yt", 'Y' ) + !--- register the 2D fields + do num = 1,nvar_emi + var2_p => emi_var(:,:,num) + call register_restart_field(emi_restart, emi_name(num), var2_p, dimensions=(/'grid_yt','grid_xt'/)) + enddo + nullify(var2_p) + endif + + !--- read new GSL created emi restart/data + call mpp_error(NOTE,'reading emi information from INPUT/emi_data.tile*.nc') + call read_restart(emi_restart) + call close_file(emi_restart) + + 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 + Sfcprop(nb)%emi_in(ix,1) = emi_var(i,j,1) + enddo + enddo + + !--- deallocate containers and free restart container + deallocate(emi_name, emi_var) + + !--- Dust input FILE + !--- open file + infile=trim(indir)//'/'//trim(fn_gbbepx) + amiopen=open_file(gbbepx_restart, trim(infile), 'read', domain=fv_domain, is_restart=.true., dont_add_res_to_filename=.true.) + if (.not.amiopen) call mpp_error( FATAL, 'Error with opening file'//trim(infile) ) + + if (.not. allocated(gbbepx_name)) then + !--- allocate the various containers needed for gbbepx fire data + allocate(gbbepx_name(nvar_gbbepx)) + allocate(gbbepx_var(nx,ny,24,nvar_gbbepx)) + + gbbepx_name(1) = 'ebb_smoke_hr' + gbbepx_name(2) = 'frp_avg_hr' + gbbepx_name(3) = 'frp_std_hr' + + !--- register axis + call register_axis(gbbepx_restart, 'lon', 'X') + call register_axis(gbbepx_restart, 'lat', 'Y') + call register_axis(gbbepx_restart, 't', 24) + !--- register the 3D fields + mand = .false. + do num = 1,nvar_gbbepx + var3_p2 => gbbepx_var(:,:,:,num) + call register_restart_field(gbbepx_restart, gbbepx_name(num), var3_p2, dimensions=(/'t ', 'lat', 'lon'/),& + &is_optional=.not.mand) + enddo + nullify(var3_p2) + endif + + !--- read new GSL created gbbepx restart/data + call mpp_error(NOTE,'reading gbbepx information from INPUT/SMOKE_GBBEPx_data.nc') + call read_restart(gbbepx_restart) + call close_file(gbbepx_restart) + + do nb = 1, Atm_block%nblks + !--- 3D 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 + !--- assign hprime(1:10) and hprime(15:24) with new oro stat data + do k = 1, 24 + Sfcprop(nb)%smoke_GBBEPx(ix,k,1) = gbbepx_var(i,j,k,1) + Sfcprop(nb)%smoke_GBBEPx(ix,k,2) = gbbepx_var(i,j,k,2) + Sfcprop(nb)%smoke_GBBEPx(ix,k,3) = gbbepx_var(i,j,k,3) + enddo + enddo + enddo + + deallocate(gbbepx_name, gbbepx_var) + endif if_smoke ! RRFS_Smoke + !--- Modify/read-in additional orographic static fields for GSL drag suite if (Model%gwd_opt==3 .or. Model%gwd_opt==33 .or. & Model%gwd_opt==2 .or. Model%gwd_opt==22 ) then From 75396def04bc38a3fafdfb581483ad89145b96f8 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 21 Apr 2022 01:17:08 +0000 Subject: [PATCH 094/115] Correction to prior commit: point ccpp-physics to NOAA-GSL gsl/develop --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 8293f36e8..2bdc8706a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8293f36e86e09103d44cce5c23e2b3db30894ce5 +Subproject commit 2bdc8706a97074b0929903eb4afbefedd8fb6312 From 20f6731785de16da1af08a796c64d96773959666 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 22 Apr 2022 18:33:05 +0000 Subject: [PATCH 095/115] point to gsl/merge-develop branch --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index be0d808ba..bb9b928a9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,7 +9,7 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/develop + branch = gsl/merge-develop [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP From db3107cdf5c1a161a3f958f1436c03d05b073e73 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 22 Apr 2022 19:33:33 +0000 Subject: [PATCH 096/115] Point to gsl/merge-develop-to-community branch for ccpp/physics --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index bb9b928a9..df370caa6 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,7 +9,7 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/NOAA-GSL/ccpp-physics - branch = gsl/merge-develop + branch = gsl/merge-develop-to-community [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP From 86a111aaef3d996f9e3f6e83ba93d2c55f8c93c2 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Sat, 23 Apr 2022 22:53:02 +0000 Subject: [PATCH 097/115] Corrections to merge + joe updates --- ccpp/data/CCPP_typedefs.meta | 14 +++++++------- ccpp/data/GFS_typedefs.F90 | 3 --- ccpp/physics | 2 +- ccpp/suites/suite_FV3_HRRR_smoke.xml | 2 +- ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml | 2 +- .../suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml | 2 +- 6 files changed, 11 insertions(+), 14 deletions(-) diff --git a/ccpp/data/CCPP_typedefs.meta b/ccpp/data/CCPP_typedefs.meta index 217889784..fcdaa0e8a 100644 --- a/ccpp/data/CCPP_typedefs.meta +++ b/ccpp/data/CCPP_typedefs.meta @@ -1824,6 +1824,13 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys +[save_q(:,:,index_of_snow_mixing_ratio_in_tracer_concentration_array)] + standard_name = snow_mixing_ratio_save + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys [save_q(:,:,index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array)] standard_name = ice_water_mixing_ratio_save long_name = cloud ice water mixing ratio before entering a physics scheme @@ -2156,13 +2163,6 @@ units = count dimensions = () type = integer -[ud_mf] - standard_name = instantaneous_atmosphere_updraft_convective_mass_flux - long_name = (updraft mass flux) * delt - units = kg m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys [uustar_water] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 895e0c966..576c5ff8f 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -33,9 +33,6 @@ module GFS_typedefs real(kind=kind_phys), parameter :: limit_unspecified = 1e12 !< special constant for "namelist value was not provided" in radar-derived temperature tendency limit range - integer, parameter :: dfi_radar_max_intervals = 4 !< Number of radar-derived temperature tendency and/or convection suppression intervals. Do not change. - - real(kind=kind_phys), parameter :: limit_unspecified = 1e12 !< special constant for "namelist value was not provided" in radar-derived temperature tendency limit range !> \section arg_table_GFS_typedefs !! \htmlinclude GFS_typedefs.html diff --git a/ccpp/physics b/ccpp/physics index 450d8fd8c..d96191612 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 450d8fd8c214f9af2befc3a562864af7a91a8a92 +Subproject commit d96191612fea427cfa8ede167edbb9a09b13a518 diff --git a/ccpp/suites/suite_FV3_HRRR_smoke.xml b/ccpp/suites/suite_FV3_HRRR_smoke.xml index 450007623..e3f51c14d 100644 --- a/ccpp/suites/suite_FV3_HRRR_smoke.xml +++ b/ccpp/suites/suite_FV3_HRRR_smoke.xml @@ -16,7 +16,7 @@ sgscloud_radpre GFS_rrtmg_pre GFS_radiation_surface - rrtmg_sw_pre + rad_sw_pre rrtmg_sw rrtmg_sw_post rrtmg_lw_pre diff --git a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml index 924398609..00ef6952c 100644 --- a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml +++ b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_ugwpv1.xml @@ -16,7 +16,7 @@ sgscloud_radpre GFS_rrtmg_pre GFS_radiation_surface - rrtmg_sw_pre + rad_sw_pre rrtmg_sw rrtmg_sw_post rrtmg_lw_pre diff --git a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml index f639f233f..5230d75d6 100644 --- a/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml +++ b/ccpp/suites/suite_FV3_RAP_noah_sfcdiff_unified_ugwp.xml @@ -16,7 +16,7 @@ sgscloud_radpre GFS_rrtmg_pre GFS_radiation_surface - rrtmg_sw_pre + rad_sw_pre rrtmg_sw rrtmg_sw_post rrtmg_lw_pre From de363fef6cc0bd8308c60d821746439e9bf9ac4a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 15:11:56 +0000 Subject: [PATCH 098/115] Point .gitmodules to Sam's fork --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index df370caa6..cbc075ef1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,7 +8,7 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSL/ccpp-physics + url = https://github.com/SamuelTrahanNOAA/ccpp-physics branch = gsl/merge-develop-to-community [submodule "upp"] path = upp From 8c60e059583022e47cc99bf0e626464756fe6390 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 16:40:04 +0000 Subject: [PATCH 099/115] Correct issues found by reviewers --- ccpp/data/GFS_typedefs.meta | 8 ++++---- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 149c0e2d7..8a0eb0bfa 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -2530,16 +2530,16 @@ kind = kind_phys active = (flag_for_rrfs_smoke_coupling) [smoke_ext] - standard_name = smoke_ext - long_name = smoke optical extinction + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys active = (flag_for_rrfs_smoke_coupling) [dust_ext] - standard_name = dust_ext - long_name = dust optical extinction + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/ccpp/physics b/ccpp/physics index d96191612..89c0c11fb 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d96191612fea427cfa8ede167edbb9a09b13a518 +Subproject commit 89c0c11fbb9559a348ee6dbd949061676e4ee43e From dbb405cf55ea5767e2a3c482f767747e966c7390 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 17:43:15 +0000 Subject: [PATCH 100/115] Rename mynnpbl to mynnedmf --- ccpp/config/ccpp_prebuild_config.py | 2 +- ccpp/data/GFS_typedefs.meta | 4 ++-- ccpp/physics | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index b83f25c4a..a95b86203 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -176,7 +176,7 @@ 'physics/physics/satmedmfvdifq.F', 'physics/physics/shinhongvdif.F90', 'physics/physics/ysuvdif.F90', - 'physics/physics/mynnpbl_wrapper.F90', + 'physics/physics/mynnedmf_wrapper.F90', 'physics/physics/mynnsfc_wrapper.F90', 'physics/physics/sgscloud_radpre.F90', 'physics/physics/sgscloud_radpost.F90', diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 8a0eb0bfa..ce03233b2 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -8010,7 +8010,7 @@ type = integer active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme) [exch_h] - standard_name = atmosphere_heat_diffusivity_for_mynnpbl + standard_name = atmosphere_heat_diffusivity_for_mynnedmf long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -8018,7 +8018,7 @@ kind = kind_phys active = (flag_for_mellor_yamada_nakanishi_niino_pbl_scheme) [exch_m] - standard_name = atmosphere_momentum_diffusivity_for_mynnpbl + standard_name = atmosphere_momentum_diffusivity_for_mynnedmf long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/ccpp/physics b/ccpp/physics index 89c0c11fb..86022b310 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 89c0c11fbb9559a348ee6dbd949061676e4ee43e +Subproject commit 86022b3104278c7f0df217293dbaba6f43cbeff2 From dc25f3d620171713f3470f01f9f66b7e64d632f4 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 21:29:04 +0000 Subject: [PATCH 101/115] Remove some empty _init and _finalize routines and update a comment in sgscloud_radpre --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 86022b310..900e2c3e1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 86022b3104278c7f0df217293dbaba6f43cbeff2 +Subproject commit 900e2c3e1f3a4aa82c35ad99f9456edd56c6599c From 45955d0740346a7ba2f76a00f9df2b927fd7e7fe Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 28 Apr 2022 23:31:07 +0000 Subject: [PATCH 102/115] Add \file to smoke files --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 900e2c3e1..3fba41233 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 900e2c3e1f3a4aa82c35ad99f9456edd56c6599c +Subproject commit 3fba412336314ac008ed70a45d85e17024dd7cef From 24007117621f725665865dd657803f2f9cf38849 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 16:51:50 +0000 Subject: [PATCH 103/115] adding bug fix from jili dong and removing U* averaging --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 3fba41233..cf9e00319 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3fba412336314ac008ed70a45d85e17024dd7cef +Subproject commit cf9e00319c1ed6319c9b1d8e8fde60e7a602a52a From 189806f4e5edf6f3fef7310ed934c4c0cac2df11 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 16:52:59 +0000 Subject: [PATCH 104/115] adding bug fix from jili dong and removing U* averaging --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index cf9e00319..bb45b2b08 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit cf9e00319c1ed6319c9b1d8e8fde60e7a602a52a +Subproject commit bb45b2b08f87c2737937e7a3ef835033715aec72 From ba5e9b779f4776734f5c937cb6ab1bfe03203d49 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 16:48:03 +0000 Subject: [PATCH 105/115] Remove some commented-out code from cu_gf_driver in ccpp-physics. --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index c00a4f01b..3b7423b3d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c00a4f01b3090044541ffb2a38e71d02822f298a +Subproject commit 3b7423b3d97f45a901e077518b0750d6473b03af From fda178fcb5812a3be2081751ac1682399262c611 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 17:44:21 +0000 Subject: [PATCH 106/115] Turn rrtmg smoke band 10 into a model namelist variable --- ccpp/data/GFS_typedefs.F90 | 24 +++++++++++++++++++++++- ccpp/data/GFS_typedefs.meta | 6 ++++++ ccpp/physics | 2 +- 3 files changed, 30 insertions(+), 2 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index f748af8fb..9c8735b95 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -665,6 +665,7 @@ module GFS_typedefs logical :: cplaqm !< default no cplaqm collection logical :: cplchm !< default no cplchm collection logical :: rrfs_smoke !< default no rrfs_smoke collection + integer :: dust_smoke_rrtmg_band_number !< band number to affect in rrtmg_pre from smoke and dust logical :: use_cice_alb !< default .false. - i.e. don't use albedo imported from the ice model logical :: cpl_imp_mrg !< default no merge import with internal forcings logical :: cpl_imp_dbg !< default no write import data to file post merge @@ -2871,6 +2872,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: cplaqm = .false. !< default no cplaqm collection logical :: cplchm = .false. !< default no cplchm collection logical :: rrfs_smoke = .false. !< default no rrfs_smoke collection + integer :: dust_smoke_rrtmg_band_number = 10!< band number to affect in rrtmg_pre from smoke and dust logical :: use_cice_alb = .false. !< default no cice albedo logical :: cpl_imp_mrg = .false. !< default no merge import with internal forcings logical :: cpl_imp_dbg = .false. !< default no write import data to file post merge @@ -3385,7 +3387,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- coupling parameters cplflx, cplice, cplocn2atm, cplwav, cplwav2atm, cplaqm, & cplchm, cpl_imp_mrg, cpl_imp_dbg, rrfs_smoke, & - use_cice_alb, & + use_cice_alb, dust_smoke_rrtmg_band_number, & #ifdef IDEA_PHYS lsidea, weimer_model, f107_kp_size, f107_kp_interval, & f107_kp_skip_size, f107_kp_data_size, f107_kp_read_in_start, & @@ -3712,6 +3714,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- RRFS Smoke Model%rrfs_smoke = rrfs_smoke + Model%dust_smoke_rrtmg_band_number = dust_smoke_rrtmg_band_number Model%seas_opt = seas_opt Model%dust_opt = dust_opt Model%biomass_burn_opt = biomass_burn_opt @@ -5586,6 +5589,25 @@ subroutine control_print(Model) print *, ' use_cice_alb : ', Model%use_cice_alb print *, ' cpl_imp_mrg : ', Model%cpl_imp_mrg print *, ' cpl_imp_dbg : ', Model%cpl_imp_dbg + if(model%rrfs_smoke) then + print *, ' ' + print *, 'smoke parameters' + print *, 'dust_smoke_rrtmg_band_number : ',Model%dust_smoke_rrtmg_band_number + print *, 'seas_opt : ',Model%seas_opt + print *, 'dust_opt : ',Model%dust_opt + print *, 'biomass_burn_opt : ',Model%biomass_burn_opt + print *, 'drydep_opt : ',Model%drydep_opt + print *, 'wetdep_ls_opt : ',Model%wetdep_ls_opt + print *, 'do_plumerise : ',Model%do_plumerise + print *, 'plumerisefire_frq: ',Model%plumerisefire_frq + print *, 'addsmoke_flag : ',Model%addsmoke_flag + print *, 'smoke_forecast : ',Model%smoke_forecast + print *, 'aero_ind_fdb : ',Model%aero_ind_fdb + print *, 'aero_dir_fdb : ',Model%aero_dir_fdb + print *, 'rrfs_smoke_debug : ',Model%rrfs_smoke_debug + print *, 'mix_chem : ',Model%mix_chem + print *, 'fire_turb : ',Model%fire_turb + endif print *, ' ' print *, ' lsidea : ', Model%lsidea print *, ' ' diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index ce03233b2..a0fa8ebf5 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -2939,6 +2939,12 @@ units = flag dimensions = () type = logical +[dust_smoke_rrtmg_band_number] + standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + long_name = rrtmg band number that smoke and dust should affect + units = count + dimensions = () + type = integer [cpl_imp_mrg] standard_name = flag_for_merging_imported_data long_name = flag controlling cpl_imp_mrg for imported data (default off) diff --git a/ccpp/physics b/ccpp/physics index 3b7423b3d..cd410130f 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3b7423b3d97f45a901e077518b0750d6473b03af +Subproject commit cd410130fcf0de0ea68c7dd98e0ecd0ccb85855f From da0435f2665a0be3df52deb985c202dc4193da7a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 18:36:15 +0000 Subject: [PATCH 107/115] Switch ccpp-physics smoke arguments to implied shape --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index cd410130f..20cbc054a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit cd410130fcf0de0ea68c7dd98e0ecd0ccb85855f +Subproject commit 20cbc054ac168d16b741520617836c0f888beb64 From ebbcfb76fa97f7d5f87fff6931cb7de942fc8d51 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 20:20:29 +0000 Subject: [PATCH 108/115] Remove some stops and gotos from ccpp-physics smoke --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 20cbc054a..f76236fb7 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 20cbc054ac168d16b741520617836c0f888beb64 +Subproject commit f76236fb7d3dfd4716060f45ba49fe7750bebdab From 1fc9e5fb76e150f3a57fb2f4adfeb4543230bb6a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 20:00:44 +0000 Subject: [PATCH 109/115] Remove some hard-coded constants and rename some meta entries --- ccpp/data/GFS_typedefs.meta | 138 ++++++++++++++++++------------------ ccpp/physics | 2 +- 2 files changed, 70 insertions(+), 70 deletions(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index a0fa8ebf5..33ed791ba 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -309,14 +309,14 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys -[qgrs(:,:,index_for_smoke)] +[qgrs(:,:,index_for_smoke_in_tracer_concentration_array)] standard_name = smoke_tracer_concentration long_name = concentration of smoke units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys -[qgrs(:,:,index_for_dust)] +[qgrs(:,:,index_for_dust_in_tracer_concentration_array)] standard_name = dust_tracer_concentration long_name = concentration of dust units = kg kg-1 @@ -737,7 +737,7 @@ dimensions = (horizontal_dimension,12,5) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [emi_in] standard_name = anthropogenic_background_input long_name = anthropogenic background input @@ -745,7 +745,7 @@ dimensions = (horizontal_dimension,1) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [smoke_GBBEPx] standard_name = emission_smoke_GBBEPx long_name = emission fire GBBEPx @@ -753,7 +753,7 @@ dimensions = (horizontal_dimension,24,3) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [z0base] standard_name = baseline_surface_roughness_length long_name = baseline surface roughness length for momentum in meter @@ -2440,7 +2440,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [nwfa2d] standard_name = tendency_of_hygroscopic_aerosols_at_surface_adjacent_layer long_name = instantaneous water-friendly sfc aerosol source @@ -2464,7 +2464,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [emseas] standard_name = emission_of_seas_for_smoke long_name = emission of seas for smoke @@ -2472,7 +2472,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [emanoc] standard_name = emission_of_anoc_for_thompson_mp long_name = emission of anoc for thompson mp @@ -2480,55 +2480,55 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [ebb_smoke_hr] - standard_name = surfce_emission_of_smoke + standard_name = surface_smoke_emission long_name = emission of surface smoke units = ug m-2 s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [frp_hr] standard_name = frp_hourly - long_name = hourly frp - units = mw + long_name = hourly fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [frp_std_hr] standard_name = frp_std_hourly - long_name = hourly std frp - units = mw + long_name = hourly stdandard deviation of fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [fhist] - standard_name = fhist - long_name = fire hist + standard_name = fire_hist + long_name = coefficient to scale the fire activity depending on the fire duration units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [coef_bb_dc] standard_name = coef_bb_dc - long_name = coef bb dc from plumerise + long_name = coef to estimate the fire emission units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [ebu_smoke] standard_name = ebu_smoke - long_name = smoke buffer of ebu + long_name = buffer of vertical fire emission units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [smoke_ext] standard_name = extinction_coefficient_in_air_due_to_smoke long_name = extinction coefficient in air due to smoke @@ -2536,7 +2536,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [dust_ext] standard_name = extinction_coefficient_in_air_due_to_dust long_name = extinction coefficient in air due to dust @@ -2544,7 +2544,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [chem3d] standard_name = chem3d_mynn_pbl_transport long_name = mynn pbl transport of smoke and dust @@ -2552,31 +2552,31 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [min_fplume] - standard_name = min_fplume - long_name = miminum plume height + standard_name = minimum_fire_plume_sigma_pressure_level + long_name = minimum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [max_fplume] - standard_name = max_fplume - long_name = maximum plume height + standard_name = maximum_fire_plume_sigma_pressure_level + long_name = maximum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [rrfs_hwp] - standard_name = rrfs_hwp + standard_name = hourly_wildfire_potential long_name = rrfs hourly fire weather potential units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [ushfsfci] standard_name = surface_upward_sensible_heat_flux_for_chemistry_coupling long_name = instantaneous upward sensible heat flux for chemistry coupling @@ -2934,13 +2934,13 @@ dimensions = () type = logical [rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling + standard_name = do_smoke_coupling long_name = flag controlling rrfs_smoke collection (default off) units = flag dimensions = () type = logical [dust_smoke_rrtmg_band_number] - standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + standard_name = index_of_shortwave_band_affected_by_smoke long_name = rrtmg band number that smoke and dust should affect units = count dimensions = () @@ -5402,13 +5402,13 @@ dimensions = () type = integer [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () @@ -5523,103 +5523,103 @@ dimensions = () type = integer [mix_chem] - standard_name = rrfs_smoke_mynn_tracer_mixing + standard_name = do_planetary_boundary_layer_smoke_mixing long_name = flag for rrfs smoke mynn tracer mixing units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [fire_turb] - standard_name = rrfs_smoke_mynn_enh_vermix + standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [seas_opt] - standard_name = rrfs_smoke_sea_salt_opt + standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [dust_opt] - standard_name = rrfs_smoke_dust_opt + standard_name = control_for_smoke_dust long_name = rrfs smoke dust chem option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [biomass_burn_opt] - standard_name = rrfs_smoke_biomass_burn_opt + standard_name = control_for_smoke_biomass_burn long_name = rrfs smoke biomass burning option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [drydep_opt] - standard_name = rrfs_smoke_drydep_opt + standard_name = control_for_smoke_dry_deposition long_name = rrfs smoke dry deposition option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [wetdep_ls_opt] - standard_name = rrfs_smoke_wetdep_ls_opt + standard_name = control_for_smoke_wet_deposition long_name = rrfs smoke large scale wet deposition option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [do_plumerise] - standard_name = rrfs_smoke_plumerise_flag + standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option units = index dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [plumerisefire_frq] - standard_name = rrfs_smoke_plumerisefire_frq + standard_name = smoke_plumerise_frequency long_name = rrfs smoke add smoke option - units = index + units = min dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [addsmoke_flag] standard_name = rrfs_smoke_addsmoke_flag long_name = rrfs smoke add smoke option units = index dimensions = () type = integer - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [smoke_forecast] - standard_name = rrfs_smoke_smoke_forecast_opt + standard_name = do_smoke_forecast long_name = flag for rrfs smoke forecast units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [aero_ind_fdb] - standard_name = rrfs_smoke_aero_ind_fdb_opt - long_name = flag for rrfs wfa ifa emission + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for wfa ifa emission indirect feedback units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [aero_dir_fdb] - standard_name = rrfs_smoke_dust_rad_fdb_opt - long_name = flag for rrfs smoke dust rad feedback + standard_name = do_smoke_aerosol_direct_feedback + long_name = flag for smoke and dust radiation feedback units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [rrfs_smoke_debug] - standard_name = rrfs_smoke_plumerise_debug + standard_name = do_smoke_debug long_name = flag for rrfs smoke plumerise debug units = flag dimensions = () type = logical - active = (flag_for_rrfs_smoke_coupling) + active = (do_smoke_coupling) [ncnvcld3d] standard_name = number_of_convective_cloud_variables_in_xyz_dimensioned_restart_array long_name = number of convective 3d clouds fields diff --git a/ccpp/physics b/ccpp/physics index f76236fb7..aaca3b0f8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f76236fb7d3dfd4716060f45ba49fe7750bebdab +Subproject commit aaca3b0f8bf777aaa10eec8f60b2d43a2ce7d7cb From b03c9559a814a1ef300033d837fc54e78a6676c8 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 21:17:07 +0000 Subject: [PATCH 110/115] Rename some standard_names, change a unit, and remove a "use physcons" --- ccpp/data/GFS_typedefs.meta | 16 ++++++++-------- ccpp/physics | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 33ed791ba..0c7cf73dd 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -5586,7 +5586,7 @@ type = integer active = (do_smoke_coupling) [addsmoke_flag] - standard_name = rrfs_smoke_addsmoke_flag + standard_name = control_for_smoke_biomass_burning_emissions long_name = rrfs smoke add smoke option units = index dimensions = () @@ -6030,7 +6030,7 @@ [bl_mynn_closure] standard_name = control_for_closure_level_in_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to determine the closure level for the mynn - units = flag + units = 1 dimensions = () type = real [icloud_bl] @@ -6040,25 +6040,25 @@ dimensions = () type = integer [isftcflx] - standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_water long_name = flag for thermal roughness lengths over water in mynnsfclay - units = flag + units = 1 dimensions = () type = integer [iz0tlnd] - standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_land long_name = flag for thermal roughness lengths over land in mynnsfclay - units = flag + units = 1 dimensions = () type = integer [sfclay_compute_flux] - standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + standard_name = do_compute_surface_scalar_fluxes long_name = flag for computing surface scalar fluxes in mynnsfclay units = flag dimensions = () type = logical [sfclay_compute_diag] - standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + standard_name = do_compute_surface_diagnostics long_name = flag for computing surface diagnostics in mynnsfclay units = flag dimensions = () diff --git a/ccpp/physics b/ccpp/physics index aaca3b0f8..552d948c6 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit aaca3b0f8bf777aaa10eec8f60b2d43a2ce7d7cb +Subproject commit 552d948c6f824386623b59c0c569994e43c98700 From 8edf82ecb7b8d6f0bbbe34857e37cedaaf61953d Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 11 May 2022 18:05:46 +0000 Subject: [PATCH 111/115] Set num3d correctly when using radar_tten --- ccpp/driver/GFS_restart.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index 1ffaed4dc..8d61604d0 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -145,6 +145,14 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%num3d = Restart%num3d + 9 endif + if (Model%num_dfi_radar > 0) then + do itime=1,Model%dfi_radar_max_intervals + if(Model%ix_dfi_radar(itime)>0) then + Restart%num3d = Restart%num3d + 1 + endif + enddo + endif + allocate (Restart%name2d(Restart%num2d)) allocate (Restart%name3d(Restart%num3d)) allocate (Restart%data(nblks,max(Restart%num2d,Restart%num3d))) From fe3050034fc456dbe7759f615c8453aaa3579c71 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 13 May 2022 21:26:00 +0000 Subject: [PATCH 112/115] Only add cnv_3d_ud_mf to the restart files when needed --- ccpp/driver/GFS_restart.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ccpp/driver/GFS_restart.F90 b/ccpp/driver/GFS_restart.F90 index 8d61604d0..73e181b5f 100644 --- a/ccpp/driver/GFS_restart.F90 +++ b/ccpp/driver/GFS_restart.F90 @@ -133,7 +133,7 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & Restart%num3d = Model%ntot3d+1 endif ! General Convection - if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then Restart%num3d = Restart%num3d + 1 endif ! GF @@ -437,8 +437,9 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & num = Model%ntot3d endif - !--Convection variable used in CB cloud fraction - if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + !--Convection variable used in CB cloud fraction. Presently this + !--is only needed in sgscloud_radpre for imfdeepcnv == imfdeepcnv_gf. + if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then num = num + 1 Restart%name3d(num) = 'cnv_3d_ud_mf' do nb = 1,nblks From e3a3c7e4247243887044cce598eb17cae89f3b29 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 16 May 2022 17:45:30 +0000 Subject: [PATCH 113/115] Pass some chemistry varibles to mynn_bl_driver correctly --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 90095d14f..eb1ba7042 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 90095d14fd84c5144076967e9a71b9ab39f32d5d +Subproject commit eb1ba70428315983b4e4b8a66da200a0c635bc75 From 981e49d8afe44a3f343ae4b87d21b9fd1bcb1edd Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 16 May 2022 21:10:06 +0000 Subject: [PATCH 114/115] Correct argument passing within mynn edmf --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index eb1ba7042..1a70737a3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit eb1ba70428315983b4e4b8a66da200a0c635bc75 +Subproject commit 1a70737a39d57b525cf1e73604f203a6c6dc7b6e From 4bf92d9f928759dd6f183eb4ae6679b034dc8c21 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 17 May 2022 15:55:42 +0000 Subject: [PATCH 115/115] point to NCAR main ccpp/physics --- .gitmodules | 4 ++-- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index cbc075ef1..6bb663df1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,8 +8,8 @@ branch = main [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/SamuelTrahanNOAA/ccpp-physics - branch = gsl/merge-develop-to-community + url = https://github.com/NCAR/ccpp-physics + branch = main [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP diff --git a/ccpp/physics b/ccpp/physics index 90095d14f..01e3d6b35 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 90095d14fd84c5144076967e9a71b9ab39f32d5d +Subproject commit 01e3d6b35c44b1f32abe8b294b414cc29b0ab554