diff --git a/.gitmodules b/.gitmodules
index 77e9c2fc56..a93aba501a 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -44,7 +44,7 @@
path = src/dynamics/fv3
url = https://github.com/ESCOMP/CAM_FV3_interface.git
fxrequired = AlwaysRequired
- fxtag = fv3int_053124
+ fxtag = fv3int_061924
fxDONOTUSEurl = https://github.com/ESCOMP/CAM_FV3_interface.git
[submodule "geoschem"]
@@ -144,7 +144,7 @@ fxDONOTUSEurl = https://github.com/ESMCI/cime
[submodule "cmeps"]
path = components/cmeps
url = https://github.com/ESCOMP/CMEPS.git
-fxtag = cmeps0.14.63
+fxtag = cmeps0.14.67
fxrequired = ToplevelRequired
fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git
@@ -179,7 +179,7 @@ fxDONOTUSEurl = https://github.com/NCAR/ParallelIO
[submodule "cice"]
path = components/cice
url = https://github.com/ESCOMP/CESM_CICE
-fxtag = cesm_cice6_5_0_9
+fxtag = cesm_cice6_5_0_10
fxrequired = ToplevelRequired
fxDONOTUSEurl = https://github.com/NCAR/ParallelIO
diff --git a/bld/build-namelist b/bld/build-namelist
index d27f98fc5d..bdcbcbfcdf 100755
--- a/bld/build-namelist
+++ b/bld/build-namelist
@@ -1567,7 +1567,7 @@ elsif ($carma eq 'tholin') {
# turn on stratospheric aerosol forcings in CAM6 configurations
my $chem_has_ocs = chem_has_species($cfg, 'OCS');
-if (($phys =~ /cam6/ or $phys =~ /cam_dev/) and $chem =~ /_mam/) {
+if (($phys =~ /cam6/ or $phys =~ /cam7/) and $chem =~ /_mam/) {
# turn on volc forcings in cam6 -- prognostic or prescribed
if ( $chem_has_ocs ) {
# turn on prognostic stratospheric aerosols
@@ -1597,9 +1597,9 @@ if (chem_has_species($cfg, 'O3S')) {
# stratospheric aerosols are needed for heterogeneous chemistry as well as radiation feedback
my $het_chem = chem_has_species($cfg, 'N2O5');
-# Default for CAM6, is that prescribed_strataero_3modes is TRUE, but allow user to override
+# Default for cam6 and cam7 is that prescribed_strataero_3modes is TRUE, but allow user to override
my $prescribed_strataero_3modes = $FALSE;
-if ($phys =~ /cam6/ or $phys =~ /cam_dev/) {
+if ($phys =~ /cam6/ or $phys =~ /cam7/) {
$prescribed_strataero_3modes = $TRUE;
}
if (defined $nl->get_value('prescribed_strataero_3modes')) {
@@ -1855,7 +1855,7 @@ my $megan_emis = defined $nl->get_value('megan_specifier');
if ( $megan_emis ) { add_default($nl, 'megan_factors_file'); }
# Tropospheric full chemistry options
-if (($chem =~ /trop_mozart/ or $chem =~ /trop_strat/ or $chem =~ /waccm_tsmlt/) and ($phys !~ /cam6/) and ($phys !~ /cam_dev/)) {
+if (($chem =~ /trop_mozart/ or $chem =~ /trop_strat/ or $chem =~ /waccm_tsmlt/) and ($phys !~ /cam6/) and ($phys !~ /cam7/)) {
# Surface emission datasets:
my %verhash;
@@ -2229,7 +2229,7 @@ if ($chem eq 'trop_mam3') {
}
# CMIP6 emissions
-if (($chem =~ /_mam4/ or $chem =~ /_mam5/) and ($phys =~ /cam6/ or $phys =~ /cam_dev/)) {
+if (($chem =~ /_mam4/ or $chem =~ /_mam5/) and ($phys =~ /cam6/ or $phys =~ /cam7/)) {
# OASISS (ocean) DMS emissions
if (!$aqua_mode and !$scam) {
@@ -2390,7 +2390,7 @@ if (($chem =~ /_mam4/ or $chem =~ /_mam5/) and ($phys =~ /cam6/ or $phys =~ /cam
}
}
- # Note, this section might need to be modified if cam_dev values
+ # Note, this section might need to be modified if cam7 values
# diverge from cam6 values
my %verhash = ('ver'=>'cam6');
my $first = 1;
@@ -3151,15 +3151,15 @@ if (($chem ne 'none') and ($chem ne 'terminator') and !($chem =~ /geoschem/)) {
add_default($nl, 'deep_scheme');
# Aerosol convective processes
-if (($phys =~ /cam6/ or $phys =~ /cam_dev/) and $nl->get_value('deep_scheme') =~ /ZM/) {
+if (($phys =~ /cam6/ or $phys =~ /cam7/) and $nl->get_value('deep_scheme') =~ /ZM/) {
add_default($nl, 'convproc_do_aer', 'val'=>'.true.');
add_default($nl, 'convproc_do_evaprain_atonce', 'val'=>'.true.');
add_default($nl, 'convproc_pom_spechygro', 'val'=>'0.2D0');
add_default($nl, 'convproc_wup_max', 'val'=>'4.0D0');
}
-# cam_dev specific namelists
-if ($phys =~ /cam_dev/ and $nl->get_value('deep_scheme') =~ /ZM/) {
+# cam7 specific namelists
+if ($phys =~ /cam7/ and $nl->get_value('deep_scheme') =~ /ZM/) {
add_default($nl, 'zmconv_parcel_pbl', 'val'=>'.true.');
} else {
add_default($nl, 'zmconv_parcel_pbl', 'val'=>'.false.');
@@ -3212,8 +3212,8 @@ if ($cfg->get('microphys') =~ /^mg/) {
# namelist options for pumas tag release_v1.22 or later
- # (currently only in the cam_dev physics package)
- if ($phys =~ /cam_dev/) {
+ # (currently only in the cam7 physics package)
+ if ($phys =~ /cam7/) {
add_default($nl, 'micro_mg_warm_rain');
add_default($nl, 'micro_mg_accre_sees_auto');
add_default($nl, 'micro_mg_vtrms_factor');
@@ -3230,7 +3230,7 @@ if ($cfg->get('microphys') =~ /^mg/) {
}else {
# For CESM2, the decision was made to set micro_do_sb_physics to false
- # This variable is replaced with micro_mg_warm_rain in cam_dev runs
+ # This variable is replaced with micro_mg_warm_rain in cam7 runs
add_default($nl, 'micro_do_sb_physics', 'val'=>'.false.');
}
@@ -3246,13 +3246,13 @@ if ($cfg->get('microphys') =~ /^mg/) {
$micro_mg_dcs = '390.D-6'; # default for SIHLS
}
elsif ($hgrid =~ /1.9x2.5/ and $phys eq 'cam6') {
- $micro_mg_dcs = '200.D-6'; # default for FV 2-deg
+ $micro_mg_dcs = '200.D-6';
}
elsif ($phys eq 'cam6') {
- $micro_mg_dcs = '500.D-6'; # default for cam6
+ $micro_mg_dcs = '500.D-6';
}
- elsif ($phys eq 'cam_dev') {
- $micro_mg_dcs = '500.D-6'; # default for cam_dev
+ elsif ($phys eq 'cam7') {
+ $micro_mg_dcs = '500.D-6';
}
}
@@ -3358,6 +3358,12 @@ if ($use_subcol_microp =~ /$TRUE/io) {
}
# CLUBB_SGS
+my $do_clubb_sgs = $nl->get_value('do_clubb_sgs');
+if (defined $do_clubb_sgs) {
+ die "CAM Namelist ERROR: User may not specify the value of do_clubb_sgs.\n".
+ "This variable is set by build-namelist based on information\n".
+ "from the configure cache file.\n";
+}
add_default($nl, 'do_clubb_sgs');
my $clubb_sgs = $nl->get_value('do_clubb_sgs');
if ($clubb_sgs =~ /$TRUE/io) {
@@ -3526,13 +3532,6 @@ if ($clubb_sgs =~ /$TRUE/io) {
add_default($nl, 'do_hb_above_clubb');
}
-# Force exit if running cam_dev and CLUBB is off
-if ($phys eq 'cam_dev') {
- if ($clubb_sgs =~ /$FALSE/io) {
- die "$ProgName - ERROR: If running cam_dev physics, do_clubb_sgs must be .true.\n";
- }
-}
-
# Tuning for wet scavenging of modal aerosols
if ($chem =~ /_mam/) {
add_default($nl, 'sol_facti_cloud_borne');
@@ -3720,7 +3719,7 @@ if ($chem =~ /_mam(\d)/) {
# By default, orographic waves are always on
if (!$simple_phys) {
- if ($phys =~ /cam6/ or $phys =~ /cam_dev/) {
+ if ($phys =~ /cam6/ or $phys =~ /cam7/) {
add_default($nl, 'use_gw_oro', 'val'=>'.false.');
@@ -3751,7 +3750,7 @@ if (!$simple_phys) {
}
if ($waccm_phys or
- (!$simple_phys and $cfg->get('nlev') >= 60)) {
+ (!$simple_phys and $cfg->get('model_top') eq 'mt')) {
# Spectral gravity waves are part of WACCM physics, and also drive the
# QBO in the high vertical resolution configuration.
add_default($nl, 'use_gw_front' , 'val'=>'.true.');
@@ -3774,8 +3773,8 @@ if ($waccm_phys or
}
add_default($nl, 'gw_qbo_hdepth_scaling', 'val'=>$hdepth_scaling);
add_default($nl, 'gw_top_taper');
-} elsif ($phys =~ /cam_dev/) {
- # cam_dev settings for nlev<60 (Other cam_dev set above)
+} elsif ($phys =~ /cam7/) {
+ # cam7 settings for model_top = 'lt'
add_default($nl, 'use_gw_front' , 'val'=>'.true.');
add_default($nl, 'use_gw_convect_dp', 'val'=>'.true.');
add_default($nl, 'gw_qbo_hdepth_scaling', 'val'=>'1.0D0');
@@ -3911,7 +3910,7 @@ if ((not $waccm_phys) and
($do_gw_front or $do_gw_front_igw or
$do_gw_convect_dp or $do_gw_convect_sh )) {
add_default($nl, 'tau_0_ubc', 'val'=>'.true.');
-} elsif ($phys =~ /cam_dev/) {
+} elsif ($phys =~ /cam7/) {
add_default($nl, 'tau_0_ubc', 'val'=>'.true.');
} elsif (!$simple_phys) {
add_default($nl, 'tau_0_ubc', 'val'=>'.false.');
@@ -5109,8 +5108,8 @@ sub check_snapshot_settings {
if ($chem ne 'none') {
push (@validList_bc, ("'chem_timestep_tend'"));
}
- } elsif ($phys =~ /cam_dev/) {
- # CAM_DEV physpkg
+ } elsif ($phys =~ /cam7/) {
+ # cam7 physpkg
push(@validList_ac, ("'chem_emissions'",
"'clubb_tend_cam'",
"'microp_section'"));
diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml
index abefa7cbbe..eca0f0d9a1 100644
--- a/bld/config_files/definition.xml
+++ b/bld/config_files/definition.xml
@@ -57,8 +57,8 @@ Option to turn on waccmx thermosphere/ionosphere extension: 0 => no, 1 => yes
Ionosphere model used in WACCMX.
-
-Physics package: cam3, cam4, cam5, cam6, cam_dev, held_suarez, adiabatic, kessler, tj2016, grayrad, spcam_sam1mom, spcam_m2005.
+
+Physics package: cam3, cam4, cam5, cam6, cam7, held_suarez, adiabatic, kessler, tj2016, grayrad, spcam_sam1mom, spcam_m2005.
Switch to turn on Harmonized Emissions Component (HEMCO) for chemistry: 0 => no, 1 => yes.
diff --git a/bld/configure b/bld/configure
index 2f8319fc70..fdcee657e6 100755
--- a/bld/configure
+++ b/bld/configure
@@ -69,7 +69,7 @@ OPTIONS
waccm_mad_mam4 | waccm_ma_mam4 | waccm_tsmlt_mam4 | waccm_tsmlt_mam4_vbsext | waccm_mad_mam5 |
waccm_ma_mam5 | waccm_tsmlt_mam5 | waccm_tsmlt_mam5_vbsext | geoschem_mam4 ].
Default: trop_mam4 for cam6 and trop_mam3 for cam5.
- -[no]clubb_sgs Switch on [off] CLUBB_SGS. Default: on for cam6, otherwise off.
+ -[no]clubb_sgs Switch on [off] CLUBB_SGS. Default: on for cam6 and cam7, otherwise off.
-clubb_opts Comma separated list of CLUBB options to turn on/off. By default they are all off.
Current option is: clubb_do_adv (Advect CLUBB moments)
-co2_cycle This option modifies the CAM configuration by
@@ -89,7 +89,7 @@ OPTIONS
-max_n_rad_cnst Maximum number of constituents that are either radiatively
active, or in any single diagnostic list for the radiation.
-microphys Specify the microphysics option [mg1 | mg2 | mg3| rk | pumas].
- -model_top Specify the model_top option [ lt | mt ].
+ -model_top Specify the model_top option for cam7 [ lt | mt ].
-nadv Set total number of advected species to .
-nadv_tt Set number of advected test tracers .
-nlev Set number of levels to .
@@ -97,7 +97,7 @@ OPTIONS
-pbl Specify the PBL option [uw | hb | hbr].
-pcols Set maximum number of columns in a chunk to .
-pergro Switch enables building CAM for perturbation growth tests.
- -phys Physics option [cam3 | cam4 | cam5 | cam6 | cam_dev |
+ -phys Physics option [cam3 | cam4 | cam5 | cam6 | cam7 |
held_suarez | adiabatic | kessler | tj2016 | grayrad
spcam_sam1mom | spcam_m2005]. Default: cam6
-prog_species Comma-separate list of prognostic mozart species packages.
@@ -212,6 +212,7 @@ EOF
# command was issued from the current working directory.
(my $ProgName = $0) =~ s!(.*)/!!; # name of this script
+$ProgName = "CAM $ProgName"; # distinquish from other components configure
my $ProgDir = $1; # name of directory containing this script -- may be a
# relative or absolute path, or null if the script is in
# the user's PATH
@@ -537,21 +538,16 @@ if ($print>=2) { print "Coupling framework: $cpl$eol"; }
#-----------------------------------------------------------------------------------------------
# Physics package
-#
-# The default physics package is cam6. Physics packages >=cam5 use chemistry packages
-# that include modal aerosols, i.e., the -chem value matches /_mam/. If the chem_pkg
-# name doesn't match /_mam/ then set the default physics package to cam4.
-my $phys_pkg = 'cam6';
-if (defined $opts{'chem'} and $opts{'chem'} !~ /_mam/) {
- $phys_pkg = 'cam4';
-}
-elsif (defined $opts{'waccmx'}) {
- $phys_pkg = 'cam4';
-}
-# user override
+my $phys_pkg = 'not_set';
+
+# There is no default physics package. It is always specified by the CAM component part
+# of a compset longname. Add check that -phys has been set.
+
if (defined $opts{'phys'}) {
$phys_pkg = lc($opts{'phys'});
+} else {
+ die "$ProgName ERROR: the -phys option must be set";
}
# Add to the config object.
@@ -569,7 +565,7 @@ if ($phys_pkg =~ m/^adiabatic$|^held_suarez$|^kessler$|^tj2016$|^grayrad$/) {
#-----------------------------------------------------------------------------------------------
# Chemistry package
-my $chem_pkg = 'trop_mam4';
+my $chem_pkg = 'not_set';
# defaults based on physics package
if ($simple_phys or $phys_pkg =~ m/^cam[34]$/ or $phys_pkg eq 'spcam_sam1mom') {
@@ -578,6 +574,12 @@ if ($simple_phys or $phys_pkg =~ m/^cam[34]$/ or $phys_pkg eq 'spcam_sam1mom') {
elsif ($phys_pkg eq 'cam5' or $phys_pkg eq 'spcam_m2005') {
$chem_pkg = 'trop_mam3';
}
+elsif ($phys_pkg eq 'cam6') {
+ $chem_pkg = 'trop_mam4';
+}
+elsif ($phys_pkg eq 'cam7') {
+ $chem_pkg = 'ghg_mam4';
+}
# some overrides for special configurations
if (defined $opts{'prog_species'}) {
@@ -678,17 +680,6 @@ my $max_n_rad_cnst = $cfg_ref->get('max_n_rad_cnst');
if ($print>=2) { print "Maximum radiatively active tracers: $max_n_rad_cnst$eol"; }
-#-----------------------------------------------------------------------------------------------
-# model_top - not set by default
-my $model_top = 'none';
-$cfg_ref->set('model_top', $model_top);
-
-# user override
-if (defined $opts{'model_top'}) {
- $cfg_ref->set('model_top', $opts{'model_top'});
-}
-if ($print>=2) { print "model_top: $model_top$eol"; }
-
#-----------------------------------------------------------------------------------------------
# waccm physics
my $waccm_phys = 0;
@@ -826,7 +817,7 @@ elsif ($phys_pkg eq 'cam5') {
elsif ($phys_pkg eq 'cam6') {
$microphys_pkg = 'mg2';
}
-elsif ($phys_pkg eq 'cam_dev') {
+elsif ($phys_pkg eq 'cam7') {
$microphys_pkg = 'mg3';
}
elsif ($phys_pkg eq 'spcam_sam1mom') {
@@ -875,7 +866,7 @@ if ($print>=2) { print "CARMA microphysical model: $carma_pkg$eol"; }
#-----------------------------------------------------------------------------------------------
# CLUBB
my $clubb_sgs = 0;
-if ($phys_pkg eq 'cam6' or $phys_pkg eq 'cam_dev') {
+if ($phys_pkg eq 'cam6' or $phys_pkg eq 'cam7') {
$clubb_sgs = 1;
}
@@ -886,6 +877,13 @@ if (defined $opts{'clubb_sgs'}) {
# consistency checks...
+# cam7 only works with CLUBB_SGS
+if (($phys_pkg eq 'cam7') and not ($clubb_sgs )) {
+ die <<"EOF";
+** ERROR: CLUBB_SGS must be enabled for cam7 physics.
+EOF
+}
+
# CLUBB_SGS only works with mg microphysics
if ($clubb_sgs and not ($microphys_pkg =~ m/^mg/ )) {
die <<"EOF";
@@ -958,13 +956,15 @@ if ($phys_pkg =~ /cam[34]/) {
elsif ($phys_pkg =~ /cam5/) {
$macrophys_pkg = 'park';
}
-elsif ($phys_pkg =~ /cam6/ and $clubb_sgs) {
- $macrophys_pkg = 'clubb_sgs';
-}
-elsif ($phys_pkg =~ /cam6/ and !$clubb_sgs) {
- $macrophys_pkg = 'park';
+elsif ($phys_pkg =~ /cam6/) {
+ if ($clubb_sgs) {
+ $macrophys_pkg = 'clubb_sgs';
+ }
+ else {
+ $macrophys_pkg = 'park';
+ }
}
-elsif ($phys_pkg =~ /cam_dev/ and $clubb_sgs) {
+elsif ($phys_pkg =~ /cam7/ and $clubb_sgs) {
$macrophys_pkg = 'clubb_sgs';
}
elsif ($phys_pkg eq 'spcam_sam1mom') {
@@ -999,13 +999,15 @@ if ($phys_pkg =~ m/^cam[34]$/) {
elsif ($phys_pkg =~ /cam5/) {
$pbl_pkg = 'uw';
}
-elsif ($phys_pkg =~ /cam6/ and $clubb_sgs) {
- $pbl_pkg = 'clubb_sgs';
-}
-elsif ($phys_pkg =~ /cam6/ and !$clubb_sgs) {
- $pbl_pkg = 'uw';
+elsif ($phys_pkg =~ /cam6/) {
+ if ($clubb_sgs) {
+ $pbl_pkg = 'clubb_sgs';
+ }
+ else {
+ $pbl_pkg = 'uw';
+ }
}
-elsif ($phys_pkg =~ /cam_dev/ and $clubb_sgs) {
+elsif ($phys_pkg =~ /cam7/ and $clubb_sgs) {
$pbl_pkg = 'clubb_sgs';
}
elsif ($phys_pkg eq 'spcam_sam1mom') {
@@ -1065,10 +1067,10 @@ if ($unicon and $print>=2) { print "Using UNICON scheme.$eol"; }
# Set default
my $rad_pkg = 'none';
-if ($phys_pkg =~ m/^cam[34]$|^spcam_sam1mom$/) {
+if ($phys_pkg =~ m/cam3|cam4|spcam_sam1mom/) {
$rad_pkg = 'camrt';
}
-elsif ($phys_pkg =~ m/^cam[56]$|^cam_dev$|^spcam_m2005$/) {
+elsif ($phys_pkg =~ m/cam5|cam6|cam7|spcam_m2005/) {
$rad_pkg = 'rrtmg';
}
# Allow the user to override the default via the commandline.
@@ -1119,8 +1121,8 @@ if (defined $opts{'cosp'}) {
}
my $cosp = $cfg_ref->get('cosp');
-# cosp is only implemented with the cam5 and cam6 physics packages
-if ($cosp and ($phys_pkg ne 'cam5' and $phys_pkg ne 'cam6' and $phys_pkg ne 'cam_dev')) {
+# cosp is only implemented with the cam5, cam6, and cam7 physics packages
+if ($cosp and ($phys_pkg ne 'cam5' and $phys_pkg ne 'cam6' and $phys_pkg ne 'cam7')) {
die "configure ERROR: cosp not implemented for the $phys_pkg physics package \n";
}
@@ -1313,6 +1315,24 @@ EOF
if ($print>=2) { print "Maximum number of sub-columns per column: $psubcols$eol"; }
+#-----------------------------------------------------------------------------------------------
+# model_top -- Introduced in cam7 to provide a way to specify the model top
+# independently of the number of model layers.
+
+# Set default
+my $model_top = 'none';
+$cfg_ref->set('model_top', $model_top);
+
+# user override
+if (defined $opts{'model_top'} and $opts{'model_top'} ne 'none') {
+ if ($phys_pkg eq 'cam7') {
+ $cfg_ref->set('model_top', $opts{'model_top'});
+ } else {
+ die "configure ERROR: model_top=$opts{'model_top'} is only implemented for cam7 physics";
+ }
+}
+if ($print>=2) { print "model_top: $model_top$eol"; }
+
#-----------------------------------------------------------------------------------------------
# Number of vertical levels
my $nlev = 0;
@@ -1321,7 +1341,7 @@ my $nlev = 0;
if ($waccmx) {
if ($phys_pkg eq 'cam6') {
$nlev = 130;
- } elsif ($phys_pkg eq 'cam_dev') {
+ } elsif ($phys_pkg eq 'cam7') {
$nlev = 130;
} else {
$nlev = 126;
@@ -1335,7 +1355,7 @@ elsif ($chem_pkg =~ /waccm_/) {
$nlev = 70;
}
}
-elsif ($phys_pkg eq 'cam_dev') {
+elsif ($phys_pkg eq 'cam7') {
$nlev = 32;
}
elsif ($phys_pkg eq 'cam6') {
@@ -2170,8 +2190,8 @@ sub write_filepath
print $fh "$camsrcdir/src/unit_drivers\n";
print $fh "$camsrcdir/src/unit_drivers/${offline_drv}\n";
- if ($phys_pkg eq 'cam_dev') {
- print $fh "$camsrcdir/src/physics/cam_dev\n";
+ if ($phys_pkg eq 'cam7') {
+ print $fh "$camsrcdir/src/physics/cam7\n";
}
if ($simple_phys) {
@@ -2280,7 +2300,7 @@ sub write_filepath
print $fh "$camsrcdir/src/physics/clubb/src/SILHS\n";
}
- if ($phys_pkg eq 'cam_dev') {
+ if ($phys_pkg eq 'cam7') {
print $fh "$camsrcdir/src/physics/pumas\n";
} else {
print $fh "$camsrcdir/src/physics/pumas-frozen\n";
diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml
index 305701c98b..d843866b3a 100644
--- a/bld/namelist_files/namelist_defaults_cam.xml
+++ b/bld/namelist_files/namelist_defaults_cam.xml
@@ -47,7 +47,7 @@
atm/cam/inic/mpas/mpasa480_L32_notopo_coords_c201125.nc
atm/cam/inic/mpas/mpasa120_L32_notopo_coords_c201216.nc
atm/cam/inic/mpas/mpasa120_L32_topo_coords_c201022.nc
-atm/cam/inic/mpas/mpasa120_L32_topo_coords_c201022.nc
+atm/cam/inic/mpas/mpasa120_L32_topo_coords_c201022.nc
atm/cam/inic/mpas/mpasa60_L32_notopo_coords_c230707.nc
atm/cam/inic/mpas/mpasa30_L32_notopo_coords_c230707.nc
@@ -125,10 +125,10 @@
atm/cam/inic/se/f.e22.FCnudged.ne0CONUSne30x8_ne0CONUSne30x8_mt12.cam6_2_032.002.cam.i.2013-01-01-00000_c200623.nc
atm/cam/inic/se/f.e22.FCnudged.ne0CONUSne30x8_ne0CONUSne30x8_mt12.cam6_2_032.002.cam.i.2013-01-01-00000_c200623.nc
atm/cam/inic/se/f.e22.FCnudged.ne30_ne30_mg17.release-cesm2.2.0_spinup.2010_2020.001.cam.i.2011-01-01-00000_L58_c220310.nc
-atm/cam/inic/se/f.cam6_3_112.FCMTHIST_v0c.ne30.non-ogw-ubcT-effgw0.7.001.cam.i.1998-01-01-00000_c230810.nc
+atm/cam/inic/se/f.cam6_3_160.FCMT_ne30.moving_mtn.001.cam.i.1996-01-01-00000_c240618.nc
atm/cam/inic/se/FLT_L58_ne30pg3_IC_c220623.nc
-atm/cam/inic/se/cam7_FMT_ne30pg3_mg17_L93_c221118.nc
+atm/cam/inic/se/c153_ne30pg3_FMTHIST_x02.cam.i.1990-01-01-00000_c240618.nc
atm/cam/chem/trop_mozart/ic/cami_0000-09-01_4x5_L26_c060217.nc
atm/cam/chem/trop_mozart/ic/cami_0000-09-01_10x15_L26_c060216.nc
@@ -225,7 +225,7 @@
atm/cam/inic/se/cami_0000-01-01_ne3np4_L26_c120525.nc
atm/cam/inic/se/cami_0000-01-01_ne3np4_L26_c120525.nc
atm/cam/inic/se/cam6_QPC6_topo_ne3pg3_mg37_L58_01-01-31_c221214.nc
-atm/cam/inic/se/cam6_QPC6_topo_ne3pg3_mg37_L93_01-01-31_c221214.nc
+atm/cam/inic/se/cam6_FMTHIST_ne3pg3_mg37_L93_79-02-01_c240517.nc
atm/cam/inic/homme/cami-mam3_0000-01_ne5np4_L30.140707.nc
atm/cam/inic/se/F2000climo_ne5pg3_mg37_L32_01-01-31_c230520.nc
atm/cam/inic/se/F2000climo_ne5pg3_mg37_L58_01-01-31_c230520.nc
@@ -260,7 +260,7 @@
atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L32_01-01-31_c221214.nc
atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L58_01-01-31_c221214.nc
-atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L93_01-01-31_c221214.nc
+atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L93_01_02_01_c240518.nc
atm/cam/inic/se/ape_cam6_ne5np4_L32_c170517.nc
atm/cam/inic/se/ape_cam6_ne16np4_L32_c170509.nc
atm/cam/inic/se/ape_cam6_ne30np4_L32_c170509.nc
@@ -295,7 +295,7 @@
atm/cam/topo/USGS_gtopo30_0.23x0.31_remap_c061107.nc
atm/cam/topo/USGS_gtopo30_0.47x0.63_remap_c061106.nc
atm/cam/topo/fv_0.47x0.63_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171023.nc
-atm/cam/topo/fv_0.47x0.63_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171023.nc
+atm/cam/topo/fv_0.47x0.63_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171023.nc
atm/cam/topo/topo-from-cami_0000-10-01_0.5x0.625_L26_c031204.nc
atm/cam/topo/fv_0.9x1.25_nc3000_Nsw042_Nrs008_Co060_Fi001_ZR_sgh30_24km_GRNL_c170103.nc
atm/cam/topo/fv_1.9x2.5_nc3000_Nsw084_Nrs016_Co120_Fi001_ZR_GRNL_c190405.nc
@@ -344,7 +344,7 @@
98288.0D0
98288.0D0
98288.0D0
- 98288.0D0
+ 98288.0D0
98288.0D0
98288.0D0
@@ -589,7 +589,7 @@
.false.
.true.
-.true.
+.true.
slingo
@@ -635,9 +635,9 @@
ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
-ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
+ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
-ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
+ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc
waccm_ozone_c121126.nc
0
@@ -876,8 +876,8 @@
.true.
.true.
.true.
-.false.
-.false.
+.false.
+.false.
.false.
.false.
.false.
@@ -934,6 +934,7 @@
atm/cam/coords/ne5np4_esmf_20191204.nc
atm/cam/coords/ne5np4.pg3_esmf_mesh_c210121.nc
atm/cam/coords/ne16np4_esmf_c210305.nc
+share/meshes/ne16pg3_ESMFmesh_cdf5_c20211018.nc
atm/cam/coords/ne30np4_esmf_c210305.nc
atm/cam/coords/ne30pg3_esmf_20200428.nc
@@ -945,10 +946,10 @@
1.30D0
1.60D0
0.32D0
-1.50D0
-1.30D0
-1.60D0
-0.32D0
+1.50D0
+1.30D0
+1.60D0
+0.32D0
atm/cam/chem/trop_mozart/emis/megan21_emis_factors_78pft_c20161108.nc
@@ -1932,10 +1933,10 @@
1850
oxid_1.9x2.5_L26_1850clim_c091123.nc
1850
-oxid_1.9x2.5_L26_1850clim_c091123.nc
-1850
-oxid_1.9x2.5_L26_1850clim_c091123.nc
-1850
+oxid_1.9x2.5_L26_1850clim_c091123.nc
+1850
+oxid_1.9x2.5_L26_1850clim_c091123.nc
+1850
atm/cam/chem/trop_mozart_aero/oxid
CYCLICAL
@@ -1977,12 +1978,12 @@
atm/cam/ozone
ozone_strataero_WACCM6_L70_zm5day_19750101-20141229_c180216.nc
atm/cam/ozone_strataero
-CESM_1849_2100_sad_V3_c160211.nc
-atm/cam/volc
-ozone_strataero_CAM6chem_1849-2014_zm_5day_c170924.nc
-atm/cam/ozone
-ozone_strataero_WACCM6_L70_zm5day_19750101-20141229_c180216.nc
-atm/cam/ozone_strataero
+CESM_1849_2100_sad_V3_c160211.nc
+atm/cam/volc
+ozone_strataero_CAM6chem_1849-2014_zm_5day_c170924.nc
+atm/cam/ozone
+ozone_strataero_WACCM6_L70_zm5day_19750101-20141229_c180216.nc
+atm/cam/ozone_strataero
atm/waccm/sulf/sulfate.ar5_camchem_c130304.nc
@@ -2066,7 +2067,7 @@
.true.
.true.
.false.
- .false.
+ .false.
.true.
0.075D0
@@ -2078,20 +2079,20 @@
.false.
.true.
- .true.
+ .true.
.false.
.true.
.true.
- .true.
+ .true.
.true.
0
1
1
- 1
+ 1
1
0.01d0
@@ -2138,10 +2139,10 @@
6.0
1.0
0.5
- 0.1
+ 0.1
0.5
4.2
- 4.25
+ 4.25
0.0
1.0
0.1
@@ -2158,21 +2159,21 @@
1.25
0.25
0.3
- 0.1
+ 0.1
0.3
0.0
0.4
25.0D-6
- 61.0D-6
+ 61.0D-6
8.0D-6
238.15D0
.true.
.false.
0.308
- 0.3
+ 0.3
0.280
0.32
- 0.3
+ 0.3
2
0.04
0.1
@@ -2186,15 +2187,16 @@
.false.
.false.
.false.
- .false.
- .true.
+ .false.
+ .true.
+ .false.
.false.
.false.
.true.
.false.
.false.
.false.
- .true.
+ .true.
.false.
.false.
.true.
@@ -2206,7 +2208,7 @@
.true.
.false.
.false.
- .true.
+ .true.
.false.
.false.
.false.
@@ -2241,8 +2243,8 @@
0.5
25.0
.false.
-.true.
.true.
+.true.
.true.
0.2
@@ -2353,10 +2355,10 @@
1.D0
0.2D0
- 0.1D0
+ 0.1D0
0.1D0
- 0.0D0
+ 0.0D0
0.001D0
@@ -2375,10 +2377,10 @@
1.D8
1.D8
- .true.
- .true.
- kk2000
- .true.
+ .true.
+ .true.
+ kk2000
+ .true.
1
3
@@ -2411,17 +2413,17 @@
.false.
.true.
-.true.
+.true.
0.01D0
0.05D0
.false.
.true.
-.true.
+.true.
.true.
.false.
-.false.
+.false.
1.0D0
.true.
@@ -2453,7 +2455,7 @@
1.D0
0.D0
0.D0
-0.D0
+0.D0
1.D0
@@ -2463,12 +2465,12 @@
30.D0
100.D0
100.D0
-100.D0
+100.D0
100.D3
100.D0
100.D0
-100.D0
+100.D0
30.D0
40.D0
@@ -2488,51 +2490,51 @@
0.45D0
0.45D0
0.35D0
-1.30D0
+1.30D0
0.30D0
-0.30D0
+0.30D0
0.45D0
-0.45D0
+0.45D0
0.45D0
-0.45D0
+0.45D0
0.45D0
0.55D0
0.22D0
0.70D0
-1.30D0
+1.30D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.8D0
-0.8D0
+0.8D0
0.70D0
-0.70D0
+0.70D0
0.13D0
0.26D0
-0.26D0
+0.26D0
0.7D0
-0.7D0
+0.7D0
0.24D0
-0.24D0
+0.24D0
0.9D0
-0.9D0
+0.9D0
@@ -2540,7 +2542,7 @@
1.62D0
0.90D0
1.00D0
-1.5D0
+1.5D0
1.10D0
1.2D0
0.60D0
@@ -2648,7 +2650,7 @@
.false.
.true.
.true.
-.true.
+.true.
0.900D0
0.910D0
@@ -2668,12 +2670,12 @@
0.8875D0
0.9125D0
- 0.910D0
- 0.950D0
- 0.950D0
- 0.8975D0
- 0.8875D0
- 0.9125D0
+ 0.910D0
+ 0.950D0
+ 0.950D0
+ 0.8975D0
+ 0.8875D0
+ 0.9125D0
0.910D0
0.920D0
@@ -2687,7 +2689,7 @@
0.100D0
0.000D0
- 0.000D0
+ 0.000D0
0.000D0
0.800D0
@@ -2711,7 +2713,7 @@
0.14D0
0.10D0
0.10D0
- 0.10D0
+ 0.10D0
0.10D0
0.10D0
@@ -2736,25 +2738,25 @@
750.0D2
700.0D2
700.0D2
- 700.0D2
+ 700.0D2
1
5
5
- 5
+ 5
4
4
4
- 4
+ 4
0.95D0
0.93D0
0.93D0
- 0.93D0
+ 0.93D0
0.70D0
0.70D0
0.70D0
- 0.70D0
+ 0.70D0
0.80D0
0.85D0
@@ -2778,7 +2780,7 @@
.false.
.true.
-.true.
+.true.
.false.
@@ -2858,11 +2860,11 @@
0.0035D0
0.0075D0
0.0075D0
- 0.0059D0
- 0.0035D0
- 0.0035D0
- 0.0075D0
- 0.0075D0
+ 0.0059D0
+ 0.0035D0
+ 0.0035D0
+ 0.0075D0
+ 0.0075D0
0.0035D0
0.0035D0
0.0020D0
@@ -2879,11 +2881,11 @@
0.0035D0
0.0300D0
0.0300D0
- 0.0450D0
- 0.0035D0
- 0.0035D0
- 0.0300D0
- 0.0300D0
+ 0.0450D0
+ 0.0035D0
+ 0.0035D0
+ 0.0300D0
+ 0.0300D0
0.0035D0
0.0035D0
0.0020D0
@@ -2907,7 +2909,7 @@
5
1
- 1
+ 1
-1.0E-3
0.5
@@ -2929,7 +2931,7 @@
2
4
4
- 4
+ 4
4
42
42
@@ -2939,9 +2941,9 @@
42
42
42
-42
+42
42
-42
+42
42
1
@@ -3218,9 +3220,9 @@
3
3
5
- 5
+ 5
6
- 6
+ 6
1
1
3
diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml
index 8dbf29dce8..cc9db62ab4 100644
--- a/bld/namelist_files/namelist_definition.xml
+++ b/bld/namelist_files/namelist_definition.xml
@@ -3605,7 +3605,9 @@ Default: set by build-namelist
-Switch for CLUBB_SGS
+Flag for CLUBB_SGS. N.B. this variable may not be set by the user. It is
+set by build-namelist via information in the configure cache file to be
+consistent with how CAM was built.
Default: set by build-namelist
diff --git a/cime_config/SystemTests/mgp.py b/cime_config/SystemTests/mgp.py
index 14f691dfcf..ab2232eda0 100644
--- a/cime_config/SystemTests/mgp.py
+++ b/cime_config/SystemTests/mgp.py
@@ -2,7 +2,7 @@
CIME MGP test. This class inherits from SystemTestsCompareTwo
This is a changing config options test to compare between MG3 and
-PUMAS in camdev. The use of MG3 or PUMAS should be bfb.
+PUMAS in cam7. The use of MG3 or PUMAS should be bfb.
This is just like an ERC test and it's meant for CAM only
as it only does a single build.
@@ -39,9 +39,9 @@ def __init__(self, case,
def _case_one_setup(self):
stop_n = self._case1.get_value("STOP_N")
expect(stop_n >= 3, "STOP_N must be at least 3, STOP_N = {}".format(stop_n))
- self._case.set_value("CAM_CONFIG_OPTS","-phys cam_dev -microphys mg3")
+ self._case.set_value("CAM_CONFIG_OPTS","-phys cam7 -microphys mg3")
def _case_two_setup(self):
- self._case.set_value("CAM_CONFIG_OPTS","-phys cam_dev -microphys pumas")
+ self._case.set_value("CAM_CONFIG_OPTS","-phys cam7 -microphys pumas")
diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml
index 3468822b29..fff083f4c2 100644
--- a/cime_config/config_component.xml
+++ b/cime_config/config_component.xml
@@ -8,13 +8,12 @@
CAM
===============
-->
+ CAM cam7 physics:
CAM cam6 physics:
CAM cam5 physics:
CAM cam4 physics:
CAM cam3 physics:
CAM simplified and non-versioned physics :
- CAM7 development physics:
-
- -phys cam_dev
- -chem ghg_mam4
-chem trop_strat_mam5_vbs
-chem geoschem_mam4
@@ -174,8 +171,8 @@
-nlev 56
-nlev 88
-nlev 145
- -nlev 58 -model_top lt
- -nlev 93 -model_top mt
+ -nlev 58 -model_top lt
+ -nlev 93 -model_top mt
-scam arm95
@@ -234,14 +231,14 @@
waccm_tsmlt_1850_cam6
waccm_ma_1850_cam6
waccm_sc_1850_cam6
- 1850_cam_lt
- 1850_cam_mt
+ 1850_cam_lt
+ 1850_cam_mt
2000_cam4_trop_chem
waccmxie_ma_2000_cam4
waccmx_ma_2000_cam4
- 2000_cam6
+ 2000_cam6
2000_cam6
waccm_tsmlt_2000_cam6
waccm_ma_2000_cam6
@@ -274,8 +271,8 @@
1950-2010_ccmi_refc1_waccmx_ma
1850-2005_cam5
hist_cam6
- hist_cam_lt
- hist_cam_mt
+ hist_cam_lt
+ hist_cam_mt
waccm_tsmlt_hist_cam6
waccm_sc_hist_cam6
waccm_ma_hist_cam6
diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml
index b0c0eba678..51fcff7c0a 100644
--- a/cime_config/config_compsets.xml
+++ b/cime_config/config_compsets.xml
@@ -63,22 +63,22 @@
FLTHIST
- HIST_CAM%DEV%LT%GHGMAM4_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ HIST_CAM70%LT_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
FMTHIST
- HIST_CAM%DEV%MT%GHGMAM4_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ HIST_CAM70%MT_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
FLT1850_TESTINGONLY_v0c
- 1850_CAM%DEV%LT%GHGMAM4_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ 1850_CAM70%LT_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
FMT1850_TESTINGONLY_v0c
- 1850_CAM%DEV%MT%GHGMAM4_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ 1850_CAM70%MT_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
@@ -372,7 +372,7 @@
F2000dev
- 2000_CAM%DEV_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ 2000_CAM70_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
@@ -434,11 +434,11 @@
FCLTHIST
- HIST_CAM%DEV%LT%CCTS1_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ HIST_CAM70%LT%CCTS1_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
FCMTHIST
- HIST_CAM%DEV%MT%CCTS1_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
+ HIST_CAM70%MT%CCTS1_CLM51%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV
FCvbsxHIST
diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml
index cd2fe41b90..5c8df356e4 100644
--- a/cime_config/config_pes.xml
+++ b/cime_config/config_pes.xml
@@ -398,7 +398,7 @@
1
-
+
none
-8
@@ -421,7 +421,7 @@
-
+
none
-8
@@ -448,7 +448,7 @@
0
-
+
none
-12
@@ -506,7 +506,7 @@
-
+
none
1800
diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml
index cee9387763..4bf6e5e221 100644
--- a/cime_config/testdefs/testlist_cam.xml
+++ b/cime_config/testdefs/testlist_cam.xml
@@ -93,7 +93,7 @@
-
+
@@ -1462,13 +1462,8 @@
-
-
-
-
-
-
+
@@ -1507,9 +1502,7 @@
-
-
@@ -1553,32 +1546,12 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -1699,16 +1672,16 @@
-
+
-
+
-
+
@@ -1729,7 +1702,7 @@
-
+
@@ -1823,7 +1796,7 @@
-
+
@@ -1832,7 +1805,7 @@
-
+
@@ -1840,8 +1813,8 @@
-
-
+
+
@@ -1850,7 +1823,7 @@
-
+
@@ -1859,7 +1832,7 @@
-
+
@@ -1868,7 +1841,7 @@
-
+
@@ -2300,7 +2273,7 @@
-
+
@@ -2309,7 +2282,7 @@
-
+
@@ -2435,7 +2408,7 @@
-
+
@@ -2455,7 +2428,7 @@
-
+
@@ -2470,7 +2443,7 @@
-
+
@@ -2479,7 +2452,7 @@
-
+
@@ -2762,7 +2735,7 @@
-
+
@@ -2820,7 +2793,7 @@
-
+
diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/shell_commands
new file mode 100644
index 0000000000..d3fa399380
--- /dev/null
+++ b/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/shell_commands
@@ -0,0 +1,3 @@
+./xmlchange ROF_NCPL=\$ATM_NCPL
+./xmlchange RUN_STARTDATE=0001-12-14
+./xmlchange CAM_CONFIG_OPTS="-phys cam7 -microphys mg2 -chem ghg_mam4 -nlev 32"
diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_cam
similarity index 100%
rename from cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_cam
rename to cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_cam
diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_clm
similarity index 100%
rename from cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_clm
rename to cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_clm
diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/shell_commands
deleted file mode 100644
index 513b5dbe41..0000000000
--- a/cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/shell_commands
+++ /dev/null
@@ -1,3 +0,0 @@
-./xmlchange ROF_NCPL=\$ATM_NCPL
-./xmlchange RUN_STARTDATE=0001-12-14
-./xmlchange CAM_CONFIG_OPTS="-phys cam_dev -microphys mg2 -chem ghg_mam4 -nlev 32"
diff --git a/doc/ChangeLog b/doc/ChangeLog
index 9e627f133c..da9cb012c1 100644
--- a/doc/ChangeLog
+++ b/doc/ChangeLog
@@ -1,4 +1,726 @@
+===============================================================
+
+Tag name: cam6_4_006
+Originator(s): pel, eaton
+Date: 3 July 2024
+One-line Summary: fix clubb interface bug (dry/moist mixing ratio conversion)
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1054
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+ - fix issue described in https://github.com/ESCOMP/CAM/issues/1053
+ . refactor set_wet_to_dry and set_dry_to_wet to require specifying which
+ constituent type the mixing ratio conversion is applied to
+
+Describe any changes made to build system: N/A
+
+Describe any changes made to the namelist: N/A
+
+List any changes to the defaults for the boundary datasets: N/A
+
+Describe any substantial timing or memory changes: N/A
+
+Code reviewed by: nusbaume
+
+List all files eliminated: N/A
+
+List all files added and what they do: N/A
+
+List all existing files that have been modified, and describe the changes:
+
+.gitmodules
+- update fv3 from fv3int_053124 to fv3int_061924
+
+src/physics/cam/clubb_intr.F90
+- add convert_cnst_type='wet' to arg list for set_wet_to_dry
+
+src/physics/cam/physics_types.F90
+- refactor set_wet_to_dry and set_dry_to_wet to require specifying which
+ constituent mixing ratios are being converted.
+
+src/dynamics/fv3/dp_coupling.F90
+src/dynamics/fv/dp_coupling.F90
+- add convert_cnst_type='dry' to arg list for set_wet_to_dry
+
+src/physics/cam/gw_drag.F90
+src/physics/cam/physpkg.F90
+src/physics/carma/cam/carma_intr.F90
+src/physics/simple/physpkg.F90
+- add convert_cnst_type='dry' to arg list for set_dry_to_wet
+
+src/physics/cam/vertical_diffusion.F90
+- add convert_cnst_type='dry' to arg list for set_dry_to_wet
+ and set_wet_to_dry
+
+src/physics/carma/models/cirrus/carma_cloudfraction.F90
+src/physics/carma/models/cirrus_dust/carma_cloudfraction.F90
+- remove unused association of set_dry_to_wet and set_wet_to_dry
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam:
+
+ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL)
+SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND)
+SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND)
+SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL)
+- pre-existing failures
+
+ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF)
+ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF)
+ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF)
+ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF)
+ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF)
+ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF)
+ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 (Overall: DIFF)
+ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF)
+ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF)
+ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF)
+SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF)
+SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF)
+SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF)
+SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF)
+SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF)
+SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF)
+SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF)
+SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF)
+SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF)
+SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF)
+SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF)
+SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF)
+SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF)
+SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF)
+SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF)
+- expected baseline differences for cam6/cam7 physics
+
+izumi/nag/aux_cam:
+
+DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL)
+- pre-existing failure
+
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF)
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF)
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF)
+ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF)
+ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF)
+ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF)
+SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF)
+SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF)
+- expected baseline differences for cam6 physics
+
+izumi/gnu/aux_cam:
+
+ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF)
+ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF)
+- expected baseline differences for cam6 physics
+
+CAM tag used for the baseline comparison tests if different than previous
+tag:
+
+Summarize any changes to answers: BFB except all tests using CLUBB (i.e.,
+ cam6 and cam7 physics) will have baseline comparison failures.
+
+===============================================================
+===============================================================
+
+Tag name: cam6_4_005
+Originator(s): eaton
+Date: 1 July 2024
+One-line Summary: Limit vertical domain used by COSP.
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1010
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+The COSP simulator was not working with "FMT" compsets. This compset has a
+model top of about 1 Pa which is above where the cloud parameterizations
+operate. The COSP interface routine was modified so that COSP operates on
+the same vertical domain as the cloud parameterizations which is set by
+the namelist variable trop_cloud_top_press (1 mb by default). Changing to
+a dynamically determined top required moving the call to COSP's
+initialization. In addition a lot of code cleanup was done, and a bug fix
+was made for the layer interface values of height and pressure passed from
+CAM to COSP.
+
+. resolves #967- COSP prevents running "FMT" compsets.
+
+Removed old tools for topo file generation.
+
+. resolves #1005 - Remove old topo generation software from CAM
+
+Describe any changes made to build system: none
+
+Describe any changes made to the namelist: none
+
+List any changes to the defaults for the boundary datasets: none
+
+Describe any substantial timing or memory changes: not measured, but COSP
+should be less expensive in models with tops above 1 mb.
+
+Code reviewed by: cacraig, nusbaume
+
+List all files eliminated:
+tools/definehires/*
+tools/definesurf/*
+tools/topo_tool/*
+. these tools for topo file generation have been replaced by
+ https://github.com/NCAR/Topo
+
+List all files added and what they do: none
+
+List all existing files that have been modified, and describe the changes:
+
+src/control/cam_history_support.F90
+. fix log output format
+
+src/physics/cam/cospsimulator_intr.F90
+. set top of data operated on by COSP using trop_cloud_top_lev
+. cospsimulator_intr_register
+ - move the setcosp2values call here. That routine contains the call to
+ COSP's initialization.
+. cospsimulator_intr_readnl
+ - move the call to setcosp2values to cospsimulator_intr_register.
+. remove outdated and/or unhelpful comments
+. remove unused variables
+. remove added history fields that had no corresponding outfld calls
+. remove array section notation from places where the whole array is used
+
+src/physics/cam/ref_pres.F90
+. add calls to create vertical coordinate variables for the domain bounded
+ by trop_cloud_lev_top. Some COSP history fields need this coordinate.
+
+src/utils/hycoef.F90
+. add comment and fix a comment
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam: All PASS except:
+ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL)
+SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND)
+SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND)
+SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL)
+SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF)
+- pre-existing failures
+
+izumi/nag/aux_cam: All PASS except:
+DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: PEND)
+- pre-existing failure
+
+izumi/gnu/aux_cam: All PASS.
+
+CAM tag used for the baseline comparison tests if different than previous
+tag:
+
+Summarize any changes to answers: BFB. Note that although the regression
+ tests with COSP diagnostics passed, there are some COSP diagnostic fields that
+ have answer changes due to a bug fix in the data sent to COSP.
+
+===============================================================
+===============================================================
+
+Tag name: cam6_4_004
+Originator(s): fvitt
+Date: 29 Jun 2024
+One-line Summary: Misc corrections for WACCM-X
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1023
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+ Implement corrections to:
+ - geometric height calculations (issue #987)
+ - thermosphere heating diagnostics (issue #1013)
+ - DTVKE vertical diffustion diagnostic
+
+Describe any changes made to build system: N/A
+
+Describe any changes made to the namelist: N/A
+
+List any changes to the defaults for the boundary datasets: N/A
+
+Describe any substantial timing or memory changes: N/A
+
+Code reviewed by: cacraigucar, nusbaume
+
+List all files eliminated: N/A
+
+List all files added and what they do: N/A
+
+List all existing files that have been modified, and describe the changes:
+M src/ionosphere/waccmx/ionosphere_interface.F90
+ - Hanli's formulation for geometric height
+
+M src/physics/cam/vertical_diffusion.F90
+ - correction to DTVKE diagnostic
+
+M src/physics/waccmx/ion_electron_temp.F90
+ - corrections to thermosphere heating diagnostics (issue #1013)
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam:
+ FAIL ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s
+ DIFF SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h
+ FAIL SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s
+ PEND SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s
+ PEND SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s
+ - pre-existing failures
+
+ DIFF ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s
+ DIFF ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s
+ DIFF ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s
+ DIFF SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie
+ DIFF SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s
+ DIFF SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s
+ - expected baseline failures in waccmx due to corrections in diagnostices
+
+izumi/nag/aux_cam:
+ FAIL DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae
+ - pre-existing failure
+
+ DIFF SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s
+ - expected baseline failure in waccmx due to corrections in diagnostices
+
+izumi/gnu/aux_cam: All PASS
+
+Summarize any changes to answers: bit-for-bit unchanged
+
+===============================================================
+===============================================================
+
+Tag name: cam6_4_003
+Originator(s): adamrher, jet
+Date: Thu Jun 28, 2024
+One-line Summary: Corrected L93 default IC files
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1040
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+ The L93 hybrid coefficients had a discontinuous kink, or offset, creating an anomalously thin layer
+ in the 300 hPa - 100 hPa altitude range. This region overlaps with the L58 grid, but for some reason
+ the L58 grid didn't get contaminated like it was in L93. We aren't sure how this happened.
+ More here: https://github.com/ESCOMP/CAM/issues/1034
+
+ fixes #1034 - Problematic hybrid coefficients in L99
+
+Describe any changes made to build system: none
+
+Describe any changes made to the namelist: none
+
+List any changes to the defaults for the boundary datasets: Files with problematic hybrid coeff were
+ regenerated.
+
+Describe any substantial timing or memory changes: none
+
+Code reviewed by: cacraigucar, jet
+
+List all files eliminated:
+ Boundary data defaults eliminated from namelist_defaults_cam.xml (files still exist but will no longer be used)
+ atm/cam/inic/se/f.cam6_3_112.FCMTHIST_v0c.ne30.non-ogw-ubcT-effgw0.7.001.cam.i.1998-01-01-00000_c230810.nc
+ atm/cam/inic/se/cam7_FMT_ne30pg3_mg17_L93_c221118.nc
+ atm/cam/inic/se/cam6_QPC6_topo_ne3pg3_mg37_L93_01-01-31_c221214.nc
+ atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L93_01-01-31_c221214.nc
+
+List all files added and what they do:
+ New files added to data repo and namelist_defaults-cam.xml:
+ atm/cam/inic/se/f.cam6_3_160.FCMT_ne30.moving_mtn.001.cam.i.1996-01-01-00000_c240618.nc
+ atm/cam/inic/se/c153_ne30pg3_FMTHIST_x02.cam.i.1990-01-01-00000_c240618.nc
+ atm/cam/inic/se/cam6_FMTHIST_ne3pg3_mg37_L93_79-02-01_c240517.nc
+ atm/cam/inic/se/cam6_QPC6_aqua_ne3pg3_mg37_L93_01_02_01_c240518.nc
+List all existing files that have been modified, and describe the changes:
+
+bld/namelist_files/namelist_defaults_cam.xml
+. Replaced problematic 93 level IC defaults with new files.
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam: BFB except:
+
+ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+- pre-existing failures
+
+SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+- expected change due to new IC default
+
+izumi/nag/aux_cam: BFB except:
+
+DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details:
+- pre-existing failure
+
+izumi/gnu/aux_cam: BFB
+
+CAM tag used for the baseline comparison tests if different than previous
+tag: NA
+
+Summarize any changes to answers: This changes answers for
+ configurations using new default 93L IC files.
+
+
+===============================================================
+===============================================================
+
+Tag name: cam6_4_002
+Originator(s): adamrher, eaton
+Date: Wed Jun 26, 2024
+One-line Summary: activate additional clubb diffusion in cam6
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1056
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+Resolves #1041 - cam6 should have additional clubb diffusion activated but it doesn't
+
+. The fix is to set the namelist defaults for clubb_l_do_expldiff_rtm_thlm
+ the same way that defaults were set for clubb_expldiff before tag cam6_3_059.
+
+Describe any changes made to build system: none
+
+Describe any changes made to the namelist:
+. defaults changed for clubb_l_do_expldiff_rtm_thlm
+
+List any changes to the defaults for the boundary datasets: none
+
+Describe any substantial timing or memory changes: none
+
+Code reviewed by: cacraigucar, nusbaume
+
+List all files eliminated: none
+
+List all files added and what they do: none
+
+List all existing files that have been modified, and describe the changes:
+
+bld/namelist_files/namelist_defaults_cam.xml
+. change defaults for clubb_l_do_expldiff_rtm_thlm to be true when clubb is
+ used, except when clubb is used with silhs. False otherwise.
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam: BFB except:
+
+ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+- pre-existing failures
+
+SMS_Ld5.f09_f09_mg17.PC6.derecho_intel.cam-cam6_port_f09 (Overall: NLFAIL) details:
+- namelist change for cam6 physics. No answer change for PORT test.
+
+ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details:
+ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details:
+ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details:
+ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details:
+ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details:
+ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details:
+ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details:
+SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details:
+SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details:
+SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details:
+SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details:
+SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details:
+SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details:
+SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details:
+SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details:
+SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details:
+SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details:
+SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details:
+SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details:
+SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details:
+- answer change for cam6 physics
+
+izumi/nag/aux_cam: BFB except:
+
+DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details:
+- pre-existing failure
+
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details:
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details:
+ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details:
+ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details:
+ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details:
+ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details:
+SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details:
+SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details:
+- answer change for cam6 physics
+
+izumi/gnu/aux_cam: BFB except:
+
+ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF) details:
+ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details:
+- answer changes in cam6 physics
+
+SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp (Overall: NLFAIL) details:
+- namelist change for cam6 physics. No answer change for this PORT test.
+
+CAM tag used for the baseline comparison tests if different than previous
+tag:
+
+Summarize any changes to answers: This changes answers for all
+ configurations using cam6 physics, except for cam6 with silhs.
+
+===============================================================
+===============================================================
+
+Tag name: cam6_4_001
+Originator(s): eaton
+Date: Wed Jun 26, 2024
+One-line Summary: Change name of physics package 'cam_dev' to 'cam7'
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1028
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+#813 - Introduce "-phys cam7" and remove "-phys cam_dev".
+https://github.com/ESCOMP/CAM/issues/813
+
+- The compset tokens CAM%DEV are replaced by CAM70
+- The src/physics/cam_dev/ directory is renamed src/physics/cam7
+- No compset names were changed.
+
+#1033 - Change DART test to use 128 instead of 108 processors
+https://github.com/ESCOMP/CAM/issues/1033
+
+- SMS_C80_P108x1_Lh1.f09_f09_mg17.FHIST_DARTC6
+ changed to
+ SMS_C80_P128x1_Lh1.f09_f09_mg17.FHIST_DARTC6
+
+Issue #1038 - Replace ne16np4 grid for WACCM HIST test with ne16np4.pg3
+https://github.com/ESCOMP/CAM/issues/1039
+
+- SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s
+ changed to
+ SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s
+
+Issue #1039 - Change transient ne30np4 cam tests to ne30np4.pg3 #1039
+https://github.com/ESCOMP/CAM/issues/1039
+
+- ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s
+ changed to
+ ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s
+
+. resolves #813
+. resolves #1033
+. resolves #1038
+. resolves #1039
+
+Describe any changes made to build system:
+
+. The physics package name 'cam_dev' is replaced by 'cam7'
+. The compset component 'CAM%DEV' is replaced by 'CAM70'
+. No compset names have been changed.
+
+Describe any changes made to the namelist:
+
+. cam_physpkg will be set to cam7 instead of cam_dev
+
+List any changes to the defaults for the boundary datasets: none
+
+Describe any substantial timing or memory changes: none
+
+Code reviewed by: cacraigucar, nusbaume
+
+List all files eliminated:
+
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/shell_commands
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_cam
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev/user_nl_clm
+src/physics/cam_dev/cam_snapshot.F90
+src/physics/cam_dev/convect_diagnostics.F90
+src/physics/cam_dev/micro_pumas_cam.F90
+src/physics/cam_dev/physpkg.F90
+src/physics/cam_dev/stochastic_emulated_cam.F90
+src/physics/cam_dev/stochastic_tau_cam.F90
+. These files moved from the directories with 'cam_dev' in the name to
+ directories with 'cam7' in the name.
+
+List all files added and what they do:
+
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/shell_commands
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_cam
+cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam7/user_nl_clm
+. moved from cime_config/testdefs/testmods_dirs/cam/outfrq1d_14dec_ghg_cam_dev
+. shell_commands has cam_dev changed to cam7
+
+src/physics/cam7/cam_snapshot.F90
+src/physics/cam7/convect_diagnostics.F90
+src/physics/cam7/micro_pumas_cam.F90
+src/physics/cam7/physpkg.F90
+src/physics/cam7/stochastic_emulated_cam.F90
+src/physics/cam7/stochastic_tau_cam.F90
+. moved from src/physics/cam_dev
+
+List all existing files that have been modified, and describe the changes:
+
+.gitmodules
+. CMEPS submodule updated to cmeps0.14.67
+
+bld/build-namelist
+. change 'cam_dev' to 'cam7'
+. a consistency check making sure clubb_sgs is used with cam7 is moved to
+ configure since these settings are known there.
+. add check to disallow user setting of do_clubb_sgs
+
+bld/namelist_files/namelist_defaults_cam.xml
+. add default value for cam_physics_mesh for ne16pg3
+
+bld/config_files/definition.xml
+. change valid_values for 'phys' from 'cam_dev' to 'cam7'
+
+bld/configure
+. change 'cam_dev' to 'cam7'
+. the physics package is always specified in the component definition.
+ Remove the default setting and make sure the -phys option is set.
+. set the default chemistry package for cam7 physics to ghg_mam4
+. the setting for 'model_top' was moved to be near the 'nlev' settings.
+. change filepath name from src/physics/cam_dev to src/physics/cam7
+. add check that model_top is only specified for cam7 physics.
+
+bld/namelist_files/namelist_defaults_cam.xml
+. change 'cam_dev' to 'cam7'
+
+bld/namelist_files/namelist_definition.xml
+. update description of do_clubb_sgs to indicate that it is not user
+ settable.
+
+cime_config/SystemTests/mgp.py
+. change 'cam_dev' to 'cam7'
+
+cime_config/config_component.xml
+cime_config/config_compsets.xml
+. change 'CAM%DEV' to 'CAM70'
+. modify compset matching so that %LT and %MT are only matched for CAM70
+ physics.
+. remove %GHGMAM4 modifier (default chemistry set in configure)
+. F2000dev, FCLTHIST, FCMTHIST - change CLM50 to CLM51. CLM no longer supports CLM50
+ with CAM70 physics.
+
+cime_config/config_pes.xml
+. change 'CAM%DEV' to 'CAM70'
+
+cime_config/testdefs/testlist_cam.xml
+. change 'CAM%DEV' to 'CAM70'
+. change 'cam_dev' to 'cam7'
+. increased walltime limits for several tests that hit time limits on
+ derecho
+. remove F2000dev tests from aux_cam and prealpha categories. Also remove
+ 2000_CAM70%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV which is
+ the same as the updated F2000dev. The remaining F2000dev tests will be
+ updated to use F2000climo once that compset is updated to CAM7.
+. Update the following tests which are currently failing due to missing CLM
+ datasets to use CSLAM grids rather than pure SE
+ ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s
+ SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s
+. Change
+ SMS_C80_P108x1_Lh1.f09_f09_mg17.FHIST_DARTC6
+ to
+ SMS_C80_P128x1_Lh1.f09_f09_mg17.FHIST_DARTC6
+. remove 1 remaining Vmct test
+
+src/chemistry/mozart/mo_gas_phase_chemdr.F90
+src/physics/cam/nucleate_ice_cam.F90
+src/physics/cam/phys_control.F90
+src/physics/cam/vertical_diffusion.F90
+. change 'cam_dev' to 'cam7'
+
+src/physics/cam/zm_conv_intr.F90
+. check whether zmconv_parcel_pbl is set true when the bottom layer thickness is
+ less than 100 m. Issue a warning to the log file if it's not.
+
+
+If there were any failures reported from running test_driver.sh on any test
+platform, and checkin with these failures has been OK'd by the gatekeeper,
+then copy the lines from the td.*.status files for the failed tests to the
+appropriate machine below. All failed tests must be justified.
+
+derecho/intel/aux_cam: all PASS except:
+
+ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details:
+ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: NLFAIL) details:
+SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details:
+- cam_physpkg changed from cam_dev to cam7
+
+ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+- pre-existing failure due to HEMCO not having reproducible results
+
+ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+- these tests changed to CSLAM grids, so no baseline for comparison
+
+ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 (Overall: DIFF) details:
+- baseline comparisons fail because case name changed from cam_dev to cam7
+
+SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details:
+- pre-existing failures - need fix in CLM external
+ CLMBuildNamelist::setup_logic_initial_conditions() : use_init_interp is NOT synchronized with init_interp_attributes in the namelist_defaults file, this should be corrected there
+
+SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details:
+- expected diff due to changing CLM50 to CLM51
+
+SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details:
+- pre-existing failure - need fix in CICE external
+ fails in med.F90
+
+izumi/nag/aux_cam: All PASS except
+
+DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details:
+- pre-existing failure
+
+izumi/gnu/aux_cam: All PASS
+
+CAM tag used for the baseline comparison tests if different than previous
+tag:
+
+Summarize any changes to answers: BFB - all diffs are due changing the test
+ grid, the test case name, or the compset definition (CLM50 -> CLM51).
+
+===============================================================
===============================================================
Tag name: cam6_3_162
diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90
index 68657d0739..0575b2f8c0 100644
--- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90
+++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90
@@ -1072,7 +1072,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, &
do m = 1,pcnst
n = map2chm( m )
if ( n > 0 ) then
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! apply to qtend array
if (cnst_type(m).eq.'dry') then
qtend(:ncol,pver,m) = qtend(:ncol,pver,m) - sflx(:ncol,n)*rpdeldry(:ncol,pver)*gravit
diff --git a/src/control/cam_history_support.F90 b/src/control/cam_history_support.F90
index 07ab2dd81a..940dc8c177 100644
--- a/src/control/cam_history_support.F90
+++ b/src/control/cam_history_support.F90
@@ -1407,7 +1407,7 @@ subroutine add_hist_coord_int(name, vlen, long_name, units, values, &
if (i == 0) then
call add_hist_coord(trim(name), i)
if(masterproc) then
- write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), &
+ write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), &
'(', i, ') with length: ', vlen
end if
end if
@@ -1472,7 +1472,7 @@ subroutine add_hist_coord_r8(name, vlen, long_name, units, values, &
if (i == 0) then
call add_hist_coord(trim(name), i)
if(masterproc) then
- write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), &
+ write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), &
'(', i, ') with length: ', vlen
end if
end if
@@ -1551,7 +1551,7 @@ subroutine add_vert_coord(name, vlen, long_name, units, values, &
vertical_coord=.true.)
i = get_hist_coord_index(trim(name))
if(masterproc) then
- write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), &
+ write(iulog, '(3a,i0,a,i0)') 'Registering hist coord: ', trim(name), &
'(', i, ') with length: ', vlen
end if
end if
diff --git a/src/dynamics/fv/dp_coupling.F90 b/src/dynamics/fv/dp_coupling.F90
index 64b2e7b9c8..fc02821471 100644
--- a/src/dynamics/fv/dp_coupling.F90
+++ b/src/dynamics/fv/dp_coupling.F90
@@ -576,7 +576,7 @@ subroutine d_p_coupling(grid, phys_state, phys_tend, pbuf2d, dyn_out)
! (note: cam_thermo_dry_air_update assumes dry unless optional conversion factor provided)
!
call set_state_pdry(phys_state(lchnk)) ! First get dry pressure to use for this timestep
- call set_wet_to_dry(phys_state(lchnk)) ! Dynamics had moist, physics wants dry
+ call set_wet_to_dry(phys_state(lchnk), convert_cnst_type='dry') ! Dynamics had moist, physics wants dry
if (dry_air_species_num>0) then
!------------------------------------------------------------
! Apply limiters to mixing ratios of major species
diff --git a/src/ionosphere/waccmx/ionosphere_interface.F90 b/src/ionosphere/waccmx/ionosphere_interface.F90
index 7579dfcde3..5f719ce0c2 100644
--- a/src/ionosphere/waccmx/ionosphere_interface.F90
+++ b/src/ionosphere/waccmx/ionosphere_interface.F90
@@ -20,6 +20,7 @@ module ionosphere_interface
use pio, only: var_desc_t
use perf_mod, only: t_startf, t_stopf
use epotential_params, only: epot_active, epot_crit_colats
+ use shr_const_mod, only: SHR_CONST_REARTH ! meters
implicit none
@@ -95,6 +96,8 @@ module ionosphere_interface
integer :: mag_nlon=0, mag_nlat=0, mag_nlev=0, mag_ngrid=0
+ real(r8), parameter :: rearth_inv = 1._r8/SHR_CONST_REARTH ! /meters
+
contains
!---------------------------------------------------------------------------
@@ -480,7 +483,6 @@ subroutine ionosphere_run2(phys_state, pbuf2d)
! Gridded component call
use edyn_grid_comp, only: edyn_grid_comp_run2
use shr_assert_mod, only: shr_assert_in_domain
- use shr_const_mod, only: SHR_CONST_REARTH ! meters
! - pull some fields from pbuf and dyn_in
! - invoke ionosphere/electro-dynamics coupling
@@ -546,7 +548,6 @@ subroutine ionosphere_run2(phys_state, pbuf2d)
real(r8) :: r8tmp
real(r8), pointer :: tempm(:,:) => null() ! Temp midpoint field for outfld
real(r8), pointer :: tempi(:,:) => null() ! Temp interface field for outfld
- real(r8), parameter :: rearth_inv = 1._r8/SHR_CONST_REARTH ! /meters
real(r8), parameter :: n2min = 1.e-6_r8 ! lower limit of N2 mixing ratios
character(len=*), parameter :: subname = 'ionosphere_run2'
@@ -740,8 +741,8 @@ subroutine ionosphere_run2(phys_state, pbuf2d)
! Might need geometric height on midpoints for output
!------------------------------------------------------------
if (hist_fld_active('Z3GM')) then
- r8tmp = phys_state(lchnk)%zm(i, k) + phis(i)*rga
- tempm(i, k) = r8tmp * (1._r8 + (r8tmp * rearth_inv))
+ ! geometric altitude (meters above sea level)
+ tempm(i,k) = geometric_hgt(zgp=phys_state(lchnk)%zm(i,k), zsf=phis(i)*rga)
end if
! physics state fields on interfaces (but only to pver)
zi_blck(k, j) = phys_state(lchnk)%zi(i, k) + phis(i)*rga
@@ -750,9 +751,9 @@ subroutine ionosphere_run2(phys_state, pbuf2d)
!------------------------------------------------------------
! Note: zht is pver instead of pverp because dynamo does not
! use bottom interface
- hi_blck(k, j) = zi_blck(k, j) * (1._r8 + (zi_blck(k, j) * rearth_inv))
+ hi_blck(k,j) = geometric_hgt(zgp=phys_state(lchnk)%zi(i,k), zsf=phis(i)*rga)
if (hist_fld_active('Z3GMI')) then
- tempi(i, k) = hi_blck(k, j)
+ tempi(i,k) = hi_blck(k, j)
end if
omega_blck(k, j) = phys_state(lchnk)%omega(i, k)
tn_blck(k, j) = phys_state(lchnk)%t(i, k)
@@ -1164,5 +1165,24 @@ end subroutine ionosphere_alloc
!==========================================================================
+ ! calculates geometric height (meters above sea level)
+ pure function geometric_hgt( zgp, zsf ) result(zgm)
+
+ real(r8), intent(in) :: zgp ! geopotential height (m)
+ real(r8), intent(in) :: zsf ! surface height above sea level (m)
+ real(r8) :: zgm ! geometric height above sea level (m)
+
+ real(r8) :: tmp
+
+ ! Hanli's formulation:
+ ! Z_gm = 1/(1 - (1+Zs/r) * Z_gp/r) * (Zs + (1+Zs/r) * Z_gp)
+ ! Z_gm: geometric height
+ ! Zs: Surface height
+ ! Z_gp: model calculated geopotential height (zm and zi in the model)
+
+ tmp = 1._r8+zsf*rearth_inv
+ zgm = (zsf + tmp*zgp) / (1._r8 - tmp*zgp*rearth_inv)
+
+ end function geometric_hgt
end module ionosphere_interface
diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90
index 4bb5ea6338..5ef05b3b91 100644
--- a/src/physics/cam/clubb_intr.F90
+++ b/src/physics/cam/clubb_intr.F90
@@ -2549,8 +2549,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, &
! Copy the state to state1 array to use in this routine
call physics_state_copy(state, state1)
- ! constituents are all treated as dry mmr by clubb
- call set_wet_to_dry(state1)
+ ! Constituents are all treated as dry mmr by clubb. Convert the water species to
+ ! a dry basis.
+ call set_wet_to_dry(state1, convert_cnst_type='wet')
if (clubb_do_liqsupersat) then
call pbuf_get_field(pbuf, npccn_idx, npccn)
diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90
index 6a01415f04..7db2792a12 100644
--- a/src/physics/cam/cospsimulator_intr.F90
+++ b/src/physics/cam/cospsimulator_intr.F90
@@ -13,14 +13,15 @@ module cospsimulator_intr
use shr_kind_mod, only: r8 => shr_kind_r8
use spmd_utils, only: masterproc
use ppgrid, only: pcols, pver, pverp, begchunk, endchunk
+ use ref_pres, only: ktop => trop_cloud_top_lev
use perf_mod, only: t_startf, t_stopf
- use cam_abortutils, only: endrun
+ use cam_abortutils, only: endrun, handle_allocate_error
use phys_control, only: cam_physpkg_is
use cam_logfile, only: iulog
#ifdef USE_COSP
use quickbeam, only: radar_cfg
use mod_quickbeam_optics, only: size_distribution
- use mod_cosp, only: cosp_outputs,cosp_optical_inputs,cosp_column_inputs
+ use mod_cosp, only: cosp_outputs, cosp_optical_inputs, cosp_column_inputs
use mod_cosp_config, only: pres_binCenters, pres_binEdges, tau_binCenters, &
tau_binEdges, cloudsat_binCenters, cloudsat_binEdges, calipso_binCenters, &
calipso_binEdges, misr_histHgtCenters, misr_histHgtEdges, PARASOL_SZA, &
@@ -56,22 +57,23 @@ module cospsimulator_intr
! ######################################################################################
! Whether to do COSP calcs and I/O, default is false. If docosp is specified in
! the atm_in namelist, this value is overwritten and cosp is run
- logical, public :: docosp = .false.
+ logical, public, protected :: docosp = .false.
! Frequency at which cosp is called, every cosp_nradsteps radiation timestep
- integer, public :: cosp_nradsteps = 1! CAM namelist variable default, not in COSP namelist
+ integer, public, protected :: cosp_nradsteps = 1
#ifdef USE_COSP
! ######################################################################################
! Local declarations
! ######################################################################################
- integer, parameter :: &
- nhtml_cosp = pver ! Mumber of model levels is pver
integer :: &
- nscol_cosp, & ! Number of subcolumns, use namelist input Ncolumns to set.
+ nlay, & ! Number of CAM layers used by COSP.
+ nlayp, & ! Number of CAM layer interfaces used by COSP.
+ nscol_cosp, & ! Number of subcolumns, allow namelist input to set.
nht_cosp ! Number of height for COSP radar and calipso simulator outputs.
! *set to 40 if csat_vgrid=.true., else set to Nlr*
+
! ######################################################################################
! Bin-boundaries for mixed dimensions. Calculated in cospsetupvales OR in cosp_config.F90
@@ -94,7 +96,6 @@ module cospsimulator_intr
real(r8), target :: reffICE_binCenters_cosp(numMODISReffIceBins)
real(r8), target :: reffLIQ_binCenters_cosp(numMODISReffLiqBins)
- real(r8) :: htmlmid_cosp(nhtml_cosp) ! Model level height midpoints for output
integer :: prstau_cosp(nprs_cosp*ntau_cosp) ! ISCCP mixed output dimension index
integer :: prstau_cosp_modis(nprs_cosp*ntau_cosp_modis) ! MODIS mixed output dimension index
integer :: htmisrtau_cosp(nhtmisr_cosp*ntau_cosp) ! MISR mixed output dimension index
@@ -104,6 +105,7 @@ module cospsimulator_intr
real(r8) :: prstau_taumid_cosp_modis(nprs_cosp*ntau_cosp_modis)
real(r8) :: htmisrtau_htmisrmid_cosp(nhtmisr_cosp*ntau_cosp)
real(r8) :: htmisrtau_taumid_cosp(nhtmisr_cosp*ntau_cosp)
+ real(r8),allocatable :: htmlmid_cosp(:) ! Model level height midpoints for output (nlay)
real(r8),allocatable, public :: htdbze_dbzemid_cosp(:) ! (nht_cosp*CLOUDSAT_DBZE_BINS)
real(r8),allocatable, target :: htlim_cosp(:,:) ! height limits for COSP outputs (nht_cosp+1)
real(r8),allocatable, target :: htmid_cosp(:) ! height midpoints of COSP radar/lidar output (nht_cosp)
@@ -111,73 +113,64 @@ module cospsimulator_intr
real(r8),allocatable :: htdbze_htmid_cosp(:) ! (nht_cosp*CLOUDSAT_DBZE_BINS)
real(r8),allocatable :: htsr_htmid_cosp(:) ! (nht_cosp*nsr_cosp)
real(r8),allocatable :: htsr_srmid_cosp(:) ! (nht_cosp*nsr_cosp)
- real(r8),allocatable :: htmlscol_htmlmid_cosp(:) ! (nhtml_cosp*nscol_cosp)
- real(r8),allocatable :: htmlscol_scol_cosp(:) ! (nhtml_cosp*nscol_cosp)
+ real(r8),allocatable :: htmlscol_htmlmid_cosp(:) ! (nlay*nscol_cosp)
+ real(r8),allocatable :: htmlscol_scol_cosp(:) ! (nlay*nscol_cosp)
integer, allocatable, target :: scol_cosp(:) ! sub-column number (nscol_cosp)
integer, allocatable :: htdbze_cosp(:) ! radar CFAD mixed output dimension index (nht_cosp*CLOUDSAT_DBZE_BINS)
integer, allocatable :: htsr_cosp(:) ! lidar CFAD mixed output dimension index (nht_cosp*nsr_cosp)
- integer, allocatable :: htmlscol_cosp(:) ! html-subcolumn mixed output dimension index (nhtml_cosp*nscol_cosp)
+ integer, allocatable :: htmlscol_cosp(:) ! html-subcolumn mixed output dimension index (nlay*nscol_cosp)
! ######################################################################################
- ! Default namelists
- ! The CAM and COSP namelists defaults are set below. Some of the COSP namelist
- ! variables are part of the CAM namelist - they all begin with "cosp_" to keep their
- ! names specific to COSP. I set their CAM namelist defaults here, not in namelist_defaults_cam.xml
- ! Variables identified as namelist variables are defined in
- ! ../models/atm/cam/bld/namelist_files/namelist_definition.xml
+ ! Default CAM namelist settings
! ######################################################################################
- ! CAM
- logical :: cosp_amwg = .false. ! CAM namelist variable default, not in COSP namelist
- logical :: cosp_lite = .false. ! CAM namelist variable default, not in COSP namelist
- logical :: cosp_passive = .false. ! CAM namelist variable default, not in COSP namelist
- logical :: cosp_active = .false. ! CAM namelist variable default, not in COSP namelist
- logical :: cosp_isccp = .false. ! CAM namelist variable default, not in COSP namelist
- logical :: cosp_lradar_sim = .false. ! CAM namelist variable default
- logical :: cosp_llidar_sim = .false. ! CAM namelist variable default
- logical :: cosp_lisccp_sim = .false. ! CAM namelist variable default
- logical :: cosp_lmisr_sim = .false. ! CAM namelist variable default
- logical :: cosp_lmodis_sim = .false. ! CAM namelist variable default
- logical :: cosp_histfile_aux = .false. ! CAM namelist variable default
- logical :: cosp_lfrac_out = .false. ! CAM namelist variable default
- logical :: cosp_runall = .false. ! flag to run all of the cosp simulator package
- integer :: cosp_ncolumns = 50 ! CAM namelist variable default
- integer :: cosp_histfile_num =1 ! CAM namelist variable default, not in COSP namelist
- integer :: cosp_histfile_aux_num =-1 ! CAM namelist variable default, not in COSP namelist
+ logical :: cosp_amwg = .false.
+ logical :: cosp_lite = .false.
+ logical :: cosp_passive = .false.
+ logical :: cosp_active = .false.
+ logical :: cosp_isccp = .false.
+ logical :: cosp_lradar_sim = .false.
+ logical :: cosp_llidar_sim = .false.
+ logical :: cosp_lisccp_sim = .false.
+ logical :: cosp_lmisr_sim = .false.
+ logical :: cosp_lmodis_sim = .false.
+ logical :: cosp_histfile_aux = .false.
+ logical :: cosp_lfrac_out = .false.
+ logical :: cosp_runall = .false.
+ integer :: cosp_ncolumns = 50
+ integer :: cosp_histfile_num = 1
+ integer :: cosp_histfile_aux_num = -1
! COSP
- logical :: lradar_sim = .false. ! COSP namelist variable, can be changed from default by CAM namelist
- logical :: llidar_sim = .false. !
- logical :: lparasol_sim = .false. !
- logical :: lgrLidar532 = .false. !
- logical :: latlid = .false. !
- logical :: lisccp_sim = .false. ! ""
- logical :: lmisr_sim = .false. ! ""
- logical :: lmodis_sim = .false. ! ""
- logical :: lrttov_sim = .false. ! not running rttov, always set to .false.
- logical :: lfrac_out = .false. ! COSP namelist variable, can be changed from default by CAM namelist
+ logical :: lradar_sim = .false.
+ logical :: llidar_sim = .false.
+ logical :: lparasol_sim = .false.
+ logical :: lgrLidar532 = .false.
+ logical :: latlid = .false.
+ logical :: lisccp_sim = .false.
+ logical :: lmisr_sim = .false.
+ logical :: lmodis_sim = .false.
+ logical :: lrttov_sim = .false.
+ logical :: lfrac_out = .false.
! ######################################################################################
! COSP parameters
! ######################################################################################
- ! Note: Unless otherwise specified, these are parameters that cannot be set by the CAM namelist.
integer, parameter :: Npoints_it = 10000 ! Max # gridpoints to be processed in one iteration (10,000)
- integer :: ncolumns = 50 ! Number of subcolumns in SCOPS (50), can be changed from default by CAM namelist
+ integer :: ncolumns = 50 ! Number of subcolumns in SCOPS (50)
integer :: nlr = 40 ! Number of levels in statistical outputs
! (only used if USE_VGRID=.true.) (40)
logical :: use_vgrid = .true. ! Use fixed vertical grid for outputs?
! (if .true. then define # of levels with nlr) (.true.)
logical :: csat_vgrid = .true. ! CloudSat vertical grid?
- ! (if .true. then the CloudSat standard grid is used.
- ! If set, overides use_vgrid.) (.true.)
- ! namelist variables for COSP input related to radar simulator
+
+ ! Variables for COSP input related to radar simulator
real(r8) :: radar_freq = 94.0_r8 ! CloudSat radar frequency (GHz) (94.0)
integer :: surface_radar = 0 ! surface=1, spaceborne=0 (0)
- integer :: use_mie_tables = 0 ! use a precomputed lookup table? yes=1,no=0 (0)
integer :: use_gas_abs = 1 ! include gaseous absorption? yes=1,no=0 (1)
integer :: do_ray = 0 ! calculate/output Rayleigh refl=1, not=0 (0)
- integer :: melt_lay = 0 ! melting layer model off=0, on=1 (0)
real(r8) :: k2 = -1 ! |K|^2, -1=use frequency dependent default (-1)
- ! namelist variables for COSP input related to lidar simulator
+
+ ! Variables for COSP input related to lidar simulator
integer, parameter :: Nprmts_max_hydro = 12 ! Max # params for hydrometeor size distributions (12)
integer, parameter :: Naero = 1 ! Number of aerosol species (Not used) (1)
integer, parameter :: Nprmts_max_aero = 1 ! Max # params for aerosol size distributions (not used) (1)
@@ -185,7 +178,7 @@ module cospsimulator_intr
! (0=ice-spheres ; 1=ice-non-spherical) (0)
integer, parameter :: overlap = 3 ! overlap type: 1=max, 2=rand, 3=max/rand (3)
- !! namelist variables for COSP input related to ISCCP simulator
+ ! Variables for COSP input related to ISCCP simulator
integer :: isccp_topheight = 1 ! 1 = adjust top height using both a computed infrared
! brightness temperature and the visible
! optical depth to adjust cloud top pressure.
@@ -268,188 +261,33 @@ module cospsimulator_intr
CONTAINS
- ! ######################################################################################
- ! SUBROUTINE setcosp2values
- ! ######################################################################################
-#ifdef USE_COSP
- subroutine setcosp2values(Nlr_in,use_vgrid_in,csat_vgrid_in,Ncolumns_in,cosp_nradsteps_in)
- use mod_cosp, only: cosp_init
- use mod_cosp_config, only: vgrid_zl, vgrid_zu, vgrid_z
- use mod_quickbeam_optics, only: hydro_class_init, quickbeam_optics_init
- ! Inputs
- integer, intent(in) :: Nlr_in ! Number of vertical levels for CALIPSO and Cloudsat products
- integer, intent(in) :: Ncolumns_in ! Number of sub-columns
- integer, intent(in) :: cosp_nradsteps_in ! How often to call COSP?
- logical, intent(in) :: use_vgrid_in ! Logical switch to use interpolated, to Nlr_in, grid for CALIPSO and Cloudsat
- logical, intent(in) :: csat_vgrid_in !
-
- ! Local
- logical :: ldouble=.false.
- logical :: lsingle=.true. ! Default is to use single moment
- integer :: i,k
-
- prsmid_cosp = pres_binCenters
- prslim_cosp = pres_binEdges
- taumid_cosp = tau_binCenters
- taulim_cosp = tau_binEdges
- srmid_cosp = calipso_binCenters
- srlim_cosp = calipso_binEdges
- sza_cosp = parasol_sza
- dbzemid_cosp = cloudsat_binCenters
- dbzelim_cosp = cloudsat_binEdges
- htmisrmid_cosp = misr_histHgtCenters
- htmisrlim_cosp = misr_histHgtEdges
- taumid_cosp_modis = tau_binCenters
- taulim_cosp_modis = tau_binEdges
- reffICE_binCenters_cosp = reffICE_binCenters
- reffICE_binEdges_cosp = reffICE_binEdges
- reffLIQ_binCenters_cosp = reffLIQ_binCenters
- reffLIQ_binEdges_cosp = reffLIQ_binEdges
-
- ! Initialize the distributional parameters for hydrometeors in radar simulator. In COSPv1.4, this was declared in
- ! cosp_defs.f.
- if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then
- ldouble = .true.
- lsingle = .false.
- endif
- call hydro_class_init(lsingle,ldouble,sd)
- call quickbeam_optics_init()
-
- ! DS2017: The setting up of the vertical grid for regridding the CALIPSO and Cloudsat products is
- ! now donein cosp_init, but these fields are stored in cosp_config.F90.
- ! Additionally all static fields used by the individual simulators are set up by calls
- ! to _init functions in cosp_init.
- ! DS2019: Add logicals, default=.false., for new Lidar simuldators (Earthcare (atlid) and ground-based
- ! lidar at 532nm)
- call COSP_INIT(Lisccp_sim, Lmodis_sim, Lmisr_sim, Lradar_sim, Llidar_sim, LgrLidar532, &
- Latlid, Lparasol_sim, Lrttov_sim, radar_freq, k2, use_gas_abs, do_ray, &
- isccp_topheight, isccp_topheight_direction, surface_radar, rcfg_cloudsat, &
- use_vgrid_in, csat_vgrid_in, Nlr_in, pver, cloudsat_micro_scheme)
-
- ! Set number of sub-columns, from namelist
- nscol_cosp = Ncolumns_in
-
- if (use_vgrid_in) then !! using fixed vertical grid
- if (csat_vgrid_in) then
- nht_cosp = 40
- else
- nht_cosp = Nlr_in
- endif
- endif
-
- ! Set COSP call frequency, from namelist.
- cosp_nradsteps = cosp_nradsteps_in
-
- ! DJS2017: In COSP2, most of the bin boundaries, centers, and edges are declared in src/cosp_config.F90.
- ! Above I just assign them accordingly in the USE statement. Other bin bounds needed by CAM
- ! are calculated here.
- ! Allocate
- allocate(htlim_cosp(2,nht_cosp),htlim_cosp_1d(nht_cosp+1),htmid_cosp(nht_cosp),scol_cosp(nscol_cosp), &
- htdbze_cosp(nht_cosp*CLOUDSAT_DBZE_BINS),htsr_cosp(nht_cosp*nsr_cosp),htmlscol_cosp(nhtml_cosp*nscol_cosp),&
- htdbze_htmid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS),htdbze_dbzemid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), &
- htsr_htmid_cosp(nht_cosp*nsr_cosp),htsr_srmid_cosp(nht_cosp*nsr_cosp), &
- htmlscol_htmlmid_cosp(nhtml_cosp*nscol_cosp),htmlscol_scol_cosp(nhtml_cosp*nscol_cosp))
-
- ! DJS2017: Just pull from cosp_config
- if (use_vgrid_in) then
- htlim_cosp_1d(1) = vgrid_zu(1)
- htlim_cosp_1d(2:nht_cosp+1) = vgrid_zl
- endif
- htmid_cosp = vgrid_z
- htlim_cosp(1,:) = vgrid_zu
- htlim_cosp(2,:) = vgrid_zl
-
- scol_cosp(:) = (/(k,k=1,nscol_cosp)/)
-
- ! Just using an index here, model height is a prognostic variable
- htmlmid_cosp(:) = (/(k,k=1,nhtml_cosp)/)
-
- ! assign mixed dimensions an integer index for cam_history.F90
- do k=1,nprs_cosp*ntau_cosp
- prstau_cosp(k) = k
- end do
- do k=1,nprs_cosp*ntau_cosp_modis
- prstau_cosp_modis(k) = k
- end do
- do k=1,nht_cosp*CLOUDSAT_DBZE_BINS
- htdbze_cosp(k) = k
- end do
- do k=1,nht_cosp*nsr_cosp
- htsr_cosp(k) = k
- end do
- do k=1,nhtml_cosp*nscol_cosp
- htmlscol_cosp(k) = k
- end do
- do k=1,nhtmisr_cosp*ntau_cosp
- htmisrtau_cosp(k) = k
- end do
-
- ! next, assign collapsed reference vectors for cam_history.F90
- ! convention for saving output = prs1,tau1 ... prs1,tau7 ; prs2,tau1 ... prs2,tau7 etc.
- ! actual output is specified in cospsimulator1_intr.F90
- do k=1,nprs_cosp
- prstau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp)
- prstau_prsmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=prsmid_cosp(k)
- prstau_taumid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=taumid_cosp_modis(1:ntau_cosp_modis)
- prstau_prsmid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=prsmid_cosp(k)
- enddo
-
- do k=1,nht_cosp
- htdbze_dbzemid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=dbzemid_cosp(1:CLOUDSAT_DBZE_BINS)
- htdbze_htmid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=htmid_cosp(k)
- enddo
-
- do k=1,nht_cosp
- htsr_srmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=srmid_cosp(1:nsr_cosp)
- htsr_htmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=htmid_cosp(k)
- enddo
-
- do k=1,nhtml_cosp
- htmlscol_scol_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=scol_cosp(1:nscol_cosp)
- htmlscol_htmlmid_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=htmlmid_cosp(k)
- enddo
-
- do k=1,nhtmisr_cosp
- htmisrtau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp)
- htmisrtau_htmisrmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=htmisrmid_cosp(k)
- enddo
-
- end subroutine setcosp2values
-#endif
-
! ######################################################################################
! SUBROUTINE cospsimulator_intr_readnl
- !
- ! PURPOSE: to read namelist variables and run setcospvalues subroutine.note: cldfrc_readnl
- ! is a good template in cloud_fraction.F90. Make sure that this routine is reading in a
- ! namelist. models/atm/cam/bld/build-namelist is the perl script to check.
! ######################################################################################
subroutine cospsimulator_intr_readnl(nlfile)
use namelist_utils, only: find_group_name
use units, only: getunit, freeunit
#ifdef SPMD
- use mpishorthand, only: mpicom, mpilog, mpiint, mpichar
+ use mpishorthand, only: mpicom, mpilog, mpiint
#endif
- character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input (nlfile=atm_in)
+ character(len=*), intent(in) :: nlfile ! file containing namelist input (nlfile=atm_in)
! Local variables
integer :: unitn, ierr
character(len=*), parameter :: subname = 'cospsimulator_intr_readnl'
#ifdef USE_COSP
-!!! this list should include any variable that you might want to include in the namelist
-!!! philosophy is to not include COSP output flags but just important COSP settings and cfmip controls.
- namelist /cospsimulator_nl/ docosp, cosp_active, cosp_amwg, &
- cosp_histfile_num, cosp_histfile_aux, cosp_histfile_aux_num, cosp_isccp, cosp_lfrac_out, &
- cosp_lite, cosp_lradar_sim, cosp_llidar_sim, cosp_lisccp_sim, cosp_lmisr_sim, cosp_lmodis_sim, cosp_ncolumns, &
- cosp_nradsteps, cosp_passive, cosp_runall
+ namelist /cospsimulator_nl/ docosp, cosp_ncolumns, cosp_nradsteps, &
+ cosp_amwg, cosp_lite, cosp_passive, cosp_active, cosp_isccp, cosp_runall, &
+ cosp_lfrac_out, cosp_lradar_sim, cosp_llidar_sim, cosp_lisccp_sim, &
+ cosp_lmisr_sim, cosp_lmodis_sim, &
+ cosp_histfile_num, cosp_histfile_aux, cosp_histfile_aux_num
!! read in the namelist
if (masterproc) then
unitn = getunit()
- open( unitn, file=trim(nlfile), status='old' ) !! presumably opens the namelist file "nlfile"
- !! position the file to write to the cospsimulator portion of the cam_in namelist
+ open( unitn, file=trim(nlfile), status='old' )
call find_group_name(unitn, 'cospsimulator_nl', status=ierr)
if (ierr == 0) then
read(unitn, cospsimulator_nl, iostat=ierr)
@@ -565,24 +403,17 @@ subroutine cospsimulator_intr_readnl(nlfile)
cosp_nradsteps = 3
end if
- !! reset COSP namelist variables based on input from cam namelist variables
- if (cosp_ncolumns .ne. ncolumns) then
- ncolumns = cosp_ncolumns
- end if
+ ! Set number of sub-columns, from namelist
+ ncolumns = cosp_ncolumns
+ nscol_cosp = cosp_ncolumns
- ! *NOTE* COSP is configured in CAM such that if a simulator is requested, all diagnostics
- ! are output. So no need turn on/aff outputs if simulator is requested.
-
- ! Set vertical coordinate, subcolumn, and calculation frequency cosp options based on namelist inputs
- call setcosp2values(nlr,use_vgrid,csat_vgrid,ncolumns,cosp_nradsteps)
-
if (masterproc) then
if (docosp) then
write(iulog,*)'COSP configuration:'
write(iulog,*)' Number of COSP subcolumns = ', cosp_ncolumns
- write(iulog,*)' Frequency at which cosp is called = ', cosp_nradsteps
+ write(iulog,*)' COSP frequency in radiation steps = ', cosp_nradsteps
write(iulog,*)' Enable radar simulator = ', lradar_sim
- write(iulog,*)' Enable calipso simulator = ', llidar_sim
+ write(iulog,*)' Enable calipso simulator = ', llidar_sim
write(iulog,*)' Enable ISCCP simulator = ', lisccp_sim
write(iulog,*)' Enable MISR simulator = ', lmisr_sim
write(iulog,*)' Enable MODIS simulator = ', lmodis_sim
@@ -590,7 +421,7 @@ subroutine cospsimulator_intr_readnl(nlfile)
write(iulog,*)' Write COSP output to history file = ', cosp_histfile_num
write(iulog,*)' Write COSP input fields = ', cosp_histfile_aux
write(iulog,*)' Write COSP input fields to history file = ', cosp_histfile_aux_num
- write(iulog,*)' Write COSP subcolumn fields = ', cosp_lfrac_out
+ write(iulog,*)' Write COSP subcolumn fields = ', lfrac_out
else
write(iulog,*)'COSP not enabled'
end if
@@ -603,10 +434,23 @@ end subroutine cospsimulator_intr_readnl
! ######################################################################################
subroutine cospsimulator_intr_register()
+ ! The coordinate variables used for COSP output are defined here. This
+ ! needs to be done before the call to read_restart_history in order for
+ ! restarts to work.
+
use cam_history_support, only: add_hist_coord
+ !---------------------------------------------------------------------------
#ifdef USE_COSP
- ! register non-standard variable dimensions
+ ! Set number of levels used by COSP to the number of levels used by
+ ! CAM's cloud macro/microphysics parameterizations.
+ nlay = pver - ktop + 1
+ nlayp = nlay + 1
+
+ ! Set COSP coordinate arrays
+ call setcosp2values()
+
+ ! Define coordinate variables for COSP outputs.
if (lisccp_sim .or. lmodis_sim) then
call add_hist_coord('cosp_prs', nprs_cosp, 'COSP Mean ISCCP pressure', &
'hPa', prsmid_cosp, bounds_name='cosp_prs_bnds', bounds=prslim_cosp)
@@ -625,7 +469,7 @@ subroutine cospsimulator_intr_register()
if (llidar_sim .or. lradar_sim) then
call add_hist_coord('cosp_ht', nht_cosp, &
- 'COSP Mean Height for calipso and radar simulator outputs', 'm', &
+ 'COSP Mean Height for calipso and radar simulator outputs', 'm', &
htmid_cosp, bounds_name='cosp_ht_bnds', bounds=htlim_cosp, &
vertical_coord=.true.)
end if
@@ -642,7 +486,7 @@ subroutine cospsimulator_intr_register()
end if
if (lradar_sim) then
- call add_hist_coord('cosp_dbze', CLOUDSAT_DBZE_BINS, &
+ call add_hist_coord('cosp_dbze', CLOUDSAT_DBZE_BINS, &
'COSP Mean dBZe for radar simulator CFAD output', 'dBZ', &
dbzemid_cosp, bounds_name='cosp_dbze_bnds', bounds=dbzelim_cosp)
end if
@@ -676,482 +520,346 @@ subroutine cospsimulator_intr_init()
#ifdef USE_COSP
use cam_history, only: addfld, add_default, horiz_only
-#ifdef SPMD
- use mpishorthand, only : mpir8, mpiint, mpicom
-#endif
- use netcdf, only : nf90_open, nf90_inq_varid, nf90_get_var, nf90_close, nf90_nowrite
- use error_messages, only : handle_ncerr, alloc_err
-
- use physics_buffer, only: pbuf_get_index
+ use physics_buffer, only: pbuf_get_index
- use mod_cosp_config, only : R_UNDEF
-
- integer :: ncid,latid,lonid,did,hrid,minid,secid, istat
- integer :: i, ierr
+ integer :: i, ierr, istat
+ character(len=*), parameter :: sub = 'cospsimulator_intr_init'
+ !---------------------------------------------------------------------------
+ ! The COSP init method (setcosp2values) was run from cospsimulator_intr_register in order to add
+ ! the history coordinate variables earlier as needed for the restart time sequencing.
+
! ISCCP OUTPUTS
if (lisccp_sim) then
- !! addfld calls for all
- !*cfMon,cfDa* clisccp2 (time,tau,plev,profile), CFMIP wants 7 p bins, 7 tau bins
- call addfld('FISCCP1_COSP',(/'cosp_tau','cosp_prs'/),'A','percent', &
- 'Grid-box fraction covered by each ISCCP D level cloud type',&
- flag_xyfill=.true., fill_value=R_UNDEF)
-
- !*cfMon,cfDa* tclisccp (time,profile), CFMIP wants "gridbox mean cloud cover from ISCCP"
- call addfld('CLDTOT_ISCCP', horiz_only,'A','percent', &
+ call addfld('FISCCP1_COSP', (/'cosp_tau','cosp_prs'/), 'A', 'percent', &
+ 'Grid-box fraction covered by each ISCCP D level cloud type', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_ISCCP', horiz_only, 'A', 'percent', &
'Total Cloud Fraction Calculated by the ISCCP Simulator ',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfDa* albisccp (time,profile)
- ! Per CFMIP request - weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average)
- call addfld('MEANCLDALB_ISCCP',horiz_only,'A','1','Mean cloud albedo*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfDa* ctpisccp (time,profile)
- ! Per CFMIP request - weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average)
- call addfld('MEANPTOP_ISCCP',horiz_only,'A','Pa','Mean cloud top pressure*CLDTOT_ISCCP',flag_xyfill=.true., &
- fill_value=R_UNDEF)
- ! tauisccp (time,profile)
- ! For averaging, weight by ISCCP Total Cloud Fraction (divide by CLDTOT_ISSCP in history file to get weighted average)
- call addfld ('MEANTAU_ISCCP',horiz_only,'A','1','Mean optical thickness*CLDTOT_ISCCP',flag_xyfill=.true., &
- fill_value=R_UNDEF)
- ! meantbisccp (time,profile), at 10.5 um
- call addfld ('MEANTB_ISCCP',horiz_only,'A','K','Mean Infrared Tb from ISCCP simulator',flag_xyfill=.true., &
- fill_value=R_UNDEF)
- ! meantbclrisccp (time,profile)
- call addfld ('MEANTBCLR_ISCCP',horiz_only,'A','K','Mean Clear-sky Infrared Tb from ISCCP simulator', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! boxtauisccp (time,column,profile)
- call addfld ('TAU_ISCCP',(/'cosp_scol'/),'I','1','Optical Depth in each Subcolumn',flag_xyfill=.true., fill_value=R_UNDEF)
- ! boxptopisccp (time,column,profile)
- call addfld ('CLDPTOP_ISCCP',(/'cosp_scol'/),'I','Pa','Cloud Top Pressure in each Subcolumn', &
- flag_xyfill=.true., fill_value=R_UNDEF)
-
- !! add all isccp outputs to the history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('FISCCP1_COSP',cosp_histfile_num,' ')
- call add_default ('CLDTOT_ISCCP',cosp_histfile_num,' ')
- call add_default ('MEANCLDALB_ISCCP',cosp_histfile_num,' ')
- call add_default ('MEANPTOP_ISCCP',cosp_histfile_num,' ')
- call add_default ('MEANTAU_ISCCP',cosp_histfile_num,' ')
- call add_default ('MEANTB_ISCCP',cosp_histfile_num,' ')
- call add_default ('MEANTBCLR_ISCCP',cosp_histfile_num,' ')
+ call addfld('MEANCLDALB_ISCCP', horiz_only, 'A', '1', &
+ 'Mean cloud albedo*CLDTOT_ISCCP', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('MEANPTOP_ISCCP', horiz_only, 'A', 'Pa', &
+ 'Mean cloud top pressure*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('MEANTAU_ISCCP', horiz_only, 'A', '1', &
+ 'Mean optical thickness*CLDTOT_ISCCP',flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('MEANTB_ISCCP', horiz_only, 'A', 'K', &
+ 'Mean Infrared Tb from ISCCP simulator',flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('MEANTBCLR_ISCCP', horiz_only, 'A', 'K', &
+ 'Mean Clear-sky Infrared Tb from ISCCP simulator', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAU_ISCCP', (/'cosp_scol'/), 'I', '1', &
+ 'Optical Depth in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDPTOP_ISCCP', (/'cosp_scol'/), 'I', 'Pa', &
+ 'Cloud Top Pressure in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('FISCCP1_COSP',cosp_histfile_num,' ')
+ call add_default('CLDTOT_ISCCP',cosp_histfile_num,' ')
+ call add_default('MEANCLDALB_ISCCP',cosp_histfile_num,' ')
+ call add_default('MEANPTOP_ISCCP',cosp_histfile_num,' ')
+ call add_default('MEANTAU_ISCCP',cosp_histfile_num,' ')
+ call add_default('MEANTB_ISCCP',cosp_histfile_num,' ')
+ call add_default('MEANTBCLR_ISCCP',cosp_histfile_num,' ')
end if
! CALIPSO SIMULATOR OUTPUTS
if (llidar_sim) then
- !! addfld calls for all
- !*cfMon,cfOff,cfDa,cf3hr* cllcalipso (time,profile)
- call addfld('CLDLOW_CAL',horiz_only,'A','percent','Calipso Low-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfOff,cfDa,cf3hr* clmcalipso (time,profile)
- call addfld('CLDMED_CAL',horiz_only,'A','percent','Calipso Mid-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfOff,cfDa,cf3hr* clhcalipso (time,profile)
- call addfld('CLDHGH_CAL',horiz_only,'A','percent','Calipso High-level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfOff,cfDa,cf3hr* cltcalipso (time,profile)
- call addfld('CLDTOT_CAL',horiz_only,'A','percent','Calipso Total Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfOff,cfDa,cf3hr* clcalipso (time,height,profile)
- call addfld('CLD_CAL',(/'cosp_ht'/),'A','percent','Calipso Cloud Fraction (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfMon,cfOff,cfDa,cf3hr* parasol_refl (time,sza,profile)
- call addfld ('RFL_PARASOL',(/'cosp_sza'/),'A','fraction','PARASOL-like mono-directional reflectance ', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfOff,cf3hr* cfad_calipsosr532 (time,height,scat_ratio,profile), %11%, default is 40 vert levs, 15 SR bins
- call addfld('CFAD_SR532_CAL',(/'cosp_sr','cosp_ht'/),'A','fraction', &
- 'Calipso Scattering Ratio CFAD (532 nm)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! beta_mol532 (time,height_mlev,profile)
- call addfld ('MOL532_CAL',(/'lev'/),'A','m-1sr-1','Calipso Molecular Backscatter (532 nm) ', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! atb532 (time,height_mlev,column,profile)
- call addfld ('ATB532_CAL',(/'cosp_scol','lev '/),'I','no_unit_log10(x)', &
- 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsoliq (time,alt40,loc) !!+cosp1.4
- call addfld('CLD_CAL_LIQ', (/'cosp_ht'/), 'A','percent', 'Calipso Liquid Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsoice (time,alt40,loc)
- call addfld('CLD_CAL_ICE', (/'cosp_ht'/), 'A','percent', 'Calipso Ice Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsoun (time,alt40,loc)
- call addfld('CLD_CAL_UN', (/'cosp_ht'/),'A','percent', 'Calipso Undefined-Phase Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsotmp (time,alt40,loc)
- call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsotmpliq (time,alt40,loc)
- call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsotmpice (time,alt40,loc)
- call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclcalipsotmpun (time,alt40,loc)
- call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A','percent', 'NOT SURE WHAT THIS IS Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcltcalipsoice (time,loc)
- call addfld('CLDTOT_CAL_ICE', horiz_only,'A','percent','Calipso Total Ice Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcltcalipsoliq (time,loc)
- call addfld('CLDTOT_CAL_LIQ', horiz_only,'A','percent','Calipso Total Liquid Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcltcalipsoun (time,loc)
- call addfld('CLDTOT_CAL_UN',horiz_only,'A','percent','Calipso Total Undefined-Phase Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclhcalipsoice (time,loc)
- call addfld('CLDHGH_CAL_ICE',horiz_only,'A','percent','Calipso High-level Ice Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclhcalipsoliq (time,loc)
- call addfld('CLDHGH_CAL_LIQ',horiz_only,'A','percent','Calipso High-level Liquid Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclhcalipsoun (time,loc)
- call addfld('CLDHGH_CAL_UN',horiz_only,'A','percent','Calipso High-level Undefined-Phase Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclmcalipsoice (time,loc)
- call addfld('CLDMED_CAL_ICE',horiz_only,'A','percent','Calipso Mid-level Ice Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclmcalipsoliq (time,loc)
- call addfld('CLDMED_CAL_LIQ',horiz_only,'A','percent','Calipso Mid-level Liquid Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lclmcalipsoun (time,loc)
- call addfld('CLDMED_CAL_UN',horiz_only,'A','percent','Calipso Mid-level Undefined-Phase Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcllcalipsoice (time,loc)
- call addfld('CLDLOW_CAL_ICE',horiz_only,'A','percent','Calipso Low-level Ice Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcllcalipsoliq (time,loc)
- call addfld('CLDLOW_CAL_LIQ',horiz_only,'A','percent','Calipso Low-level Liquid Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! lcllcalipsoun (time,loc) !+cosp1.4
- call addfld('CLDLOW_CAL_UN',horiz_only,'A','percent','Calipso Low-level Undefined-Phase Cloud Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
-
-! ! Calipso Opaque/thin cloud diagnostics
-! call addfld('CLDOPQ_CAL', horiz_only, 'A', 'percent', 'CALIPSO Opaque Cloud Cover', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL', horiz_only, 'A', 'percent', 'CALIPSO Thin Cloud Cover', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDZOPQ_CAL', horiz_only, 'A', 'm', 'CALIPSO z_opaque Altitude', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDOPQ_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO Opaque Cloud Fraction', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO Thin Cloud Fraction', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDZOPQ_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO z_opaque Fraction', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('OPACITY_CAL_2D', (/'cosp_ht'/), 'A', 'percent', 'CALIPSO opacity Fraction', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDOPQ_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO Opaque Cloud Temperature', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO Thin Cloud Temperature', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDZOPQ_CAL_TMP', horiz_only, 'A', 'K', 'CALIPSO z_opaque Temperature', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDOPQ_CAL_Z', horiz_only, 'A', 'm', 'CALIPSO Opaque Cloud Altitude', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL_Z', horiz_only, 'A', 'm', 'CALIPSO Thin Cloud Altitude', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL_EMIS', horiz_only, 'A', '1', 'CALIPSO Thin Cloud Emissivity', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDOPQ_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO Opaque Cloud Altitude with respect to surface-elevation', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDTHN_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO Thin Cloud Altitude with respect to surface-elevation', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-! call addfld('CLDZOPQ_CAL_SE', horiz_only, 'A', 'm', 'CALIPSO z_opaque Altitude with respect to surface-elevation', &
-! flag_xyfill=.true., fill_value=R_UNDEF)
-
- ! add_default calls for CFMIP experiments or else all fields are added to history file
- ! except those with sub-column dimension/experimental variables
- !! add all calipso outputs to the history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('CLDLOW_CAL',cosp_histfile_num,' ')
- call add_default ('CLDMED_CAL',cosp_histfile_num,' ')
- call add_default ('CLDHGH_CAL',cosp_histfile_num,' ')
- call add_default ('CLDTOT_CAL',cosp_histfile_num,' ')
- call add_default ('CLD_CAL',cosp_histfile_num,' ')
- call add_default ('RFL_PARASOL',cosp_histfile_num,' ')
- call add_default ('CFAD_SR532_CAL',cosp_histfile_num,' ')
- call add_default ('CLD_CAL_LIQ',cosp_histfile_num,' ') !+COSP1.4
- call add_default ('CLD_CAL_ICE',cosp_histfile_num,' ')
- call add_default ('CLD_CAL_UN',cosp_histfile_num,' ')
- call add_default ('CLDTOT_CAL_ICE',cosp_histfile_num,' ')
- call add_default ('CLDTOT_CAL_LIQ',cosp_histfile_num,' ')
- call add_default ('CLDTOT_CAL_UN',cosp_histfile_num,' ')
- call add_default ('CLDHGH_CAL_ICE',cosp_histfile_num,' ')
- call add_default ('CLDHGH_CAL_LIQ',cosp_histfile_num,' ')
- call add_default ('CLDHGH_CAL_UN',cosp_histfile_num,' ')
- call add_default ('CLDMED_CAL_ICE',cosp_histfile_num,' ')
- call add_default ('CLDMED_CAL_LIQ',cosp_histfile_num,' ')
- call add_default ('CLDMED_CAL_UN',cosp_histfile_num,' ')
- call add_default ('CLDLOW_CAL_ICE',cosp_histfile_num,' ')
- call add_default ('CLDLOW_CAL_LIQ',cosp_histfile_num,' ')
- call add_default ('CLDLOW_CAL_UN',cosp_histfile_num,' ')
-! call add_default ('CLDOPQ_CAL',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL',cosp_histfile_num,' ')
-! call add_default ('CLDZOPQ_CAL',cosp_histfile_num,' ')
-! call add_default ('CLDOPQ_CAL_2D',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL_2D',cosp_histfile_num,' ')
-! call add_default ('CLDZOPQ_CAL_2D',cosp_histfile_num,' ')
-! call add_default ('OPACITY_CAL_2D',cosp_histfile_num,' ')
-! call add_default ('CLDOPQ_CAL_TMP',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL_TMP',cosp_histfile_num,' ')
-! call add_default ('CLDZOPQ_CAL_TMP',cosp_histfile_num,' ')
-! call add_default ('CLDOPQ_CAL_Z',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL_Z',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL_EMIS',cosp_histfile_num,' ')
-! call add_default ('CLDOPQ_CAL_SE',cosp_histfile_num,' ')
-! call add_default ('CLDTHN_CAL_SE',cosp_histfile_num,' ')
-! call add_default ('CLDZOPQ_CAL_SE',cosp_histfile_num,' ')
+ call addfld('CLDLOW_CAL', horiz_only, 'A', 'percent', &
+ 'Calipso Low-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDMED_CAL', horiz_only, 'A', 'percent', &
+ 'Calipso Mid-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDHGH_CAL', horiz_only, 'A', 'percent', &
+ 'Calipso High-level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CAL', horiz_only, 'A', 'percent', &
+ 'Calipso Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL', (/'cosp_ht'/), 'A', 'percent', &
+ 'Calipso Cloud Fraction (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('RFL_PARASOL', (/'cosp_sza'/), 'A', 'fraction', &
+ 'PARASOL-like mono-directional reflectance ', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CFAD_SR532_CAL', (/'cosp_sr','cosp_ht'/), 'A', 'fraction', &
+ 'Calipso Scattering Ratio CFAD (532 nm)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('MOL532_CAL', (/'trop_pref'/), 'A', 'm-1 sr-1', &
+ 'Calipso Molecular Backscatter (532 nm) ', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('ATB532_CAL', (/'cosp_scol','trop_pref'/), 'I', 'no_unit_log10(x)', &
+ 'Calipso Attenuated Total Backscatter (532 nm) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_LIQ', (/'cosp_ht'/), 'A', 'percent', &
+ 'Calipso Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_ICE', (/'cosp_ht'/), 'A', 'percent', &
+ 'Calipso Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_UN', (/'cosp_ht'/), 'A', 'percent', &
+ 'Calipso Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_TMP', (/'cosp_ht'/), 'A', 'K', &
+ 'Calipso Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_TMPLIQ', (/'cosp_ht'/), 'A', 'K', &
+ 'Calipso Liquid Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_TMPICE', (/'cosp_ht'/), 'A', 'K', &
+ 'Calipso Ice Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_TMPUN', (/'cosp_ht'/), 'A', 'K', &
+ 'Calipso Undefined-Phase Cloud Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CAL_ICE', horiz_only, 'A', 'percent', &
+ 'Calipso Total Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CAL_LIQ', horiz_only, 'A', 'percent', &
+ 'Calipso Total Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CAL_UN', horiz_only, 'A', 'percent', &
+ 'Calipso Total Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDHGH_CAL_ICE', horiz_only, 'A', 'percent', &
+ 'Calipso High-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDHGH_CAL_LIQ', horiz_only, 'A', 'percent', &
+ 'Calipso High-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDHGH_CAL_UN', horiz_only, 'A', 'percent', &
+ 'Calipso High-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDMED_CAL_ICE', horiz_only, 'A', 'percent', &
+ 'Calipso Mid-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDMED_CAL_LIQ', horiz_only, 'A', 'percent', &
+ 'Calipso Mid-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDMED_CAL_UN', horiz_only, 'A', 'percent', &
+ 'Calipso Mid-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDLOW_CAL_ICE', horiz_only, 'A', 'percent', &
+ 'Calipso Low-level Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDLOW_CAL_LIQ', horiz_only, 'A', 'percent', &
+ 'Calipso Low-level Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDLOW_CAL_UN', horiz_only, 'A', 'percent', &
+ 'Calipso Low-level Undefined-Phase Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('CLDLOW_CAL',cosp_histfile_num,' ')
+ call add_default('CLDMED_CAL',cosp_histfile_num,' ')
+ call add_default('CLDHGH_CAL',cosp_histfile_num,' ')
+ call add_default('CLDTOT_CAL',cosp_histfile_num,' ')
+ call add_default('CLD_CAL',cosp_histfile_num,' ')
+ call add_default('RFL_PARASOL',cosp_histfile_num,' ')
+ call add_default('CFAD_SR532_CAL',cosp_histfile_num,' ')
+ call add_default('CLD_CAL_LIQ',cosp_histfile_num,' ')
+ call add_default('CLD_CAL_ICE',cosp_histfile_num,' ')
+ call add_default('CLD_CAL_UN',cosp_histfile_num,' ')
+ call add_default('CLDTOT_CAL_ICE',cosp_histfile_num,' ')
+ call add_default('CLDTOT_CAL_LIQ',cosp_histfile_num,' ')
+ call add_default('CLDTOT_CAL_UN',cosp_histfile_num,' ')
+ call add_default('CLDHGH_CAL_ICE',cosp_histfile_num,' ')
+ call add_default('CLDHGH_CAL_LIQ',cosp_histfile_num,' ')
+ call add_default('CLDHGH_CAL_UN',cosp_histfile_num,' ')
+ call add_default('CLDMED_CAL_ICE',cosp_histfile_num,' ')
+ call add_default('CLDMED_CAL_LIQ',cosp_histfile_num,' ')
+ call add_default('CLDMED_CAL_UN',cosp_histfile_num,' ')
+ call add_default('CLDLOW_CAL_ICE',cosp_histfile_num,' ')
+ call add_default('CLDLOW_CAL_LIQ',cosp_histfile_num,' ')
+ call add_default('CLDLOW_CAL_UN',cosp_histfile_num,' ')
if ((.not.cosp_amwg) .and. (.not.cosp_lite) .and. (.not.cosp_passive) .and. (.not.cosp_active) &
.and. (.not.cosp_isccp)) then
- call add_default ('MOL532_CAL',cosp_histfile_num,' ')
+ call add_default('MOL532_CAL',cosp_histfile_num,' ')
end if
end if
! RADAR SIMULATOR OUTPUTS
+ allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk), stat=istat)
+ call handle_allocate_error(istat, sub, 'sd_cs,rcfg_cs')
if (lradar_sim) then
- allocate(sd_cs(begchunk:endchunk), rcfg_cs(begchunk:endchunk))
do i = begchunk, endchunk
sd_cs(i) = sd
rcfg_cs(i) = rcfg_cloudsat
end do
- ! addfld calls
- !*cfOff,cf3hr* cfad_dbze94 (time,height,dbze,profile), default is 40 vert levs, 15 dBZ bins
- call addfld('CFAD_DBZE94_CS',(/'cosp_dbze','cosp_ht '/),'A','fraction',&
- 'Radar Reflectivity Factor CFAD (94 GHz)',&
- flag_xyfill=.true., fill_value=R_UNDEF)
- !*cfOff,cf3hr* clcalipso2 (time,height,profile)
- call addfld ('CLD_CAL_NOTCS',(/'cosp_ht'/),'A','percent','Cloud occurrence seen by CALIPSO but not CloudSat ', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! cltcalipsoradar (time,profile)
- call addfld ('CLDTOT_CALCS',horiz_only,'A','percent',' Calipso and Radar Total Cloud Fraction ',flag_xyfill=.true., &
- fill_value=R_UNDEF)
- call addfld ('CLDTOT_CS',horiz_only,'A','percent',' Radar total cloud amount ',flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CLDTOT_CS2',horiz_only,'A','percent', &
- ' Radar total cloud amount without the data for the first kilometer above surface ', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! dbze94 (time,height_mlev,column,profile),! height_mlevel = height when vgrid_in = .true. (default)
- call addfld ('DBZE_CS',(/'cosp_scol','lev '/),'I','dBZe',' Radar dBZe (94 GHz) in each Subcolumn',&
+ call addfld('CFAD_DBZE94_CS',(/'cosp_dbze','cosp_ht '/), 'A', 'fraction', &
+ 'Radar Reflectivity Factor CFAD (94 GHz)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLD_CAL_NOTCS', (/'cosp_ht'/), 'A', 'percent', &
+ 'Cloud occurrence seen by CALIPSO but not CloudSat ', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CALCS', horiz_only, 'A', 'percent', &
+ 'Calipso and Radar Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CS', horiz_only, 'A', 'percent', &
+ 'Radar total cloud amount', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLDTOT_CS2', horiz_only, 'A', 'percent', &
+ 'Radar total cloud amount without the data for the first kilometer above surface ', &
flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('DBZE_CS', (/'cosp_scol','trop_pref'/), 'I', 'dBZe', &
+ 'Radar dBZe (94 GHz) in each Subcolumn', flag_xyfill=.true., fill_value=R_UNDEF)
! Cloudsat near-sfc precipitation diagnostics
- call addfld('CS_NOPRECIP', horiz_only, 'A', '1', 'CloudSat No Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_RAINPOSS', horiz_only, 'A', '1', 'Cloudsat Rain Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_RAINPROB', horiz_only, 'A', '1', 'CloudSat Rain Probable Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_RAINCERT', horiz_only, 'A', '1', 'CloudSat Rain Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_SNOWPOSS', horiz_only, 'A', '1', 'CloudSat Snow Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_SNOWCERT', horiz_only, 'A', '1', 'CloudSat Snow Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_MIXPOSS', horiz_only, 'A', '1', 'CloudSat Mixed Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_MIXCERT', horiz_only, 'A', '1', 'CloudSat Mixed Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_RAINHARD', horiz_only, 'A', '1', 'CloudSat Heavy Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_UN', horiz_only, 'A', '1', 'CloudSat Unclassified Precipitation Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld('CS_PIA', horiz_only, 'A', 'dBZ', 'CloudSat Radar Path Integrated Attenuation', flag_xyfill=.true., fill_value=R_UNDEF)
- ! Associated CAM microphysics
- !call addfld('CAM_MP_CVRAIN',horiz_only, 'A', 'kg/kg','CAM Microphysics Convective Rain', flag_xyfill=.true., fill_value=R_UNDEF)
- !call addfld('CAM_MP_CVSNOW',horiz_only, 'A', 'kg/kg','CAM Microphysics Convective Snow', flag_xyfill=.true., fill_value=R_UNDEF)
- !call addfld('CAM_MP_LSRAIN',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Rain', flag_xyfill=.true., fill_value=R_UNDEF)
- !call addfld('CAM_MP_LSSNOW',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Snow', flag_xyfill=.true., fill_value=R_UNDEF)
- !call addfld('CAM_MP_LSGRPL',horiz_only, 'A', 'kg/kg','CAM Microphysics Large-Scale Graupel', flag_xyfill=.true., fill_value=R_UNDEF)
-
-
- ! add_default calls for CFMIP experiments or else all fields are added to history file except those with sub-column dimension
- !! add all radar outputs to the history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('CFAD_DBZE94_CS',cosp_histfile_num,' ')
- call add_default ('CLD_CAL_NOTCS', cosp_histfile_num,' ')
- call add_default ('CLDTOT_CALCS', cosp_histfile_num,' ')
- call add_default ('CLDTOT_CS', cosp_histfile_num,' ')
- call add_default ('CLDTOT_CS2', cosp_histfile_num,' ')
- call add_default ('CS_NOPRECIP', cosp_histfile_num,' ')
- call add_default ('CS_RAINPOSS', cosp_histfile_num,' ')
- call add_default ('CS_RAINPROB', cosp_histfile_num,' ')
- call add_default ('CS_RAINCERT', cosp_histfile_num,' ')
- call add_default ('CS_SNOWPOSS', cosp_histfile_num,' ')
- call add_default ('CS_SNOWCERT', cosp_histfile_num,' ')
- call add_default ('CS_MIXPOSS', cosp_histfile_num,' ')
- call add_default ('CS_MIXCERT', cosp_histfile_num,' ')
- call add_default ('CS_RAINHARD', cosp_histfile_num,' ')
- call add_default ('CS_UN', cosp_histfile_num,' ')
- call add_default ('CS_PIA', cosp_histfile_num,' ')
+ call addfld('CS_NOPRECIP', horiz_only, 'A', '1', &
+ 'CloudSat No Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_RAINPOSS', horiz_only, 'A', '1', &
+ 'Cloudsat Rain Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_RAINPROB', horiz_only, 'A', '1', &
+ 'CloudSat Rain Probable Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_RAINCERT', horiz_only, 'A', '1', &
+ 'CloudSat Rain Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_SNOWPOSS', horiz_only, 'A', '1', &
+ 'CloudSat Snow Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_SNOWCERT', horiz_only, 'A', '1', &
+ 'CloudSat Snow Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_MIXPOSS', horiz_only, 'A', '1', &
+ 'CloudSat Mixed Possible Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_MIXCERT', horiz_only, 'A', '1', &
+ 'CloudSat Mixed Certain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_RAINHARD', horiz_only, 'A', '1', &
+ 'CloudSat Heavy Rain Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_UN', horiz_only, 'A', '1', &
+ 'CloudSat Unclassified Precipitation Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CS_PIA', horiz_only, 'A', 'dBZ', &
+ 'CloudSat Radar Path Integrated Attenuation', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('CFAD_DBZE94_CS',cosp_histfile_num,' ')
+ call add_default('CLD_CAL_NOTCS', cosp_histfile_num,' ')
+ call add_default('CLDTOT_CALCS', cosp_histfile_num,' ')
+ call add_default('CLDTOT_CS', cosp_histfile_num,' ')
+ call add_default('CLDTOT_CS2', cosp_histfile_num,' ')
+ call add_default('CS_NOPRECIP', cosp_histfile_num,' ')
+ call add_default('CS_RAINPOSS', cosp_histfile_num,' ')
+ call add_default('CS_RAINPROB', cosp_histfile_num,' ')
+ call add_default('CS_RAINCERT', cosp_histfile_num,' ')
+ call add_default('CS_SNOWPOSS', cosp_histfile_num,' ')
+ call add_default('CS_SNOWCERT', cosp_histfile_num,' ')
+ call add_default('CS_MIXPOSS', cosp_histfile_num,' ')
+ call add_default('CS_MIXCERT', cosp_histfile_num,' ')
+ call add_default('CS_RAINHARD', cosp_histfile_num,' ')
+ call add_default('CS_UN', cosp_histfile_num,' ')
+ call add_default('CS_PIA', cosp_histfile_num,' ')
end if
! MISR SIMULATOR OUTPUTS
if (lmisr_sim) then
- ! clMISR (time,tau,CTH_height_bin,profile)
- call addfld ('CLD_MISR',(/'cosp_tau ','cosp_htmisr'/),'A','percent','Cloud Fraction from MISR Simulator', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- !! add all misr outputs to the history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('CLD_MISR',cosp_histfile_num,' ')
+ call addfld('CLD_MISR', (/'cosp_tau ','cosp_htmisr'/), 'A', 'percent', &
+ 'Cloud Fraction from MISR Simulator', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('CLD_MISR',cosp_histfile_num,' ')
end if
! MODIS OUTPUT
if (lmodis_sim) then
- ! float cltmodis ( time, loc )
- call addfld ('CLTMODIS',horiz_only,'A','%','MODIS Total Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clwmodis ( time, loc )
- call addfld ('CLWMODIS',horiz_only,'A','%','MODIS Liquid Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float climodis ( time, loc )
- call addfld ('CLIMODIS',horiz_only,'A','%','MODIS Ice Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clhmodis ( time, loc )
- call addfld ('CLHMODIS',horiz_only,'A','%','MODIS High Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clmmodis ( time, loc )
- call addfld ('CLMMODIS',horiz_only,'A','%','MODIS Mid Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float cllmodis ( time, loc )
- call addfld ('CLLMODIS',horiz_only,'A','%','MODIS Low Level Cloud Fraction',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tautmodis ( time, loc )
- call addfld ('TAUTMODIS',horiz_only,'A','1','MODIS Total Cloud Optical Thickness*CLTMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tauwmodis ( time, loc )
- call addfld ('TAUWMODIS',horiz_only,'A','1','MODIS Liquid Cloud Optical Thickness*CLWMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tauimodis ( time, loc )
- call addfld ('TAUIMODIS',horiz_only,'A','1','MODIS Ice Cloud Optical Thickness*CLIMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tautlogmodis ( time, loc )
- call addfld ('TAUTLOGMODIS',horiz_only,'A','1','MODIS Total Cloud Optical Thickness (Log10 Mean)*CLTMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tauwlogmodis ( time, loc )
- call addfld ('TAUWLOGMODIS',horiz_only,'A','1','MODIS Liquid Cloud Optical Thickness (Log10 Mean)*CLWMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float tauilogmodis ( time, loc )
- call addfld ('TAUILOGMODIS',horiz_only,'A','1','MODIS Ice Cloud Optical Thickness (Log10 Mean)*CLIMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float reffclwmodis ( time, loc )
- call addfld ('REFFCLWMODIS',horiz_only,'A','m','MODIS Liquid Cloud Particle Size*CLWMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float reffclimodis ( time, loc )
- call addfld ('REFFCLIMODIS',horiz_only,'A','m','MODIS Ice Cloud Particle Size*CLIMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float pctmodis ( time, loc )
- call addfld ('PCTMODIS',horiz_only,'A','Pa','MODIS Cloud Top Pressure*CLTMODIS',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float lwpmodis ( time, loc )
- call addfld ('LWPMODIS',horiz_only,'A','kg m-2','MODIS Cloud Liquid Water Path*CLWMODIS', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float iwpmodis ( time, loc )
- call addfld ('IWPMODIS',horiz_only,'A','kg m-2','MODIS Cloud Ice Water Path*CLIMODIS',flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clmodis ( time, plev, tau, loc )
- call addfld ('CLMODIS',(/'cosp_tau_modis','cosp_prs '/),'A','%','MODIS Cloud Area Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clrimodis ( time, plev, tau, loc )
- call addfld ('CLRIMODIS',(/'cosp_tau_modis','cosp_reffice '/),'A','%','MODIS Cloud Area Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- ! float clrlmodis ( time, plev, tau, loc )
- call addfld ('CLRLMODIS',(/'cosp_tau_modis','cosp_reffliq '/),'A','%','MODIS Cloud Area Fraction', &
- flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLTMODIS', horiz_only, 'A', '%', &
+ 'MODIS Total Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLWMODIS', horiz_only, 'A', '%', &
+ 'MODIS Liquid Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLIMODIS', horiz_only, 'A', '%', &
+ 'MODIS Ice Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLHMODIS', horiz_only, 'A', '%', &
+ 'MODIS High Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLMMODIS', horiz_only, 'A', '%', &
+ 'MODIS Mid Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLLMODIS', horiz_only, 'A', '%', &
+ 'MODIS Low Level Cloud Fraction', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUTMODIS', horiz_only, 'A', '1', &
+ 'MODIS Total Cloud Optical Thickness*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUWMODIS', horiz_only, 'A', '1', &
+ 'MODIS Liquid Cloud Optical Thickness*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUIMODIS', horiz_only, 'A', '1', &
+ 'MODIS Ice Cloud Optical Thickness*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUTLOGMODIS', horiz_only, 'A', '1', &
+ 'MODIS Total Cloud Optical Thickness (Log10 Mean)*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUWLOGMODIS', horiz_only, 'A', '1', &
+ 'MODIS Liquid Cloud Optical Thickness (Log10 Mean)*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('TAUILOGMODIS', horiz_only, 'A', '1', &
+ 'MODIS Ice Cloud Optical Thickness (Log10 Mean)*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('REFFCLWMODIS', horiz_only, 'A', 'm', &
+ 'MODIS Liquid Cloud Particle Size*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('REFFCLIMODIS', horiz_only, 'A', 'm', &
+ 'MODIS Ice Cloud Particle Size*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('PCTMODIS', horiz_only, 'A', 'Pa', &
+ 'MODIS Cloud Top Pressure*CLTMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('LWPMODIS', horiz_only, 'A', 'kg m-2', &
+ 'MODIS Cloud Liquid Water Path*CLWMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('IWPMODIS', horiz_only, 'A', 'kg m-2', &
+ 'MODIS Cloud Ice Water Path*CLIMODIS', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLMODIS', (/'cosp_tau_modis','cosp_prs '/), 'A', '%', &
+ 'MODIS Cloud Area Fraction (tau-pressure histogram)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLRIMODIS', (/'cosp_tau_modis','cosp_reffice '/), 'A', '%', &
+ 'MODIS Cloud Area Fraction (tau-reffice histogram)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld('CLRLMODIS', (/'cosp_tau_modis','cosp_reffliq '/), 'A', '%', &
+ 'MODIS Cloud Area Fraction (tau-reffliq histogram)', flag_xyfill=.true., fill_value=R_UNDEF)
- !! add MODIS output to history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('CLTMODIS',cosp_histfile_num,' ')
- call add_default ('CLWMODIS',cosp_histfile_num,' ')
- call add_default ('CLIMODIS',cosp_histfile_num,' ')
- call add_default ('CLHMODIS',cosp_histfile_num,' ')
- call add_default ('CLMMODIS',cosp_histfile_num,' ')
- call add_default ('CLLMODIS',cosp_histfile_num,' ')
- call add_default ('TAUTMODIS',cosp_histfile_num,' ')
- call add_default ('TAUWMODIS',cosp_histfile_num,' ')
- call add_default ('TAUIMODIS',cosp_histfile_num,' ')
- call add_default ('TAUTLOGMODIS',cosp_histfile_num,' ')
- call add_default ('TAUWLOGMODIS',cosp_histfile_num,' ')
- call add_default ('TAUILOGMODIS',cosp_histfile_num,' ')
- call add_default ('REFFCLWMODIS',cosp_histfile_num,' ')
- call add_default ('REFFCLIMODIS',cosp_histfile_num,' ')
- call add_default ('PCTMODIS',cosp_histfile_num,' ')
- call add_default ('LWPMODIS',cosp_histfile_num,' ')
- call add_default ('IWPMODIS',cosp_histfile_num,' ')
- call add_default ('CLMODIS',cosp_histfile_num,' ')
- call add_default ('CLRIMODIS',cosp_histfile_num,' ')
- call add_default ('CLRLMODIS',cosp_histfile_num,' ')
+ call add_default('CLTMODIS',cosp_histfile_num,' ')
+ call add_default('CLWMODIS',cosp_histfile_num,' ')
+ call add_default('CLIMODIS',cosp_histfile_num,' ')
+ call add_default('CLHMODIS',cosp_histfile_num,' ')
+ call add_default('CLMMODIS',cosp_histfile_num,' ')
+ call add_default('CLLMODIS',cosp_histfile_num,' ')
+ call add_default('TAUTMODIS',cosp_histfile_num,' ')
+ call add_default('TAUWMODIS',cosp_histfile_num,' ')
+ call add_default('TAUIMODIS',cosp_histfile_num,' ')
+ call add_default('TAUTLOGMODIS',cosp_histfile_num,' ')
+ call add_default('TAUWLOGMODIS',cosp_histfile_num,' ')
+ call add_default('TAUILOGMODIS',cosp_histfile_num,' ')
+ call add_default('REFFCLWMODIS',cosp_histfile_num,' ')
+ call add_default('REFFCLIMODIS',cosp_histfile_num,' ')
+ call add_default('PCTMODIS',cosp_histfile_num,' ')
+ call add_default('LWPMODIS',cosp_histfile_num,' ')
+ call add_default('IWPMODIS',cosp_histfile_num,' ')
+ call add_default('CLMODIS',cosp_histfile_num,' ')
+ call add_default('CLRIMODIS',cosp_histfile_num,' ')
+ call add_default('CLRLMODIS',cosp_histfile_num,' ')
end if
! SUB-COLUMN OUTPUT
if (lfrac_out) then
- ! frac_out (time,height_mlev,column,profile)
- call addfld ('SCOPS_OUT',(/'cosp_scol','lev '/),'I','0=nocld,1=strcld,2=cnvcld','SCOPS Subcolumn output', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- !! add scops ouptut to history file specified by the CAM namelist variable cosp_histfile_num
- call add_default ('SCOPS_OUT',cosp_histfile_num,' ')
- ! save sub-column outputs from ISCCP if ISCCP is run
+ call addfld('SCOPS_OUT', (/'cosp_scol','trop_pref'/), 'I', '0=nocld,1=strcld,2=cnvcld', &
+ 'SCOPS Subcolumn output', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('SCOPS_OUT',cosp_histfile_num,' ')
+
if (lisccp_sim) then
- call add_default ('TAU_ISCCP',cosp_histfile_num,' ')
- call add_default ('CLDPTOP_ISCCP',cosp_histfile_num,' ')
+ call add_default('TAU_ISCCP',cosp_histfile_num,' ')
+ call add_default('CLDPTOP_ISCCP',cosp_histfile_num,' ')
end if
- ! save sub-column outputs from calipso if calipso is run
+
if (llidar_sim) then
- call add_default ('ATB532_CAL',cosp_histfile_num,' ')
+ call add_default('ATB532_CAL',cosp_histfile_num,' ')
end if
- ! save sub-column outputs from radar if radar is run
+
if (lradar_sim) then
- call add_default ('DBZE_CS',cosp_histfile_num,' ')
+ call add_default('DBZE_CS',cosp_histfile_num,' ')
end if
end if
!! ADDFLD, ADD_DEFAULT, OUTFLD CALLS FOR COSP OUTPUTS IF RUNNING COSP OFF-LINE
- !! Note: A suggestion was to add all of the CAM variables needed to add to make it possible to run COSP off-line
- !! These fields are available and can be called from the namelist though. Here, when the cosp_runall mode is invoked
- !! all of the inputs are saved on the cam history file. This is good de-bugging functionality we should maintain.
if (cosp_histfile_aux) then
- call addfld ('PS_COSP', horiz_only, 'I','Pa', 'PS_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('TS_COSP', horiz_only, 'I','K', 'TS_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('P_COSP', (/ 'lev'/), 'I','Pa', 'P_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('PH_COSP', (/ 'lev'/), 'I','Pa', 'PH_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('ZLEV_COSP', (/ 'lev'/), 'I','m', 'ZLEV_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('ZLEV_HALF_COSP', (/ 'lev'/), 'I','m', 'ZLEV_HALF_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('T_COSP', (/ 'lev'/), 'I','K', 'T_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('RH_COSP', (/ 'lev'/), 'I','percent','RH_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('Q_COSP', (/ 'lev'/), 'I','kg/kg', 'Q_COSP', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('TAU_067', (/'cosp_scol','lev '/), 'I','1', 'Subcolumn 0.67micron optical depth', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('EMISS_11', (/'cosp_scol','lev '/), 'I','1', 'Subcolumn 11micron emissivity', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('MODIS_fracliq', (/'cosp_scol','lev '/), 'I','1', 'Fraction of tau from liquid water', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', 'Asymmetry parameter (MODIS)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('MODIS_ssa', (/'cosp_scol','lev '/), 'I','1', 'Single-scattering albedo (MODIS)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_betatot', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_betatot_ice', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_betatot_liq', (/'cosp_scol','lev '/), 'I','1', 'Backscatter coefficient (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_tautot', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_tautot_ice', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CAL_tautot_liq', (/'cosp_scol','lev '/), 'I','1', 'Vertically integrated ptical-depth (CALIPSO)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CS_z_vol', (/'cosp_scol','lev '/), 'I','1', 'Effective reflectivity factor (CLOUDSAT)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CS_kr_vol', (/'cosp_scol','lev '/), 'I','1', 'Attenuation coefficient (hydro) (CLOUDSAT)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
- call addfld ('CS_g_vol', (/'cosp_scol','lev '/), 'I','1', 'Attenuation coefficient (gases) (CLOUDSAT)', &
- flag_xyfill=.true., fill_value=R_UNDEF)
-
- call add_default ('PS_COSP', cosp_histfile_aux_num,' ')
- call add_default ('TS_COSP', cosp_histfile_aux_num,' ')
- call add_default ('P_COSP', cosp_histfile_aux_num,' ')
- call add_default ('PH_COSP', cosp_histfile_aux_num,' ')
- call add_default ('ZLEV_COSP', cosp_histfile_aux_num,' ')
- call add_default ('ZLEV_HALF_COSP', cosp_histfile_aux_num,' ')
- call add_default ('T_COSP', cosp_histfile_aux_num,' ')
- call add_default ('RH_COSP', cosp_histfile_aux_num,' ')
- call add_default ('TAU_067', cosp_histfile_aux_num,' ')
- call add_default ('EMISS_11', cosp_histfile_aux_num,' ')
- call add_default ('MODIS_fracliq', cosp_histfile_aux_num,' ')
- call add_default ('MODIS_asym', cosp_histfile_aux_num,' ')
- call add_default ('MODIS_ssa', cosp_histfile_aux_num,' ')
- call add_default ('CAL_betatot', cosp_histfile_aux_num,' ')
- call add_default ('CAL_betatot_ice', cosp_histfile_aux_num,' ')
- call add_default ('CAL_betatot_liq', cosp_histfile_aux_num,' ')
- call add_default ('CAL_tautot', cosp_histfile_aux_num,' ')
- call add_default ('CAL_tautot_ice', cosp_histfile_aux_num,' ')
- call add_default ('CAL_tautot_liq', cosp_histfile_aux_num,' ')
- call add_default ('CS_z_vol', cosp_histfile_aux_num,' ')
- call add_default ('CS_kr_vol', cosp_histfile_aux_num,' ')
- call add_default ('CS_g_vol', cosp_histfile_aux_num,' ')
+ call addfld ('PS_COSP', horiz_only, 'I','Pa', &
+ 'COSP Surface Pressure', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('TS_COSP', horiz_only, 'I','K', &
+ 'COSP Skin Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('P_COSP', (/ 'trop_pref'/), 'I','Pa', &
+ 'COSP Pressure (layer midpoint)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('PH_COSP', (/ 'trop_prefi'/), 'I','Pa', &
+ 'COSP Pressure (layer interface)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('ZLEV_COSP', (/ 'trop_pref'/), 'I','m', &
+ 'COSP Height (layer midpoint)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('ZLEV_HALF_COSP', (/ 'trop_prefi'/), 'I','m', &
+ 'COSP Height (layer interface)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('T_COSP', (/ 'trop_pref'/), 'I','K', &
+ 'COSP Temperature', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('Q_COSP', (/ 'trop_pref'/), 'I','percent', &
+ 'COSP Specific Humidity', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call addfld ('TAU_067', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Subcolumn 0.67micron optical depth', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('EMISS_11', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Subcolumn 11micron emissivity', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('MODIS_fracliq', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Fraction of tau from liquid water', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('MODIS_asym', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Asymmetry parameter (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('MODIS_ssa', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Single-scattering albedo (MODIS)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('CS_z_vol', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Effective reflectivity factor (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('CS_kr_vol', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Attenuation coefficient (hydro) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF)
+ call addfld ('CS_g_vol', (/'cosp_scol','trop_pref'/), 'I','1', &
+ 'Attenuation coefficient (gases) (CLOUDSAT)', flag_xyfill=.true., fill_value=R_UNDEF)
+
+ call add_default('PS_COSP', cosp_histfile_aux_num,' ')
+ call add_default('TS_COSP', cosp_histfile_aux_num,' ')
+ call add_default('P_COSP', cosp_histfile_aux_num,' ')
+ call add_default('PH_COSP', cosp_histfile_aux_num,' ')
+ call add_default('ZLEV_COSP', cosp_histfile_aux_num,' ')
+ call add_default('ZLEV_HALF_COSP', cosp_histfile_aux_num,' ')
+ call add_default('T_COSP', cosp_histfile_aux_num,' ')
+ call add_default('Q_COSP', cosp_histfile_aux_num,' ')
+ call add_default('TAU_067', cosp_histfile_aux_num,' ')
+ call add_default('EMISS_11', cosp_histfile_aux_num,' ')
+ call add_default('MODIS_fracliq', cosp_histfile_aux_num,' ')
+ call add_default('MODIS_asym', cosp_histfile_aux_num,' ')
+ call add_default('MODIS_ssa', cosp_histfile_aux_num,' ')
+ call add_default('CS_z_vol', cosp_histfile_aux_num,' ')
+ call add_default('CS_kr_vol', cosp_histfile_aux_num,' ')
+ call add_default('CS_g_vol', cosp_histfile_aux_num,' ')
end if
rei_idx = pbuf_get_index('REI')
@@ -1173,31 +881,184 @@ subroutine cospsimulator_intr_init()
lsflxprc_idx = pbuf_get_index('LS_FLXPRC')
lsflxsnw_idx = pbuf_get_index('LS_FLXSNW')
- allocate(first_run_cosp(begchunk:endchunk))
+ allocate(first_run_cosp(begchunk:endchunk), run_cosp(1:pcols,begchunk:endchunk), &
+ stat=istat)
+ call handle_allocate_error(istat, sub, '*run_cosp')
first_run_cosp(begchunk:endchunk)=.true.
- allocate(run_cosp(1:pcols,begchunk:endchunk))
run_cosp(1:pcols,begchunk:endchunk)=.false.
#endif
end subroutine cospsimulator_intr_init
+ ! ######################################################################################
+ ! SUBROUTINE setcosp2values
+ ! ######################################################################################
+#ifdef USE_COSP
+ subroutine setcosp2values()
+ use mod_cosp, only: cosp_init
+ use mod_cosp_config, only: vgrid_zl, vgrid_zu, vgrid_z
+ use mod_quickbeam_optics, only: hydro_class_init, quickbeam_optics_init
+
+ ! Local
+ logical :: ldouble=.false.
+ logical :: lsingle=.true. ! Default is to use single moment
+ integer :: k
+ integer :: istat
+ character(len=*), parameter :: sub = 'setcosp2values'
+ !--------------------------------------------------------------------------------------
+
+ prsmid_cosp = pres_binCenters
+ prslim_cosp = pres_binEdges
+ taumid_cosp = tau_binCenters
+ taulim_cosp = tau_binEdges
+ srmid_cosp = calipso_binCenters
+ srlim_cosp = calipso_binEdges
+ sza_cosp = parasol_sza
+ dbzemid_cosp = cloudsat_binCenters
+ dbzelim_cosp = cloudsat_binEdges
+ htmisrmid_cosp = misr_histHgtCenters
+ htmisrlim_cosp = misr_histHgtEdges
+ taumid_cosp_modis = tau_binCenters
+ taulim_cosp_modis = tau_binEdges
+ reffICE_binCenters_cosp = reffICE_binCenters
+ reffICE_binEdges_cosp = reffICE_binEdges
+ reffLIQ_binCenters_cosp = reffLIQ_binCenters
+ reffLIQ_binEdges_cosp = reffLIQ_binEdges
+
+ ! Initialize the distributional parameters for hydrometeors in radar simulator. In COSPv1.4, this was declared in
+ ! cosp_defs.f.
+ if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then
+ ldouble = .true.
+ lsingle = .false.
+ endif
+ call hydro_class_init(lsingle,ldouble,sd)
+ call quickbeam_optics_init()
+
+ ! DS2017: The setting up of the vertical grid for regridding the CALIPSO and Cloudsat products is
+ ! now done in cosp_init, but these fields are stored in cosp_config.F90.
+ ! Additionally all static fields used by the individual simulators are set up by calls
+ ! to _init functions in cosp_init.
+ ! DS2019: Add logicals, default=.false., for new Lidar simuldators (Earthcare (atlid) and ground-based
+ ! lidar at 532nm)
+ call COSP_INIT(Lisccp_sim, Lmodis_sim, Lmisr_sim, Lradar_sim, Llidar_sim, LgrLidar532, &
+ Latlid, Lparasol_sim, Lrttov_sim, radar_freq, k2, use_gas_abs, do_ray, &
+ isccp_topheight, isccp_topheight_direction, surface_radar, rcfg_cloudsat, &
+ use_vgrid, csat_vgrid, Nlr, nlay, cloudsat_micro_scheme)
+
+ if (use_vgrid) then !! using fixed vertical grid
+ if (csat_vgrid) then
+ nht_cosp = 40
+ else
+ nht_cosp = Nlr
+ endif
+ endif
+
+ ! DJS2017: In COSP2, most of the bin boundaries, centers, and edges are declared in src/cosp_config.F90.
+ ! Above I just assign them accordingly in the USE statement. Other bin bounds needed by CAM
+ ! are calculated here.
+
+ allocate( &
+ htmlmid_cosp(nlay), &
+ htdbze_dbzemid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), &
+ htlim_cosp(2,nht_cosp), &
+ htmid_cosp(nht_cosp), &
+ htlim_cosp_1d(nht_cosp+1), &
+ htdbze_htmid_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), &
+ htsr_htmid_cosp(nht_cosp*nsr_cosp), &
+ htsr_srmid_cosp(nht_cosp*nsr_cosp), &
+ htmlscol_htmlmid_cosp(nlay*nscol_cosp), &
+ htmlscol_scol_cosp(nlay*nscol_cosp), &
+ scol_cosp(nscol_cosp), &
+ htdbze_cosp(nht_cosp*CLOUDSAT_DBZE_BINS), &
+ htsr_cosp(nht_cosp*nsr_cosp), &
+ htmlscol_cosp(nlay*nscol_cosp), stat=istat)
+ call handle_allocate_error(istat, sub, 'htmlmid_cosp,..,htmlscol_cosp')
+
+ ! DJS2017: Just pull from cosp_config
+ if (use_vgrid) then
+ htlim_cosp_1d(1) = vgrid_zu(1)
+ htlim_cosp_1d(2:nht_cosp+1) = vgrid_zl
+ endif
+ htmid_cosp = vgrid_z
+ htlim_cosp(1,:) = vgrid_zu
+ htlim_cosp(2,:) = vgrid_zl
+
+ scol_cosp(:) = (/(k,k=1,nscol_cosp)/)
+
+ ! Just using an index here, model height is a prognostic variable
+ htmlmid_cosp(:) = (/(k,k=1,nlay)/)
+
+ ! assign mixed dimensions an integer index for cam_history.F90
+ do k=1,nprs_cosp*ntau_cosp
+ prstau_cosp(k) = k
+ end do
+ do k=1,nprs_cosp*ntau_cosp_modis
+ prstau_cosp_modis(k) = k
+ end do
+ do k=1,nht_cosp*CLOUDSAT_DBZE_BINS
+ htdbze_cosp(k) = k
+ end do
+ do k=1,nht_cosp*nsr_cosp
+ htsr_cosp(k) = k
+ end do
+ do k=1,nlay*nscol_cosp
+ htmlscol_cosp(k) = k
+ end do
+ do k=1,nhtmisr_cosp*ntau_cosp
+ htmisrtau_cosp(k) = k
+ end do
+
+ ! next, assign collapsed reference vectors for cam_history.F90
+ ! convention for saving output = prs1,tau1 ... prs1,tau7 ; prs2,tau1 ... prs2,tau7 etc.
+ ! actual output is specified in cospsimulator_intr_init.
+ do k=1,nprs_cosp
+ prstau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp)
+ prstau_prsmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=prsmid_cosp(k)
+ prstau_taumid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=taumid_cosp_modis(1:ntau_cosp_modis)
+ prstau_prsmid_cosp_modis(ntau_cosp_modis*(k-1)+1:k*ntau_cosp_modis)=prsmid_cosp(k)
+ enddo
+
+ do k=1,nht_cosp
+ htdbze_dbzemid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=dbzemid_cosp(1:CLOUDSAT_DBZE_BINS)
+ htdbze_htmid_cosp(CLOUDSAT_DBZE_BINS*(k-1)+1:k*CLOUDSAT_DBZE_BINS)=htmid_cosp(k)
+ enddo
+
+ do k=1,nht_cosp
+ htsr_srmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=srmid_cosp(1:nsr_cosp)
+ htsr_htmid_cosp(nsr_cosp*(k-1)+1:k*nsr_cosp)=htmid_cosp(k)
+ enddo
+
+ do k=1,nlay
+ htmlscol_scol_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=scol_cosp(1:nscol_cosp)
+ htmlscol_htmlmid_cosp(nscol_cosp*(k-1)+1:k*nscol_cosp)=htmlmid_cosp(k)
+ enddo
+
+ do k=1,nhtmisr_cosp
+ htmisrtau_taumid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=taumid_cosp(1:ntau_cosp)
+ htmisrtau_htmisrmid_cosp(ntau_cosp*(k-1)+1:k*ntau_cosp)=htmisrmid_cosp(k)
+ enddo
+
+ end subroutine setcosp2values
+#endif
+
! ######################################################################################
! SUBROUTINE cospsimulator_intr_run
! ######################################################################################
- subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,snow_tau_in,snow_emis_in)
+ subroutine cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, &
+ cld_swtau_in, snow_tau_in, snow_emis_in)
+
use physics_types, only: physics_state
use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx
use camsrfexch, only: cam_in_t
use constituents, only: cnst_get_ind
use rad_constituents, only: rad_cnst_get_gas
- use wv_saturation, only: qsat_water
use interpolate_data, only: lininterp_init,lininterp,lininterp_finish,interp_type
- use physconst, only: pi, gravit
+ use physconst, only: pi, inverse_gravit => rga
use cam_history, only: outfld,hist_fld_col_active
use cam_history_support, only: max_fieldname_len
- use cmparray_mod, only: CmpDayNite, ExpDayNite
+
#ifdef USE_COSP
- use mod_cosp_config, only: R_UNDEF,parasol_nrefl, Nlvgrid, vgrid_zl, vgrid_zu
+ use mod_cosp_config, only: R_UNDEF,parasol_nrefl, Nlvgrid
use mod_cosp, only: cosp_simulator
use mod_quickbeam_optics, only: size_distribution
#endif
@@ -1220,69 +1081,20 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
! ######################################################################################
integer :: lchnk ! chunk identifier
integer :: ncol ! number of active atmospheric columns
- integer :: i,k,ip,it,ipt,ih,id,ihd,is,ihs,isc,ihsc,ihm,ihmt,ihml,itim_old,ifld
-
- ! Variables for day/nite and orbital subsetting
- ! Gathered indicies of day and night columns
- ! chunk_column_index = IdxDay(daylight_column_index)
- integer :: Nday ! Number of daylight columns
- integer :: Nno ! Number of columns not using for simulator
- integer, dimension(pcols) :: IdxDay ! Indices of daylight columns
- integer, dimension(pcols) :: IdxNo ! Indices of columns not using for simulator
- real(r8) :: tmp(pcols) ! tempororary variable for array expansion
- real(r8) :: tmp1(pcols,pver) ! tempororary variable for array expansion
- real(r8) :: tmp2(pcols,pver) ! tempororary variable for array expansion
- real(r8) :: lon_cosp_day(pcols) ! tempororary variable for sunlit lons
- real(r8) :: lat_cosp_day(pcols) ! tempororary variable for sunlit lats
- real(r8) :: ptop_day(pcols,pver) ! tempororary variable for sunlit ptop
- real(r8) :: pmid_day(pcols,pver) ! tempororary variable for sunlit pmid
- real(r8) :: ztop_day(pcols,pver) ! tempororary variable for sunlit ztop
- real(r8) :: zmid_day(pcols,pver) ! tempororary variable for sunlit zmid
- real(r8) :: t_day(pcols,pver) ! tempororary variable for sunlit t
- real(r8) :: rh_day(pcols,pver) ! tempororary variable for sunlit rh
- real(r8) :: q_day(pcols,pver) ! tempororary variable for sunlit q
- real(r8) :: concld_day(pcols,pver) ! tempororary variable for sunlit concld
- real(r8) :: cld_day(pcols,pver) ! tempororary variable for sunlit cld
- real(r8) :: ps_day(pcols) ! tempororary variable for sunlit ps
- real(r8) :: ts_day(pcols) ! tempororary variable for sunlit ts
- real(r8) :: landmask_day(pcols) ! tempororary variable for sunlit landmask
- real(r8) :: o3_day(pcols,pver) ! tempororary variable for sunlit o3
- real(r8) :: us_day(pcols) ! tempororary variable for sunlit us
- real(r8) :: vs_day(pcols) ! tempororary variable for sunlit vs
- real(r8) :: mr_lsliq_day(pcols,pver) ! tempororary variable for sunlit mr_lsliq
- real(r8) :: mr_lsice_day(pcols,pver) ! tempororary variable for sunlit mr_lsice
- real(r8) :: mr_ccliq_day(pcols,pver) ! tempororary variable for sunlit mr_ccliq
- real(r8) :: mr_ccice_day(pcols,pver) ! tempororary variable for sunlit mr_ccice
- real(r8) :: rain_ls_interp_day(pcols,pver) ! tempororary variable for sunlit rain_ls_interp
- real(r8) :: snow_ls_interp_day(pcols,pver) ! tempororary variable for sunlit snow_ls_interp
- real(r8) :: grpl_ls_interp_day(pcols,pver) ! tempororary variable for sunlit grpl_ls_interp
- real(r8) :: rain_cv_interp_day(pcols,pver) ! tempororary variable for sunlit rain_cv_interp
- real(r8) :: snow_cv_interp_day(pcols,pver) ! tempororary variable for sunlit snow_cv_interp
- real(r8) :: reff_cosp_day(pcols,pver,nhydro) ! tempororary variable for sunlit reff_cosp(:,:,:)
- real(r8) :: dtau_s_day(pcols,pver) ! tempororary variable for sunlit dtau_s
- real(r8) :: dtau_c_day(pcols,pver) ! tempororary variable for sunlit dtau_c
- real(r8) :: dtau_s_snow_day(pcols,pver) ! tempororary variable for sunlit dtau_s_snow
- real(r8) :: dem_s_day(pcols,pver) ! tempororary variable for sunlit dem_s
- real(r8) :: dem_c_day(pcols,pver) ! tempororary variable for sunlit dem_c
- real(r8) :: dem_s_snow_day(pcols,pver) ! tempororary variable for sunlit dem_s_snow
-
- ! Constants for optical depth calculation (from radcswmx.F90)
- real(r8), parameter :: abarl = 2.817e-02_r8 ! A coefficient for extinction optical depth
- real(r8), parameter :: bbarl = 1.305_r8 ! b coefficient for extinction optical depth
- real(r8), parameter :: abari = 3.448e-03_r8 ! A coefficient for extinction optical depth
- real(r8), parameter :: bbari = 2.431_r8 ! b coefficient for extinction optical depth
- real(r8), parameter :: cldmin = 1.0e-80_r8 ! note: cldmin much less than cldmin from cldnrh
- real(r8), parameter :: cldeps = 0.0_r8
+ integer :: i, k, kk
+ integer :: itim_old
+ integer :: ip, it
+ integer :: ipt
+ integer :: ih, ihd, ihs, ihsc, ihm, ihmt, ihml
+ integer :: isc
+ integer :: is
+ integer :: id
+
+ real(r8), parameter :: rad2deg = 180._r8/pi
! Microphysics variables
- integer, parameter :: ncnstmax=4 ! number of constituents
- character(len=8), dimension(ncnstmax), parameter :: & ! constituent names
- cnst_names = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE'/)
- integer :: ncnst ! number of constituents (can vary)
integer :: ixcldliq ! cloud liquid amount index for state%q
integer :: ixcldice ! cloud ice amount index
- integer :: ixnumliq ! cloud liquid number index
- integer :: ixnumice ! cloud ice water index
! COSP-related local vars
type(cosp_outputs) :: cospOUT ! COSP simulator outputs
@@ -1290,52 +1102,37 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
type(cosp_column_inputs) :: cospstateIN ! COSP model fields needed by simulators
! COSP input variables that depend on CAM
- ! 1) Npoints = number of gridpoints COSP will process (without subsetting, Npoints=ncol)
- ! 2) Nlevels = number of model levels (Nlevels=pver)
- real(r8), parameter :: time = 1.0_r8 ! time ! Time since start of run [days], set to 1 bc running over single CAM timestep
- real(r8), parameter :: time_bnds(2)=(/0.5_r8,1.5_r8/) ! time_bnds ! Time boundaries - new in cosp v1.3, set following cosp_test.f90 line 121
integer :: Npoints ! Number of gridpoints COSP will process
- integer :: Nlevels ! Nlevels
- logical :: use_reff ! True if effective radius to be used by radar simulator
- ! (always used by lidar)
- logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm
real(r8), parameter :: emsfc_lw = 0.99_r8 ! longwave emissivity of surface at 10.5 microns
- ! set value same as in cloudsimulator.F90
! Local vars related to calculations to go from CAM input to COSP input
! cosp convective value includes both deep and shallow convection
- real(r8) :: ptop(pcols,pver) ! top interface pressure (Pa)
- real(r8) :: ztop(pcols,pver) ! top interface height asl (m)
- real(r8) :: pbot(pcols,pver) ! bottom interface pressure (Pa)
- real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m)
- real(r8) :: zmid(pcols,pver) ! middle interface height asl (m)
- real(r8) :: lat_cosp(pcols) ! lat for cosp (degrees_north)
- real(r8) :: lon_cosp(pcols) ! lon for cosp (degrees_east)
- real(r8) :: landmask(pcols) ! landmask (0 or 1)
- real(r8) :: mr_lsliq(pcols,pver) ! mixing_ratio_large_scale_cloud_liquid (kg/kg)
- real(r8) :: mr_lsice(pcols,pver) ! mixing_ratio_large_scale_cloud_ice (kg/kg)
- real(r8) :: mr_ccliq(pcols,pver) ! mixing_ratio_convective_cloud_liquid (kg/kg)
- real(r8) :: mr_ccice(pcols,pver) ! mixing_ratio_convective_cloud_ice (kg/kg)
- real(r8) :: rain_cv(pcols,pverp) ! interface flux_convective_cloud_rain (kg m^-2 s^-1)
- real(r8) :: snow_cv(pcols,pverp) ! interface flux_convective_cloud_snow (kg m^-2 s^-1)
- real(r8) :: rain_cv_interp(pcols,pver) ! midpoint flux_convective_cloud_rain (kg m^-2 s^-1)
- real(r8) :: snow_cv_interp(pcols,pver) ! midpoint flux_convective_cloud_snow (kg m^-2 s^-1)
- real(r8) :: grpl_ls_interp(pcols,pver) ! midpoint ls grp flux, should be 0
- real(r8) :: rain_ls_interp(pcols,pver) ! midpoint ls rain flux (kg m^-2 s^-1)
- real(r8) :: snow_ls_interp(pcols,pver) ! midpoint ls snow flux
- real(r8) :: reff_cosp(pcols,pver,nhydro) ! effective radius for cosp input
- real(r8) :: rh(pcols,pver) ! relative_humidity_liquid_water (%)
- real(r8) :: es(pcols,pver) ! saturation vapor pressure
- real(r8) :: qs(pcols,pver) ! saturation mixing ratio (kg/kg), saturation specific humidity
- real(r8) :: cld_swtau(pcols,pver) ! incloud sw tau for input to COSP
- real(r8) :: dtau_s(pcols,pver) ! dtau_s - Optical depth of stratiform cloud at 0.67 um
- real(r8) :: dtau_c(pcols,pver) ! dtau_c - Optical depth of convective cloud at 0.67 um
- real(r8) :: dtau_s_snow(pcols,pver) ! dtau_s_snow - Grid-box mean Optical depth of stratiform snow at 0.67 um
- real(r8) :: dem_s(pcols,pver) ! dem_s - Longwave emis of stratiform cloud at 10.5 um
- real(r8) :: dem_c(pcols,pver) ! dem_c - Longwave emis of convective cloud at 10.5 um
- real(r8) :: dem_s_snow(pcols,pver) ! dem_s_snow - Grid-box mean Optical depth of stratiform snow at 10.5 um
- integer :: cam_sunlit(pcols) ! cam_sunlit - Sunlit flag(1-sunlit/0-dark).
- integer :: nSunLit,nNoSunLit ! Number of sunlit (not sunlit) scenes.
+ real(r8), allocatable :: &
+ zmid(:,:), & ! layer midpoint height asl (m)
+ zint(:,:), & ! layer interface height asl (m)
+ surf_hgt(:), & ! surface height (m)
+ landmask(:), & ! landmask (0 or 1)
+ mr_ccliq(:,:), & ! mixing_ratio_convective_cloud_liquid (kg/kg)
+ mr_ccice(:,:), & ! mixing_ratio_convective_cloud_ice (kg/kg)
+ mr_lsliq(:,:), & ! mixing_ratio_large_scale_cloud_liquid (kg/kg)
+ mr_lsice(:,:), & ! mixing_ratio_large_scale_cloud_ice (kg/kg)
+ rain_cv(:,:), & ! interface flux_convective_cloud_rain (kg m^-2 s^-1)
+ snow_cv(:,:), & ! interface flux_convective_cloud_snow (kg m^-2 s^-1)
+ rain_cv_interp(:,:), & ! midpoint flux_convective_cloud_rain (kg m^-2 s^-1)
+ snow_cv_interp(:,:), & ! midpoint flux_convective_cloud_snow (kg m^-2 s^-1)
+ rain_ls_interp(:,:), & ! midpoint ls rain flux (kg m^-2 s^-1)
+ snow_ls_interp(:,:), & ! midpoint ls snow flux
+ grpl_ls_interp(:,:), & ! midpoint ls grp flux, set to 0
+ reff_cosp(:,:,:), & ! effective radius for cosp input
+ dtau_s(:,:), & ! Optical depth of stratiform cloud at 0.67 um
+ dtau_c(:,:), & ! Optical depth of convective cloud at 0.67 um
+ dtau_s_snow(:,:), & ! Grid-box mean Optical depth of stratiform snow at 0.67 um
+ dem_s(:,:), & ! Longwave emis of stratiform cloud at 10.5 um
+ dem_c(:,:), & ! Longwave emis of convective cloud at 10.5 um
+ dem_s_snow(:,:) ! Grid-box mean Optical depth of stratiform snow at 10.5 um
+
+ integer :: cam_sunlit(pcols) ! cam_sunlit - Sunlit flag(1-sunlit/0-dark).
+ integer :: nSunLit ! Number of sunlit (not sunlit) scenes.
! ######################################################################################
! Simulator output info
@@ -1353,9 +1150,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
'CS_NOPRECIP ', 'CS_RAINPOSS ', 'CS_RAINPROB ', &
'CS_RAINCERT ', 'CS_SNOWPOSS ', 'CS_SNOWCERT ', &
'CS_MIXPOSS ', 'CS_MIXCERT ', 'CS_RAINHARD ', &
- 'CS_UN ', 'CS_PIA '/)!, 'CAM_MP_CVRAIN ', &
- !'CAM_MP_CVSNOW ', 'CAM_MP_LSRAIN ', 'CAM_MP_LSSNOW ', &
- !'CAM_MP_LSGRPL '/)
+ 'CS_UN ', 'CS_PIA '/)
! CALIPSO outputs
character(len=max_fieldname_len),dimension(nf_calipso),parameter :: &
@@ -1364,11 +1159,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
'CLD_CAL_ICE ','CLD_CAL_UN ','CLD_CAL_TMP ','CLD_CAL_TMPLIQ ','CLD_CAL_TMPICE ',&
'CLD_CAL_TMPUN ','CLDTOT_CAL_ICE ','CLDTOT_CAL_LIQ ','CLDTOT_CAL_UN ','CLDHGH_CAL_ICE ',&
'CLDHGH_CAL_LIQ ','CLDHGH_CAL_UN ','CLDMED_CAL_ICE ','CLDMED_CAL_LIQ ','CLDMED_CAL_UN ',&
- 'CLDLOW_CAL_ICE ','CLDLOW_CAL_LIQ ','CLDLOW_CAL_UN '/)!, &
-! 'CLDOPQ_CAL ','CLDTHN_CAL ','CLDZOPQ_CAL ','CLDOPQ_CAL_2D ','CLDTHN_CAL_2D ',&
-! 'CLDZOPQ_CAL_2D ','OPACITY_CAL_2D ','CLDOPQ_CAL_TMP ','CLDTHN_CAL_TMP ','CLDZOPQ_CAL_TMP',&
-! 'CLDOPQ_CAL_Z ','CLDTHN_CAL_Z ','CLDTHN_CAL_EMIS','CLDOPQ_CAL_SE ','CLDTHN_CAL_SE ',&
-! 'CLDZOPQ_CAL_SE' /)
+ 'CLDLOW_CAL_ICE ','CLDLOW_CAL_LIQ ','CLDLOW_CAL_UN '/)
! ISCCP outputs
character(len=max_fieldname_len),dimension(nf_isccp),parameter :: &
fname_isccp=(/'FISCCP1_COSP ','CLDTOT_ISCCP ','MEANCLDALB_ISCCP',&
@@ -1386,7 +1177,7 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
'CLRLMODIS '/)
logical :: run_radar(nf_radar,pcols) ! logical telling you if you should run radar simulator
- logical :: run_calipso(nf_calipso,pcols) ! logical telling you if you should run calipso simulator
+ logical :: run_calipso(nf_calipso,pcols) ! logical telling you if you should run calipso simulator
logical :: run_isccp(nf_isccp,pcols) ! logical telling you if you should run isccp simulator
logical :: run_misr(nf_misr,pcols) ! logical telling you if you should run misr simulator
logical :: run_modis(nf_modis,pcols) ! logical telling you if you should run modis simulator
@@ -1394,9 +1185,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
! CAM pointers to get variables from radiation interface (get from rad_cnst_get_gas)
real(r8), pointer, dimension(:,:) :: q ! specific humidity (kg/kg)
real(r8), pointer, dimension(:,:) :: o3 ! Mass mixing ratio 03
- real(r8), pointer, dimension(:,:) :: co2 ! Mass mixing ratio C02
- real(r8), pointer, dimension(:,:) :: ch4 ! Mass mixing ratio CH4
- real(r8), pointer, dimension(:,:) :: n2o ! Mass mixing ratio N20
! CAM pointers to get variables from the physics buffer
real(r8), pointer, dimension(:,:) :: cld ! cloud fraction, tca - total_cloud_amount (0-1)
@@ -1408,103 +1196,70 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
real(r8), pointer, dimension(:,:) :: cv_reffliq ! convective cld liq effective drop radius (microns)
real(r8), pointer, dimension(:,:) :: cv_reffice ! convective cld ice effective drop size (microns)
- !! precip flux pointers (use for cam4 or cam5)
+ !! precip flux pointers
real(r8), target, dimension(pcols,pverp) :: zero_ifc ! zero array for interface fields not in the pbuf
- ! Added pointers; pbuff in zm_conv_intr.F90, calc in zm_conv.F90
real(r8), pointer, dimension(:,:) :: dp_flxprc ! deep interface gbm flux_convective_cloud_rain+snow (kg m^-2 s^-1)
real(r8), pointer, dimension(:,:) :: dp_flxsnw ! deep interface gbm flux_convective_cloud_snow (kg m^-2 s^-1)
- ! More pointers; pbuf in convect_shallow.F90, calc in hk_conv.F90/convect_shallow.F90 (CAM4), uwshcu.F90 (CAM5)
real(r8), pointer, dimension(:,:) :: sh_flxprc ! shallow interface gbm flux_convective_cloud_rain+snow (kg m^-2 s^-1)
real(r8), pointer, dimension(:,:) :: sh_flxsnw ! shallow interface gbm flux_convective_cloud_snow (kg m^-2 s^-1)
- ! More pointers; pbuf in stratiform.F90, getting from pbuf here
- ! a) added as output to pcond subroutine in cldwat.F90 and to nmicro_pcond subroutine in cldwat2m_micro.F90
real(r8), pointer, dimension(:,:) :: ls_flxprc ! stratiform interface gbm flux_cloud_rain+snow (kg m^-2 s^-1)
real(r8), pointer, dimension(:,:) :: ls_flxsnw ! stratiform interface gbm flux_cloud_snow (kg m^-2 s^-1)
!! cloud mixing ratio pointers (note: large-scale in state)
- ! More pointers; pbuf in convect_shallow.F90 (cam4) or stratiform.F90 (cam5)
- ! calc in hk_conv.F90 (CAM4 should be 0!), uwshcu.F90 but then affected by micro so values from stratiform.F90 (CAM5)
real(r8), pointer, dimension(:,:) :: sh_cldliq ! shallow gbm cloud liquid water (kg/kg)
real(r8), pointer, dimension(:,:) :: sh_cldice ! shallow gbm cloud ice water (kg/kg)
- ! More pointers; pbuf in zm_conv_intr.F90, calc in zm_conv.F90, 0 for CAM4 and CAM5 (same convection scheme)
real(r8), pointer, dimension(:,:) :: dp_cldliq ! deep gbm cloud liquid water (kg/kg)
real(r8), pointer, dimension(:,:) :: dp_cldice ! deep gmb cloud ice water (kg/kg)
! Output CAM variables
- ! Notes:
- ! 1) use pcols (maximum number of columns that code could use, maybe 16)
- ! pcols vs. ncol. ncol is the number of columns a chunk is actually using, pcols is maximum number
- ! 2) Mixed variables rules/notes, need to collapse because CAM history does not support increased dimensionality
- ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nhtml_cosp, ntau_cosp*nhtmisr_cosp
- ! a) always making mixed variables VERTICAL*OTHER, e.g., pressure*tau or ht*dbze
- ! b) always collapsing output as V1_1/V2_1...V1_1/V2_N ; V1_2/V2_1 ...V1_2/V2_N etc. to V1_N/V2_1 ... V1_N/V2_N
- ! c) here, need vars for both multi-dimensional output from COSP, and two-dimensional output from CAM
- ! 3) ntime=1, nprofile=ncol
- ! 4) dimensions listed in COSP units are from netcdf output from cosp test case, and are not necessarily in the
- ! correct order. In fact, most of them are not as I discovered after trying to run COSP in-line.
- ! BE says this could be because FORTRAN and C (netcdf defaults to C) have different conventions.
- ! 5) !! Note: after running COSP, it looks like height_mlev is actually the model levels after all!!
- real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp) ! clisccp2 (time,tau,plev,profile)
- real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp) ! cfad_dbze94 (time,height,dbze,profile)
- real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp) ! cfad_lidarsr532 (time,height,scat_ratio,profile)
- real(r8) :: dbze94(pcols,nscol_cosp,nhtml_cosp) ! dbze94 (time,height_mlev,column,profile)
- real(r8) :: atb532(pcols,nscol_cosp,nhtml_cosp) ! atb532 (time,height_mlev,column,profile)
- real(r8) :: clMISR(pcols,ntau_cosp,nhtmisr_cosp) ! clMISR (time,tau,CTH_height_bin,profile)
- real(r8) :: frac_out(pcols,nscol_cosp,nhtml_cosp) ! frac_out (time,height_mlev,column,profile)
- real(r8) :: cldtot_isccp(pcols) ! CAM tclisccp (time,profile)
- real(r8) :: meancldalb_isccp(pcols) ! CAM albisccp (time,profile)
- real(r8) :: meanptop_isccp(pcols) ! CAM ctpisccp (time,profile)
- real(r8) :: cldlow_cal(pcols) ! CAM cllcalipso (time,profile)
- real(r8) :: cldmed_cal(pcols) ! CAM clmcalipso (time,profile)
- real(r8) :: cldhgh_cal(pcols) ! CAM clhcalipso (time,profile)
- real(r8) :: cldtot_cal(pcols) ! CAM cltcalipso (time,profile)
- real(r8) :: cldtot_cal_ice(pcols) ! CAM (time,profile) !!+cosp1.4
- real(r8) :: cldtot_cal_liq(pcols) ! CAM (time,profile)
- real(r8) :: cldtot_cal_un(pcols) ! CAM (time,profile)
- real(r8) :: cldhgh_cal_ice(pcols) ! CAM (time,profile)
- real(r8) :: cldhgh_cal_liq(pcols) ! CAM (time,profile)
- real(r8) :: cldhgh_cal_un(pcols) ! CAM (time,profile)
- real(r8) :: cldmed_cal_ice(pcols) ! CAM (time,profile)
- real(r8) :: cldmed_cal_liq(pcols) ! CAM (time,profile)
- real(r8) :: cldmed_cal_un(pcols) ! CAM (time,profile)
- real(r8) :: cldlow_cal_ice(pcols) ! CAM (time,profile)
- real(r8) :: cldlow_cal_liq(pcols) ! CAM (time,profile)
- real(r8) :: cldlow_cal_un(pcols) ! CAM (time,profile) !+cosp1.4
- real(r8) :: cld_cal(pcols,nht_cosp) ! CAM clcalipso (time,height,profile)
- real(r8) :: cld_cal_liq(pcols,nht_cosp) ! CAM (time,height,profile) !+cosp1.4
- real(r8) :: cld_cal_ice(pcols,nht_cosp) ! CAM (time,height,profile)
- real(r8) :: cld_cal_un(pcols,nht_cosp) ! CAM (time,height,profile)
- real(r8) :: cld_cal_tmp(pcols,nht_cosp) ! CAM (time,height,profile)
- real(r8) :: cld_cal_tmpliq(pcols,nht_cosp) ! CAM (time,height,profile)
- real(r8) :: cld_cal_tmpice(pcols,nht_cosp) ! CAM (time,height,profile)
- real(r8) :: cld_cal_tmpun(pcols,nht_cosp) ! CAM (time,height,profile) !+cosp1.4
-! real(r8) :: cldopaq_cal(pcols)
-! real(r8) :: cldthin_cal(pcols)
-! real(r8) :: cldopaqz_cal(pcols)
-! real(r8) :: cldopaq_cal_temp(pcols)
-! real(r8) :: cldthin_cal_temp(pcols)
-! real(r8) :: cldzopaq_cal_temp(pcols)
-! real(r8) :: cldopaq_cal_z(pcols)
-! real(r8) :: cldthin_cal_z(pcols)
-! real(r8) :: cldthin_cal_emis(pcols)
-! real(r8) :: cldopaq_cal_se(pcols)
-! real(r8) :: cldthin_cal_se(pcols)
-! real(r8) :: cldzopaq_cal_se(pcols)
-! real(r8) :: cldopaq_cal_2d(pcols,nht_cosp)
-! real(r8) :: cldthin_cal_2d(pcols,nht_cosp)
-! real(r8) :: cldzopaq_cal_2d(pcols,nht_cosp)
-! real(r8) :: opacity_cal_2d(pcols,nht_cosp)
- real(r8) :: cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS)! CAM cfad_dbze94 (time,height,dbze,profile)
- real(r8) :: cfad_sr532_cal(pcols,nht_cosp*nsr_cosp) ! CAM cfad_lidarsr532 (time,height,scat_ratio,profile)
- real(r8) :: tau_isccp(pcols,nscol_cosp) ! CAM boxtauisccp (time,column,profile)
- real(r8) :: cldptop_isccp(pcols,nscol_cosp) ! CAM boxptopisccp (time,column,profile)
- real(r8) :: meantau_isccp(pcols) ! CAM tauisccp (time,profile)
- real(r8) :: meantb_isccp(pcols) ! CAM meantbisccp (time,profile)
- real(r8) :: meantbclr_isccp(pcols) ! CAM meantbclrisccp (time,profile)
- real(r8) :: dbze_cs(pcols,nhtml_cosp*nscol_cosp) ! CAM dbze94 (time,height_mlev,column,profile)
- real(r8) :: cldtot_calcs(pcols) ! CAM cltlidarradar (time,profile)
- real(r8) :: cldtot_cs(pcols) ! CAM cltradar (time,profile)
- real(r8) :: cldtot_cs2(pcols) ! CAM cltradar2 (time,profile)
+ ! Multiple "mdims" are collapsed because CAM history buffers only support one mdim.
+ ! MIXED DIMS: ntau_cosp*nprs_cosp, CLOUDSAT_DBZE_BINS*nht_cosp, nsr_cosp*nht_cosp, nscol_cosp*nlay,
+ ! ntau_cosp*nhtmisr_cosp
+ real(r8) :: clisccp2(pcols,ntau_cosp,nprs_cosp)
+ real(r8) :: cfad_dbze94(pcols,CLOUDSAT_DBZE_BINS,nht_cosp)
+ real(r8) :: cfad_lidarsr532(pcols,nsr_cosp,nht_cosp)
+ real(r8) :: dbze94(pcols,nscol_cosp,nlay)
+ real(r8) :: atb532(pcols,nscol_cosp,nlay)
+ real(r8) :: clMISR(pcols,ntau_cosp,nhtmisr_cosp)
+ real(r8) :: frac_out(pcols,nscol_cosp,nlay)
+ real(r8) :: cldtot_isccp(pcols)
+ real(r8) :: meancldalb_isccp(pcols)
+ real(r8) :: meanptop_isccp(pcols)
+ real(r8) :: cldlow_cal(pcols)
+ real(r8) :: cldmed_cal(pcols)
+ real(r8) :: cldhgh_cal(pcols)
+ real(r8) :: cldtot_cal(pcols)
+ real(r8) :: cldtot_cal_ice(pcols)
+ real(r8) :: cldtot_cal_liq(pcols)
+ real(r8) :: cldtot_cal_un(pcols)
+ real(r8) :: cldhgh_cal_ice(pcols)
+ real(r8) :: cldhgh_cal_liq(pcols)
+ real(r8) :: cldhgh_cal_un(pcols)
+ real(r8) :: cldmed_cal_ice(pcols)
+ real(r8) :: cldmed_cal_liq(pcols)
+ real(r8) :: cldmed_cal_un(pcols)
+ real(r8) :: cldlow_cal_ice(pcols)
+ real(r8) :: cldlow_cal_liq(pcols)
+ real(r8) :: cldlow_cal_un(pcols)
+ real(r8) :: cld_cal(pcols,nht_cosp)
+ real(r8) :: cld_cal_liq(pcols,nht_cosp)
+ real(r8) :: cld_cal_ice(pcols,nht_cosp)
+ real(r8) :: cld_cal_un(pcols,nht_cosp)
+ real(r8) :: cld_cal_tmp(pcols,nht_cosp)
+ real(r8) :: cld_cal_tmpliq(pcols,nht_cosp)
+ real(r8) :: cld_cal_tmpice(pcols,nht_cosp)
+ real(r8) :: cld_cal_tmpun(pcols,nht_cosp)
+ real(r8) :: cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS)
+ real(r8) :: cfad_sr532_cal(pcols,nht_cosp*nsr_cosp)
+ real(r8) :: tau_isccp(pcols,nscol_cosp)
+ real(r8) :: cldptop_isccp(pcols,nscol_cosp)
+ real(r8) :: meantau_isccp(pcols)
+ real(r8) :: meantb_isccp(pcols)
+ real(r8) :: meantbclr_isccp(pcols)
+ real(r8) :: dbze_cs(pcols,nlay*nscol_cosp)
+ real(r8) :: cldtot_calcs(pcols)
+ real(r8) :: cldtot_cs(pcols)
+ real(r8) :: cldtot_cs2(pcols)
real(r8) :: ptcloudsatflag0(pcols)
real(r8) :: ptcloudsatflag1(pcols)
real(r8) :: ptcloudsatflag2(pcols)
@@ -1516,12 +1271,12 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
real(r8) :: ptcloudsatflag8(pcols)
real(r8) :: ptcloudsatflag9(pcols)
real(r8) :: cloudsatpia(pcols)
- real(r8) :: cld_cal_notcs(pcols,nht_cosp) ! CAM clcalipso2 (time,height,profile)
- real(r8) :: atb532_cal(pcols,nhtml_cosp*nscol_cosp) ! CAM atb532 (time,height_mlev,column,profile)
- real(r8) :: mol532_cal(pcols,nhtml_cosp) ! CAM beta_mol532 (time,height_mlev,profile)
- real(r8) :: cld_misr(pcols,nhtmisr_cosp*ntau_cosp) ! CAM clMISR (time,tau,CTH_height_bin,profile)
- real(r8) :: refl_parasol(pcols,nsza_cosp) ! CAM parasol_refl (time,sza,profile)
- real(r8) :: scops_out(pcols,nhtml_cosp*nscol_cosp) ! CAM frac_out (time,height_mlev,column,profile)
+ real(r8) :: cld_cal_notcs(pcols,nht_cosp)
+ real(r8) :: atb532_cal(pcols,nlay*nscol_cosp)
+ real(r8) :: mol532_cal(pcols,nlay)
+ real(r8) :: cld_misr(pcols,nhtmisr_cosp*ntau_cosp)
+ real(r8) :: refl_parasol(pcols,nsza_cosp)
+ real(r8) :: scops_out(pcols,nlay*nscol_cosp)
real(r8) :: cltmodis(pcols)
real(r8) :: clwmodis(pcols)
real(r8) :: climodis(pcols)
@@ -1545,45 +1300,40 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
real(r8) :: clrimodis(pcols,ntau_cosp,numMODISReffIceBins)
real(r8) :: clrlmodis_cam(pcols,ntau_cosp*numMODISReffLiqBins)
real(r8) :: clrlmodis(pcols,ntau_cosp,numMODISReffLiqBins)
- !real(r8) :: tau067_out(pcols,nhtml_cosp*nscol_cosp),emis11_out(pcols,nhtml_cosp*nscol_cosp)
- real(r8),dimension(pcols,nhtml_cosp*nscol_cosp) :: &
- tau067_out,emis11_out,fracliq_out,cal_betatot,cal_betatot_ice, &
- cal_betatot_liq,cal_tautot,cal_tautot_ice,cal_tautot_liq,cs_gvol_out,cs_krvol_out,cs_zvol_out,&
- asym34_out,ssa34_out
+ real(r8), dimension(pcols,nlay*nscol_cosp) :: &
+ tau067_out, emis11_out, fracliq_out, asym34_out, ssa34_out
type(interp_type) :: interp_wgts
- integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1)
+ integer, parameter :: extrap_method = 1 ! sets extrapolation method to boundary value (1)
! COSPv2 stuff
character(len=256),dimension(100) :: cosp_status
integer :: nerror
+ integer :: istat
+ character(len=*), parameter :: sub = 'cospsimulator_intr_run'
+ !--------------------------------------------------------------------------------------
+
call t_startf("init_and_stuff")
! ######################################################################################
! Initialization
! ######################################################################################
- ! Find the chunk and ncol from the state vector
- lchnk = state%lchnk ! state variable contains a number of columns, one chunk
+
+ lchnk = state%lchnk ! chunk ID
ncol = state%ncol ! number of columns in the chunk
+ Npoints = ncol ! number of COSP gridpoints
zero_ifc = 0._r8
- ! Initialize temporary variables as R_UNDEF - need to do this otherwise array expansion puts garbage in history
- ! file for columns over which COSP did make calculations.
- tmp(1:pcols) = R_UNDEF
- tmp1(1:pcols,1:pver) = R_UNDEF
- tmp2(1:pcols,1:pver) = R_UNDEF
-
! Initialize CAM variables as R_UNDEF, important for history files because it will exclude these from averages
- ! (multi-dimensional output that will be collapsed)
! initialize over all pcols, not just ncol. missing values needed in chunks where ncol 0) then
@@ -1824,218 +1533,133 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! CALCULATE COSP INPUT VARIABLES FROM CAM VARIABLES, done for all columns within chunk
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
- ! 0) Create ptop/ztop for gbx%pf and gbx%zlev are for the the interface,
- ! also reverse CAM height/pressure values for input into CSOP
- ! CAM state%pint from top to surface, COSP wants surface to top.
-
- ! Initalize
- ptop(1:ncol,1:pver)=0._r8
- pbot(1:ncol,1:pver)=0._r8
- ztop(1:ncol,1:pver)=0._r8
- zbot(1:ncol,1:pver)=0._r8
- zmid(1:ncol,1:pver)=0._r8
-
- ! assign values from top
- do k=1,pverp-1
- ! assign values from top
- ptop(1:ncol,k)=state%pint(1:ncol,pverp-k)
- ztop(1:ncol,k)=state%zi(1:ncol,pverp-k)
- ! assign values from bottom
- pbot(1:ncol,k)=state%pint(1:ncol,pverp-k+1)
- zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1)
- end do
-
- ! add surface height (surface geopotential/gravity) to convert CAM heights based on geopotential above surface into height above sea level
- do k=1,pver
- do i=1,ncol
- ztop(i,k)=ztop(i,k)+state%phis(i)/gravit
- zbot(i,k)=zbot(i,k)+state%phis(i)/gravit
- zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit
- end do
- end do
-
- ! 1) lat/lon - convert from radians to cosp input type
- ! Initalize
- lat_cosp(1:ncol)=0._r8
- lon_cosp(1:ncol)=0._r8
- ! convert from radians to degrees_north and degrees_east
- lat_cosp=state%lat*180._r8/(pi) ! needs to go from -90 to +90 degrees north
- lon_cosp=state%lon*180._r8/(pi) ! needs to go from 0 to 360 degrees east
-
- ! 2) rh - relative_humidity_liquid_water (%)
- ! calculate from CAM q and t using CAM built-in functions
- do k = 1, pver
- call qsat_water(state%t(1:ncol,k), state%pmid(1:ncol,k), es(1:ncol,k), qs(1:ncol,k), ncol)
- end do
- ! initialize rh
- rh(1:ncol,1:pver)=0._r8
-
- ! calculate rh
- do k=1,pver
- do i=1,ncol
- rh(i,k)=(q(i,k)/qs(i,k))*100
- end do
+
+ ! These arrays are dimensioned to only include active columns (ncol), and the number
+ ! of layers (nlay) and layer interfaces (nlayp) operated on by COSP.
+ allocate( &
+ zmid(ncol,nlay), &
+ zint(ncol,nlayp), &
+ surf_hgt(ncol), &
+ landmask(ncol), &
+ mr_ccliq(ncol,nlay), &
+ mr_ccice(ncol,nlay), &
+ mr_lsliq(ncol,nlay), &
+ mr_lsice(ncol,nlay), &
+ rain_cv(ncol,nlayp), &
+ snow_cv(ncol,nlayp), &
+ rain_cv_interp(ncol,nlay), &
+ snow_cv_interp(ncol,nlay), &
+ rain_ls_interp(ncol,nlay), &
+ snow_ls_interp(ncol,nlay), &
+ grpl_ls_interp(ncol,nlay), &
+ reff_cosp(ncol,nlay,nhydro), &
+ dtau_s(ncol,nlay), &
+ dtau_c(ncol,nlay), &
+ dtau_s_snow(ncol,nlay), &
+ dem_s(ncol,nlay), &
+ dem_c(ncol,nlay), &
+ dem_s_snow(ncol,nlay), stat=istat)
+ call handle_allocate_error(istat, sub, 'zmid,..,dem_s_snow')
+
+ ! add surface height (surface geopotential/gravity) to convert CAM heights based on
+ ! geopotential above surface into height above sea level
+ surf_hgt = state%phis(:ncol)*inverse_gravit
+ do k = 1, nlay
+ zmid(:,k) = state%zm(:ncol,ktop+k-1) + surf_hgt
+ zint(:,k) = state%zi(:ncol,ktop+k-1) + surf_hgt
end do
-
- ! 3) landmask - calculate from cam_in%landfrac
- ! initalize landmask
- landmask(1:ncol)=0._r8
- ! calculate landmask
- do i=1,ncol
- if (cam_in%landfrac(i).gt.0.01_r8) landmask(i)= 1
+ zint(:,nlayp) = surf_hgt
+
+ landmask = 0._r8
+ do i = 1, ncol
+ if (cam_in%landfrac(i) > 0.01_r8) landmask(i)= 1
end do
- ! 4) calculate necessary input cloud/precip variables
- ! CAM4 note: don't take the cloud water from the hack shallow convection scheme or the deep convection.
- ! cloud water values for convection are the same as the stratiform value. (Sungsu)
- ! all precip fluxes are mid points, all values are grid-box mean ("gbm") (Yuying)
-
- ! initialize local variables
- mr_ccliq(1:ncol,1:pver) = 0._r8
- mr_ccice(1:ncol,1:pver) = 0._r8
- mr_lsliq(1:ncol,1:pver) = 0._r8
- mr_lsice(1:ncol,1:pver) = 0._r8
- grpl_ls_interp(1:ncol,1:pver) = 0._r8
- rain_ls_interp(1:ncol,1:pver) = 0._r8
- snow_ls_interp(1:ncol,1:pver) = 0._r8
- rain_cv(1:ncol,1:pverp) = 0._r8
- snow_cv(1:ncol,1:pverp) = 0._r8
- rain_cv_interp(1:ncol,1:pver) = 0._r8
- snow_cv_interp(1:ncol,1:pver) = 0._r8
- reff_cosp(1:ncol,1:pver,1:nhydro) = 0._r8
- ! note: reff_cosp dimensions should be same as cosp (reff_cosp has 9 hydrometeor dimension)
- ! Reff(Npoints,Nlevels,N_HYDRO)
-
- use_precipitation_fluxes = .true. !!! consistent with cam4 implementation.
-
- ! add together deep and shallow convection precipitation fluxes, recall *_flxprc variables are rain+snow
- rain_cv(1:ncol,1:pverp) = (sh_flxprc(1:ncol,1:pverp)-sh_flxsnw(1:ncol,1:pverp)) + &
- (dp_flxprc(1:ncol,1:pverp)-dp_flxsnw(1:ncol,1:pverp))
- snow_cv(1:ncol,1:pverp) = sh_flxsnw(1:ncol,1:pverp) + dp_flxsnw(1:ncol,1:pverp)
+ ! Add together deep and shallow convection precipitation fluxes.
+ ! Note: sh_flxprc and dp_flxprc variables are rain+snow
+ rain_cv = (sh_flxprc(:ncol,ktop:pverp) - sh_flxsnw(:ncol,ktop:pverp)) + &
+ (dp_flxprc(:ncol,ktop:pverp) - dp_flxsnw(:ncol,ktop:pverp))
+ snow_cv = sh_flxsnw(:ncol,ktop:pverp) + dp_flxsnw(:ncol,ktop:pverp)
! interpolate interface precip fluxes to mid points
- do i=1,ncol
- ! find weights (pressure weighting?)
- call lininterp_init(state%zi(i,1:pverp),pverp,state%zm(i,1:pver),pver,extrap_method,interp_wgts)
- ! interpolate lininterp1d(arrin, nin, arrout, nout, interp_wgts)
- ! note: lininterp is an interface, contains lininterp1d -- code figures out to use lininterp1d.
- call lininterp(rain_cv(i,1:pverp),pverp,rain_cv_interp(i,1:pver),pver,interp_wgts)
- call lininterp(snow_cv(i,1:pverp),pverp,snow_cv_interp(i,1:pver),pver,interp_wgts)
- call lininterp(ls_flxprc(i,1:pverp),pverp,rain_ls_interp(i,1:pver),pver,interp_wgts)
- call lininterp(ls_flxsnw(i,1:pverp),pverp,snow_ls_interp(i,1:pver),pver,interp_wgts)
+ do i = 1, ncol
+ ! find weights
+ call lininterp_init(state%zi(i,ktop:pverp), nlayp, state%zm(i,ktop:pver), nlay, &
+ extrap_method, interp_wgts)
+ ! interpolate lininterp(arrin, nin, arrout, nout, interp_wgts)
+ call lininterp(rain_cv(i,:), nlayp, rain_cv_interp(i,:), nlay, interp_wgts)
+ call lininterp(snow_cv(i,:), nlayp, snow_cv_interp(i,:), nlay, interp_wgts)
+ call lininterp(ls_flxprc(i,ktop:pverp), nlayp, rain_ls_interp(i,:), nlay, interp_wgts)
+ call lininterp(ls_flxsnw(i,ktop:pverp), nlayp, snow_ls_interp(i,:), nlay, interp_wgts)
call lininterp_finish(interp_wgts)
!! ls_flxprc is for rain+snow, find rain_ls_interp by subtracting off snow_ls_interp
- rain_ls_interp(i,1:pver)=rain_ls_interp(i,1:pver)-snow_ls_interp(i,1:pver)
+ rain_ls_interp(i,:) = rain_ls_interp(i,:) - snow_ls_interp(i,:)
end do
+
+ !! Make sure interpolated values are not less than 0
+ do k = 1, nlay
+ do i = 1, ncol
+ if (rain_ls_interp(i,k) < 0._r8) then
+ rain_ls_interp(i,k) = 0._r8
+ end if
+ if (snow_ls_interp(i,k) < 0._r8) then
+ snow_ls_interp(i,k) = 0._r8
+ end if
+ if (rain_cv_interp(i,k) < 0._r8) then
+ rain_cv_interp(i,k) = 0._r8
+ end if
+ if (snow_cv_interp(i,k) < 0._r8) then
+ snow_cv_interp(i,k) = 0._r8
+ end if
+ end do
+ end do
+
+ grpl_ls_interp = 0._r8
!! CAM5 cloud mixing ratio calculations
!! Note: Although CAM5 has non-zero convective cloud mixing ratios that affect the model state,
!! Convective cloud water is NOT part of radiation calculations.
- do k=1,pver
- do i=1,ncol
- if (cld(i,k) .gt. 0._r8) then
+ mr_ccliq = 0._r8
+ mr_ccice = 0._r8
+ mr_lsliq = 0._r8
+ mr_lsice = 0._r8
+ do k = 1, nlay
+ kk = ktop + k -1
+ do i = 1, ncol
+ if (cld(i,k) > 0._r8) then
!! note: convective mixing ratio is the sum of shallow and deep convective clouds in CAM5
- mr_ccliq(i,k) = sh_cldliq(i,k) + dp_cldliq(i,k)
- mr_ccice(i,k) = sh_cldice(i,k) + dp_cldice(i,k)
- mr_lsliq(i,k)=state%q(i,k,ixcldliq) ! mr_lsliq, mixing_ratio_large_scale_cloud_liquid, state only includes stratiform (kg/kg)
- mr_lsice(i,k)=state%q(i,k,ixcldice) ! mr_lsice - mixing_ratio_large_scale_cloud_ice, state only includes stratiform (kg/kg)
- else
- mr_ccliq(i,k) = 0._r8
- mr_ccice(i,k) = 0._r8
- mr_lsliq(i,k) = 0._r8
- mr_lsice(i,k) = 0._r8
+ mr_ccliq(i,k) = sh_cldliq(i,kk) + dp_cldliq(i,kk)
+ mr_ccice(i,k) = sh_cldice(i,kk) + dp_cldice(i,kk)
+ mr_lsliq(i,k) = state%q(i,kk,ixcldliq) ! state only includes stratiform (kg/kg)
+ mr_lsice(i,k) = state%q(i,kk,ixcldice) ! state only includes stratiform (kg/kg)
end if
end do
end do
- !! Previously, I had set use_reff=.false.
- !! use_reff = .false. !! if you use this,all sizes use DEFAULT_LIDAR_REFF = 30.0e-6 meters
-
- !! The specification of reff_cosp now follows e-mail discussion with Yuying in January 2011. (see above)
- !! All of the values that I have assembled in the code are in microns... convert to meters here since that is what COSP wants.
- use_reff = .true.
- reff_cosp(1:ncol,1:pver,1) = rel(1:ncol,1:pver)*1.e-6_r8 !! LSCLIQ (same as effc and effliq in stratiform.F90)
- reff_cosp(1:ncol,1:pver,2) = rei(1:ncol,1:pver)*1.e-6_r8 !! LSCICE (same as effi and effice in stratiform.F90)
- reff_cosp(1:ncol,1:pver,3) = ls_reffrain(1:ncol,1:pver)*1.e-6_r8 !! LSRAIN (calculated in cldwat2m_micro.F90, passed to stratiform.F90)
- reff_cosp(1:ncol,1:pver,4) = ls_reffsnow(1:ncol,1:pver)*1.e-6_r8 !! LSSNOW (calculated in cldwat2m_micro.F90, passed to stratiform.F90)
- reff_cosp(1:ncol,1:pver,5) = cv_reffliq(1:ncol,1:pver)*1.e-6_r8 !! CVCLIQ (calculated in stratiform.F90, not actually used in radiation)
- reff_cosp(1:ncol,1:pver,6) = cv_reffice(1:ncol,1:pver)*1.e-6_r8 !! CVCICE (calculated in stratiform.F90, not actually used in radiation)
- reff_cosp(1:ncol,1:pver,7) = ls_reffrain(1:ncol,1:pver)*1.e-6_r8 !! CVRAIN (same as stratiform per Andrew)
- reff_cosp(1:ncol,1:pver,8) = ls_reffsnow(1:ncol,1:pver)*1.e-6_r8 !! CVSNOW (same as stratiform per Andrew)
- reff_cosp(1:ncol,1:pver,9) = 0._r8 !! LSGRPL (using radar default reff)
+ !! The specification of reff_cosp now follows e-mail discussion with Yuying in January 2011.
+ !! The values from the physics buffer are in microns... convert to meters for COSP.
+ reff_cosp(:,:,I_LSCLIQ) = rel(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_LSCICE) = rei(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_LSRAIN) = ls_reffrain(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_LSSNOW) = ls_reffsnow(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_CVCLIQ) = cv_reffliq(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_CVCICE) = cv_reffice(:ncol,ktop:pver)*1.e-6_r8
+ reff_cosp(:,:,I_CVRAIN) = ls_reffrain(:ncol,ktop:pver)*1.e-6_r8 !! same as stratiform per Andrew
+ reff_cosp(:,:,I_CVSNOW) = ls_reffsnow(:ncol,ktop:pver)*1.e-6_r8 !! same as stratiform per Andrew
+ reff_cosp(:,:,I_LSGRPL) = 0._r8 !! using radar default reff
- !! Need code below for when effective radius is fillvalue, and you multiply it by 1.e-6 to convert units, and value becomes no longer fillvalue.
- !! Here, we set it back to zero.
- where (rel(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,1) = 0._r8
- end where
- where (rei(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,2) = 0._r8
- end where
- where (ls_reffrain(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,3) = 0._r8
- end where
- where (ls_reffsnow(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,4) = 0._r8
- end where
- where (cv_reffliq(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,5) = 0._r8
- end where
- where (cv_reffice(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,6) = 0._r8
- end where
- where (ls_reffrain(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,7) = 0._r8
- end where
- where (ls_reffsnow(1:ncol,1:pver) .eq. R_UNDEF)
- reff_cosp(1:ncol,1:pver,8) = 0._r8
- end where
-
- !! Make sure interpolated values are not less than 0 - COSP was complaining and resetting small negative values to zero.
- !! ----- WARNING: COSP_CHECK_INPUT_2D: minimum value of rain_ls set to: 0.000000000000000
- !! So I set negative values to zero here...
- do k=1,pver
- do i=1,ncol
- if (rain_ls_interp(i,k) .lt. 0._r8) then
- rain_ls_interp(i,k)=0._r8
- end if
- if (snow_ls_interp(i,k) .lt. 0._r8) then
- snow_ls_interp(i,k)=0._r8
- end if
- if (rain_cv_interp(i,k) .lt. 0._r8) then
- rain_cv_interp(i,k)=0._r8
- end if
- if (snow_cv_interp(i,k) .lt. 0._r8) then
- snow_cv_interp(i,k)=0._r8
- end if
- end do
- end do
-
- ! 5) assign optical depths and emissivities needed for isccp simulator
- cld_swtau(1:ncol,1:pver) = cld_swtau_in(1:ncol,1:pver)
-
- ! initialize cosp inputs
- dtau_s(1:ncol,1:pver) = 0._r8
- dtau_c(1:ncol,1:pver) = 0._r8
- dtau_s_snow(1:ncol,1:pver) = 0._r8
- dem_s(1:ncol,1:pver) = 0._r8
- dem_c(1:ncol,1:pver) = 0._r8
- dem_s_snow(1:ncol,1:pver) = 0._r8
-
- ! assign values
- ! NOTES:
- ! 1) CAM4 assumes same radiative properties for stratiform and convective clouds,
- ! (see ISCCP_CLOUD_TYPES subroutine call in cloudsimulator.F90)
- ! I presume CAM5 is doing the same thing based on the ISCCP simulator calls within RRTM's radiation.F90
- ! 2) COSP wants in-cloud values. CAM5 values cld_swtau are in-cloud.
- ! 3) snow_tau_in and snow_emis_in are passed without modification to COSP
- dtau_s(1:ncol,1:pver) = cld_swtau(1:ncol,1:pver) ! mean 0.67 micron optical depth of stratiform (in-cloud)
- dtau_c(1:ncol,1:pver) = cld_swtau(1:ncol,1:pver) ! mean 0.67 micron optical depth of convective (in-cloud)
- dem_s(1:ncol,1:pver) = emis(1:ncol,1:pver) ! 10.5 micron longwave emissivity of stratiform (in-cloud)
- dem_c(1:ncol,1:pver) = emis(1:ncol,1:pver) ! 10.5 micron longwave emissivity of convective (in-cloud)
- dem_s_snow(1:ncol,1:pver) = snow_emis_in(1:ncol,1:pver) ! 10.5 micron grid-box mean optical depth of stratiform snow
- dtau_s_snow(1:ncol,1:pver) = snow_tau_in(1:ncol,1:pver) ! 0.67 micron grid-box mean optical depth of stratiform snow
+ ! assign optical depths and emissivities
+ ! CAM4 assumes same radiative properties for stratiform and convective clouds,
+ ! (see ISCCP_CLOUD_TYPES subroutine call in cloudsimulator.F90)
+ ! Assume CAM5 is doing the same thing based on the ISCCP simulator calls within RRTM's radiation.F90
+ ! COSP wants in-cloud values. CAM5 values cld_swtau are in-cloud.
+ ! snow_tau_in and snow_emis_in are passed without modification to COSP
+ dtau_s = cld_swtau_in(:ncol,ktop:pver)
+ dtau_c = cld_swtau_in(:ncol,ktop:pver)
+ dtau_s_snow = snow_tau_in(:ncol,ktop:pver)
+ dem_s = emis(:ncol,ktop:pver)
+ dem_c = emis(:ncol,ktop:pver)
+ dem_s_snow = snow_emis_in(:ncol,ktop:pver)
! ######################################################################################
! Compute sunlit flag. If cosp_runall=.true., then run on all points.
@@ -2044,32 +1668,22 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
if (cosp_runall) then
cam_sunlit(:) = 1
nSunLit = ncol
- nNoSunLit = 0
else
nSunLit = 0
- nNoSunLit = 0
do i=1,ncol
if ((coszrs(i) > 0.0_r8) .and. (run_cosp(i,lchnk))) then
cam_sunlit(i) = 1
nSunLit = nSunLit+1
- else
- nNoSunLit = nNoSunlit+1
endif
enddo
endif
call t_stopf("init_and_stuff")
- ! ######################################################################################
- ! ######################################################################################
- ! END TRANSLATE CAM VARIABLES TO COSP INPUT VARIABLES
- ! ######################################################################################
- ! ######################################################################################
-
! ######################################################################################
! Construct COSP output derived type.
! ######################################################################################
call t_startf("construct_cosp_outputs")
- call construct_cosp_outputs(ncol,nscol_cosp,pver,Nlvgrid,0,cospOUT)
+ call construct_cosp_outputs(ncol, nscol_cosp, nlay, Nlvgrid, cospOUT)
call t_stopf("construct_cosp_outputs")
! ######################################################################################
@@ -2077,44 +1691,45 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
! ######################################################################################
! Model state
call t_startf("construct_cospstateIN")
- call construct_cospstateIN(ncol,pver,0,cospstateIN)
- cospstateIN%lat = lat_cosp(1:ncol)
- cospstateIN%lon = lon_cosp(1:ncol)
- cospstateIN%at = state%t(1:ncol,1:pver)
- cospstateIN%qv = q(1:ncol,1:pver)
- cospstateIN%o3 = o3(1:ncol,1:pver)
- cospstateIN%sunlit = cam_sunlit(1:ncol)
- cospstateIN%skt = cam_in%ts(1:ncol)
- cospstateIN%land = landmask(1:ncol)
- cospstateIN%pfull = state%pmid(1:ncol,1:pver)
- cospstateIN%phalf(1:ncol,1) = 0._r8
- cospstateIN%phalf(1:ncol,2:pver+1) = pbot(1:ncol,pver:1:-1)
- cospstateIN%hgt_matrix = zmid(1:ncol,1:pver)
- cospstateIN%hgt_matrix_half(1:ncol,pver+1) = 0._r8
- cospstateIN%hgt_matrix_half(1:ncol,1:pver) = zbot(1:ncol,pver:1:-1)
- cospstateIN%surfelev(1:ncol) = zbot(1:ncol,1)
+
+ call construct_cospstateIN(ncol, nlay, 0, cospstateIN)
+
+ ! convert to degrees. Lat in range [-90,..,90], Lon in range [0,..,360]
+ cospstateIN%lat = state%lat(:ncol)*rad2deg
+ cospstateIN%lon = state%lon(:ncol)*rad2deg
+ cospstateIN%at = state%t(:ncol,ktop:pver)
+ cospstateIN%qv = q(:ncol,ktop:pver)
+ cospstateIN%o3 = o3(:ncol,ktop:pver)
+ cospstateIN%sunlit = cam_sunlit(:ncol)
+ cospstateIN%skt = cam_in%ts(:ncol)
+ cospstateIN%land = landmask
+ cospstateIN%pfull = state%pmid(:ncol,ktop:pver)
+ cospstateIN%phalf = state%pint(:ncol,ktop:pverp)
+ cospstateIN%hgt_matrix = zmid
+ cospstateIN%hgt_matrix_half = zint
+ cospstateIN%surfelev = surf_hgt
call t_stopf("construct_cospstateIN")
! Optical inputs
call t_startf("construct_cospIN")
- call construct_cospIN(ncol,nscol_cosp,pver,cospIN)
- cospIN%emsfc_lw = emsfc_lw
+ call construct_cospIN(ncol, nscol_cosp, nlay, cospIN)
+ cospIN%emsfc_lw = emsfc_lw
if (lradar_sim) cospIN%rcfg_cloudsat = rcfg_cs(lchnk)
call t_stopf("construct_cospIN")
- ! *NOTE* Fields passed into subsample_and_optics are ordered from TOA-2-SFC.
call t_startf("subsample_and_optics")
- call subsample_and_optics(ncol,pver,nscol_cosp,nhydro,overlap, &
- use_precipitation_fluxes,lidar_ice_type,sd_cs(lchnk),cld(1:ncol,1:pver),&
- concld(1:ncol,1:pver),rain_ls_interp(1:ncol,1:pver), &
- snow_ls_interp(1:ncol,1:pver),grpl_ls_interp(1:ncol,1:pver), &
- rain_cv_interp(1:ncol,1:pver),snow_cv_interp(1:ncol,1:pver), &
- mr_lsliq(1:ncol,1:pver),mr_lsice(1:ncol,1:pver), &
- mr_ccliq(1:ncol,1:pver),mr_ccice(1:ncol,1:pver), &
- reff_cosp(1:ncol,1:pver,:),dtau_c(1:ncol,1:pver), &
- dtau_s(1:ncol,1:pver),dem_c(1:ncol,1:pver), &
- dem_s(1:ncol,1:pver),dtau_s_snow(1:ncol,1:pver), &
- dem_s_snow(1:ncol,1:pver),state%ps(1:ncol),cospstateIN,cospIN)
+ ! The arrays passed here contain only active columns and the limited vertical
+ ! domain operated on by COSP. Unsubscripted array arguments have already been
+ ! allocated to the correct size. Arrays the size of a CAM chunk (pcol,pver)
+ ! need to pass the correct section (:ncol,ktop:pver).
+ call subsample_and_optics( &
+ ncol, nlay, nscol_cosp, nhydro, overlap, &
+ lidar_ice_type, sd_cs(lchnk), &
+ cld(:ncol,ktop:pver), concld(:ncol,ktop:pver), &
+ rain_ls_interp, snow_ls_interp, grpl_ls_interp, rain_cv_interp, &
+ snow_cv_interp, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, &
+ reff_cosp, dtau_c, dtau_s ,dem_c, dem_s, dtau_s_snow, &
+ dem_s_snow, state%ps(:ncol), cospstateIN, cospIN)
call t_stopf("subsample_and_optics")
! ######################################################################################
@@ -2151,12 +1766,11 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
call outfld('ZLEV_COSP', cospstateIN%hgt_matrix, ncol,lchnk)
call outfld('ZLEV_HALF_COSP', cospstateIN%hgt_matrix_half, ncol,lchnk)
call outfld('T_COSP', cospstateIN%at, ncol,lchnk)
- call outfld('RH_COSP', cospstateIN%qv, ncol,lchnk)
- call outfld('Q_COSP', q(1:ncol,1:pver), ncol,lchnk)
+ call outfld('Q_COSP', cospstateIN%qv, ncol,lchnk)
! 3D outputs, but first compress to 2D
do i=1,ncol
- do ihml=1,nhtml_cosp
+ do ihml=1,nlay
do isc=1,nscol_cosp
ihsc = (ihml-1)*nscol_cosp+isc
tau067_out(i,ihsc) = cospIN%tau_067(i,isc,ihml)
@@ -2268,18 +1882,18 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
! ######################################################################################
call t_startf("output_copying")
if (allocated(cospIN%frac_out)) &
- frac_out(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospIN%frac_out ! frac_out (time,height_mlev,column,profile)
+ frac_out(1:ncol,1:nscol_cosp,1:nlay) = cospIN%frac_out
! Cloudsat
if (lradar_sim) then
- cfad_dbze94(1:ncol,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = cospOUT%cloudsat_cfad_ze ! cfad_dbze94 (time,height,dbze,profile)
- dbze94(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospOUT%cloudsat_Ze_tot ! dbze94 (time,height_mlev,column,profile)
- cldtot_cs(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc ! CAM version of cltradar (time,profile) ! NOT COMPUTED IN COSP2
- cldtot_cs2(1:ncol) = 0._r8!cospOUT%cloudsat_radar_tcc2 ! CAM version of cltradar2 (time,profile) ! NOT COMPUTED IN COSP2
+ cfad_dbze94(1:ncol,1:CLOUDSAT_DBZE_BINS,1:nht_cosp) = cospOUT%cloudsat_cfad_ze
+ dbze94(1:ncol,1:nscol_cosp,1:nlay) = cospOUT%cloudsat_Ze_tot
+ cldtot_cs(1:ncol) = 0._r8
+ cldtot_cs2(1:ncol) = 0._r8
! *NOTE* These two fields are joint-simulator products, but in CAM they are controlled
! by the radar simulator control.
- cldtot_calcs(1:ncol) = cospOUT%radar_lidar_tcc ! CAM version of cltlidarradar (time,profile)
- cld_cal_notcs(1:ncol,1:nht_cosp) = cospOUT%lidar_only_freq_cloud ! CAM version of clcalipso2 (time,height,profile)
+ cldtot_calcs(1:ncol) = cospOUT%radar_lidar_tcc
+ cld_cal_notcs(1:ncol,1:nht_cosp) = cospOUT%lidar_only_freq_cloud
! Cloudsat near-surface precipitation diagnostics
ptcloudsatflag0(1:ncol) = cospOUT%cloudsat_precip_cover(:,1)
@@ -2294,81 +1908,56 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
ptcloudsatflag9(1:ncol) = cospOUT%cloudsat_precip_cover(:,10)
cloudsatpia(1:ncol) = cospOUT%cloudsat_pia
- ! Output the mixing-ratio for all hydrometeor types in Cloudsat near-surface precipitation diagnostics
- ! *NOTE* These fields are simply the native CAM mixing-ratios for each hydrometeor type used in the
- ! CAM6 microphysics scheme, interpolated to the same vertical grid used by the Cloudsat
- ! simulator. These fields are not part of the radar simulator standard output, as these fields
- ! are entirely dependent on the host models microphysics, not the retrieval.
-
-
endif
! CALIPSO
if (llidar_sim) then
- cldlow_cal(1:ncol) = cospOUT%calipso_cldlayer(:,1) ! CAM version of cllcalipso (time,profile)
- cldmed_cal(1:ncol) = cospOUT%calipso_cldlayer(:,2) ! CAM version of clmcalipso (time,profile)
- cldhgh_cal(1:ncol) = cospOUT%calipso_cldlayer(:,3) ! CAM version of clhcalipso (time,profile)
- cldtot_cal(1:ncol) = cospOUT%calipso_cldlayer(:,4) ! CAM version of cltcalipso (time,profile)
- cldlow_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,1) ! CAM version of cllcalipsoice !+cosp1.4
- cldmed_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,1) ! CAM version of clmcalipsoice
- cldhgh_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,1) ! CAM version of clhcalipsoice
- cldtot_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,1) ! CAM version of cltcalipsoice
- cldlow_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,2) ! CAM version of cllcalipsoliq
- cldmed_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,2) ! CAM version of clmcalipsoliq
- cldhgh_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,2) ! CAM version of clhcalipsoliq
- cldtot_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,2) ! CAM version of cltcalipsoliq
- cldlow_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,3) ! CAM version of cllcalipsoun
- cldmed_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,3) ! CAM version of clmcalipsoun
- cldhgh_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,3) ! CAM version of clhcalipsoun
- cldtot_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,3) ! CAM version of cltcalipsoun, !+cosp1.4
- cld_cal_ice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,1) ! CAM version of clcalipsoice !+cosp1.4
- cld_cal_liq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,2) ! CAM version of clcalipsoliq
- cld_cal_un(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,3) ! CAM version of clcalipsoun
- cld_cal_tmp(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,1) ! CAM version of clcalipsotmp
- cld_cal_tmpliq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,2) ! CAM version of clcalipsotmpice
- cld_cal_tmpice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,3) ! CAM version of clcalipsotmpliq
- cld_cal_tmpun(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,4) ! CAM version of clcalipsotmpun, !+cosp1.4
- cld_cal(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcld(:,1:nht_cosp) ! CAM version of clcalipso (time,height,profile)
- mol532_cal(1:ncol,1:nhtml_cosp) = cospOUT%calipso_beta_mol ! CAM version of beta_mol532 (time,height_mlev,profile)
- atb532(1:ncol,1:nscol_cosp,1:nhtml_cosp) = cospOUT%calipso_beta_tot ! atb532 (time,height_mlev,column,profile)
- cfad_lidarsr532(1:ncol,1:nsr_cosp,1:nht_cosp) = cospOUT%calipso_cfad_sr(:,:,:) ! cfad_lidarsr532 (time,height,scat_ratio,profile)
- ! PARASOL. In COSP2, the Parasol simulator is independent of the calipso simulator.
- refl_parasol(1:ncol,1:nsza_cosp) = cospOUT%parasolGrid_refl ! CAM version of parasolrefl (time,sza,profile)
- ! CALIPSO Opaque cloud diagnostics
-! cldopaq_cal(1:pcols) = cospOUT%calipso_cldtype(:,1)
-! cldthin_cal(1:pcols) = cospOUT%calipso_cldtype(:,2)
-! cldopaqz_cal(1:pcols) = cospOUT%calipso_cldtype(:,3)
-! cldopaq_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,1)
-! cldthin_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,2)
-! cldzopaq_cal_temp(1:pcols) = cospOUT%calipso_cldtypetemp(:,3)
-! cldopaq_cal_z(1:pcols) = cospOUT%calipso_cldtypemeanz(:,1)
-! cldthin_cal_z(1:pcols) = cospOUT%calipso_cldtypemeanz(:,2)
-! cldthin_cal_emis(1:pcols) = cospOUT%calipso_cldthinemis
-! cldopaq_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,1)
-! cldthin_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,2)
-! cldzopaq_cal_se(1:pcols) = cospOUT%calipso_cldtypemeanzse(:,3)
-! cldopaq_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,1)
-! cldthin_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,2)
-! cldzopaq_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,3)
-! opacity_cal_2d(1:pcols,1:nht_cosp) = cospOUT%calipso_lidarcldtype(:,:,4)
+ cldlow_cal(1:ncol) = cospOUT%calipso_cldlayer(:,1)
+ cldmed_cal(1:ncol) = cospOUT%calipso_cldlayer(:,2)
+ cldhgh_cal(1:ncol) = cospOUT%calipso_cldlayer(:,3)
+ cldtot_cal(1:ncol) = cospOUT%calipso_cldlayer(:,4)
+ cldlow_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,1)
+ cldmed_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,1)
+ cldhgh_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,1)
+ cldtot_cal_ice(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,1)
+ cldlow_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,2)
+ cldmed_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,2)
+ cldhgh_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,2)
+ cldtot_cal_liq(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,2)
+ cldlow_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,1,3)
+ cldmed_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,2,3)
+ cldhgh_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,3,3)
+ cldtot_cal_un(1:ncol) = cospOUT%calipso_cldlayerphase(:,4,3)
+ cld_cal_ice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,1)
+ cld_cal_liq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,2)
+ cld_cal_un(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldphase(:,:,3)
+ cld_cal_tmp(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,1)
+ cld_cal_tmpliq(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,2)
+ cld_cal_tmpice(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,3)
+ cld_cal_tmpun(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcldtmp(:,:,4)
+ cld_cal(1:ncol,1:nht_cosp) = cospOUT%calipso_lidarcld(:,1:nht_cosp)
+ mol532_cal(1:ncol,1:nlay) = cospOUT%calipso_beta_mol
+ atb532(1:ncol,1:nscol_cosp,1:nlay)= cospOUT%calipso_beta_tot
+ cfad_lidarsr532(1:ncol,1:nsr_cosp,1:nht_cosp) = cospOUT%calipso_cfad_sr(:,:,:)
+ refl_parasol(1:ncol,1:nsza_cosp) = cospOUT%parasolGrid_refl
endif
! ISCCP
if (lisccp_sim) then
- clisccp2(1:ncol,1:ntau_cosp,1:nprs_cosp) = cospOUT%isccp_fq ! CAM version of clisccp2 (time,tau,plev,profile)
- tau_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxtau ! CAM version of boxtauisccp (time,column,profile)
- cldptop_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxptop ! CAM version of boxptopisccp (time,column,profile)
- cldtot_isccp(1:ncol) = cospOUT%isccp_totalcldarea ! CAM version of tclisccp (time, profile)
- meanptop_isccp(1:ncol) = cospOUT%isccp_meanptop ! CAM version of ctpisccp (time, profile)
- meantau_isccp(1:ncol) = cospOUT%isccp_meantaucld ! CAM version of meantbisccp (time, profile)
- meancldalb_isccp(1:ncol) = cospOUT%isccp_meanalbedocld ! CAM version of albisccp (time, profile)
- meantb_isccp(1:ncol) = cospOUT%isccp_meantb ! CAM version of meantbisccp (time, profile)
- meantbclr_isccp(1:ncol) = cospOUT%isccp_meantbclr ! CAM version of meantbclrisccp (time, profile)
+ clisccp2(1:ncol,1:ntau_cosp,1:nprs_cosp) = cospOUT%isccp_fq
+ tau_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxtau
+ cldptop_isccp(1:ncol,1:nscol_cosp) = cospOUT%isccp_boxptop
+ cldtot_isccp(1:ncol) = cospOUT%isccp_totalcldarea
+ meanptop_isccp(1:ncol) = cospOUT%isccp_meanptop
+ meantau_isccp(1:ncol) = cospOUT%isccp_meantaucld
+ meancldalb_isccp(1:ncol) = cospOUT%isccp_meanalbedocld
+ meantb_isccp(1:ncol) = cospOUT%isccp_meantb
+ meantbclr_isccp(1:ncol) = cospOUT%isccp_meantbclr
endif
! MISR
if (lmisr_sim) then
- clMISR(1:ncol,1:ntau_cosp,1:nhtmisr_cosp) = cospOUT%misr_fq ! CAM version of clMISR (time,tau,CTH_height_bin,profile)
+ clMISR(1:ncol,1:ntau_cosp,1:nhtmisr_cosp) = cospOUT%misr_fq
endif
! MODIS
@@ -2395,46 +1984,39 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
clrlmodis(1:ncol,1:ntau_cosp_modis,1:numMODISReffLiqBins) = cospOUT%modis_Optical_Thickness_vs_ReffLIQ
endif
- ! Use high-dimensional output to populate CAM collapsed output variables
- ! see above for mixed dimension definitions
- ! i am using the convention of starting vertical coordinates at the surface, up to down, COSP convention, not CAM.
+ ! Use COSP output to populate CAM collapsed output variables
do i=1,ncol
if (lradar_sim) then
- ! CAM cfad_dbze94 (time,height,dbze,profile)
do ih=1,nht_cosp
do id=1,CLOUDSAT_DBZE_BINS
ihd=(ih-1)*CLOUDSAT_DBZE_BINS+id
- cfad_dbze94_cs(i,ihd) = cfad_dbze94(i,id,ih) ! cfad_dbze94_cs(pcols,nht_cosp*CLOUDSAT_DBZE_BINS)
+ cfad_dbze94_cs(i,ihd) = cfad_dbze94(i,id,ih)
end do
end do
- ! CAM dbze94 (time,height_mlev,column,profile)
- do ihml=1,nhtml_cosp
+ do ihml=1,nlay
do isc=1,nscol_cosp
ihsc=(ihml-1)*nscol_cosp+isc
- dbze_cs(i,ihsc) = dbze94(i,isc,ihml) ! dbze_cs(pcols,pver*nscol_cosp)
+ dbze_cs(i,ihsc) = dbze94(i,isc,ihml)
end do
end do
endif
if (llidar_sim) then
- ! CAM cfad_lidarsr532 (time,height,scat_ratio,profile)
do ih=1,nht_cosp
do is=1,nsr_cosp
ihs=(ih-1)*nsr_cosp+is
- cfad_sr532_cal(i,ihs) = cfad_lidarsr532(i,is,ih) ! cfad_sr532_cal(pcols,nht_cosp*nsr_cosp)
+ cfad_sr532_cal(i,ihs) = cfad_lidarsr532(i,is,ih)
end do
end do
- ! CAM atb532 (time,height_mlev,column,profile) FIX
- do ihml=1,nhtml_cosp
+ do ihml=1,nlay
do isc=1,nscol_cosp
ihsc=(ihml-1)*nscol_cosp+isc
- atb532_cal(i,ihsc) = atb532(i,isc,ihml) ! atb532_cal(pcols,nht_cosp*nscol_cosp)
+ atb532_cal(i,ihsc) = atb532(i,isc,ihml)
end do
end do
endif
if (lmisr_sim) then
- ! CAM clMISR (time,tau,CTH_height_bin,profile)
do ihm=1,nhtmisr_cosp
do it=1,ntau_cosp
ihmt=(ihm-1)*ntau_cosp+it
@@ -2444,21 +2026,18 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
endif
if (lmodis_sim) then
- ! CAM clmodis
do ip=1,nprs_cosp
do it=1,ntau_cosp_modis
ipt=(ip-1)*ntau_cosp_modis+it
clmodis_cam(i,ipt) = clmodis(i,it,ip)
end do
end do
- ! CAM clrimodis
do ip=1,numMODISReffIceBins
do it=1,ntau_cosp_modis
ipt=(ip-1)*ntau_cosp_modis+it
clrimodis_cam(i,ipt) = clrimodis(i,it,ip)
end do
end do
- ! CAM clrlmodis
do ip=1,numMODISReffLiqBins
do it=1,ntau_cosp_modis
ipt=(ip-1)*ntau_cosp_modis+it
@@ -2468,10 +2047,10 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
endif
! Subcolums
- do ihml=1,nhtml_cosp
+ do ihml=1,nlay
do isc=1,nscol_cosp
ihsc=(ihml-1)*nscol_cosp+isc
- scops_out(i,ihsc) = frac_out(i,isc,ihml) ! scops_out(pcols,nht_cosp*nscol_cosp)
+ scops_out(i,ihsc) = frac_out(i,isc,ihml)
end do
end do
end do
@@ -2601,40 +2180,6 @@ subroutine cospsimulator_intr_run(state,pbuf, cam_in,emis,coszrs,cld_swtau_in,sn
end where
call outfld('CLD_CAL_TMPUN',cld_cal_tmpun ,pcols,lchnk) !! !+cosp1.4
- ! Opaque cloud diagnostics
-! call outfld('CLDOPQ_CAL', cldopaq_cal, pcols, lchnk)
-! call outfld('CLDTHN_CAL', cldthin_cal, pcols, lchnk)
-! call outfld('CLDZOPQ_CAL', cldopaqz_cal, pcols, lchnk)
-! call outfld('CLDOPQ_CAL_TMP', cldopaq_cal_temp, pcols, lchnk)
-! call outfld('CLDTHN_CAL_TMP', cldthin_cal_temp, pcols, lchnk)
-! call outfld('CLDZOPQ_CAL_TMP', cldzopaq_cal_temp, pcols, lchnk)
-! call outfld('CLDOPQ_CAL_Z', cldopaq_cal_z, pcols, lchnk)
-! call outfld('CLDTHN_CAL_Z', cldthin_cal_z, pcols, lchnk)
-! call outfld('CLDTHN_CAL_EMIS', cldthin_cal_emis, pcols, lchnk)
-! call outfld('CLDOPQ_CAL_SE', cldopaq_cal_se, pcols, lchnk)
-! call outfld('CLDTHN_CAL_SE', cldthin_cal_se, pcols, lchnk)
-! call outfld('CLDZOPQ_CAL_SE', cldzopaq_cal_se, pcols, lchnk)
-! !
-! where (cldopaq_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF)
-! cldopaq_cal_2d(:ncol,:nht_cosp) = 0.0_r8
-! end where
-! call outfld('CLDOPQ_CAL_2D', cldopaq_cal_2d, pcols, lchnk)
-! !
-! where (cldthin_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF)
-! cldthin_cal_2d(:ncol,:nht_cosp) = 0.0_r8
-! end where
-! call outfld('CLDTHN_CAL_2D', cldthin_cal_2d, pcols, lchnk)
-! !
-! where (cldzopaq_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF)
-! cldzopaq_cal_2d(:ncol,:nht_cosp) = 0.0_r8
-! end where
-! call outfld('CLDZOPQ_CAL_2D', cldzopaq_cal_2d, pcols, lchnk)
-! !
-! where (opacity_cal_2d(:ncol,:nht_cosp) .eq. R_UNDEF)
-! opacity_cal_2d(:ncol,:nht_cosp) = 0.0_r8
-! end where
-! call outfld('OPACITY_CAL_2D', opacity_cal_2d, pcols, lchnk)
-
end if
! RADAR SIMULATOR OUTPUTS
@@ -2794,7 +2339,7 @@ end subroutine cospsimulator_intr_run
! SUBROUTINE subsample_and_optics
! ######################################################################################
subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, &
- use_precipitation_fluxes, lidar_ice_type, sd, tca, cca,&
+ lidar_ice_type, sd, tca, cca, &
fl_lsrainIN, fl_lssnowIN, fl_lsgrplIN, fl_ccrainIN, &
fl_ccsnowIN, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, &
reffIN, dtau_c, dtau_s, dem_c, dem_s, dtau_s_snow, &
@@ -2812,8 +2357,6 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
use mod_cosp_config, only: Nlvgrid, vgrid_zl, vgrid_zu
use mod_cosp_stats, only: cosp_change_vertical_grid
! Inputs
- logical,intent(in) :: &
- use_precipitation_fluxes
integer,intent(in) :: &
nPoints, & ! Number of gridpoints
nLevels, & ! Number of vertical levels
@@ -2852,7 +2395,7 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
type(cosp_column_inputs),intent(inout) :: cospstateIN
! Local variables
- integer :: i,j,k
+ integer :: i, j, k, istat
real(wp),dimension(nPoints,nLevels) :: column_frac_out,column_prec_out, &
fl_lsrain,fl_lssnow,fl_lsgrpl,fl_ccrain, &
fl_ccsnow
@@ -2870,6 +2413,9 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
MODIS_opticalThicknessIce, &
fracPrecipIce, fracPrecipIce_statGrid
real(wp),dimension(:,:,:,:),allocatable :: mr_hydro,Reff,Np
+
+ character(len=*), parameter :: sub = 'subsample_and_optics'
+ !--------------------------------------------------------------------------------------
call t_startf("scops")
if (Ncolumns .gt. 1) then
@@ -2877,7 +2423,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! RNG used for subcolumn generation
- allocate(rngs(nPoints),seed(nPoints))
+ allocate(rngs(nPoints), seed(nPoints), stat=istat)
+ call handle_allocate_error(istat, sub, 'rngs, seed')
seed = int(sfcP)
if (Npoints .gt. 1) seed=(sfcP-int(sfcP))*1000000
call init_rng(rngs, seed)
@@ -2886,28 +2433,24 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
call scops(NPoints,Nlevels,Ncolumns,rngs,tca,cca,overlap,cospIN%frac_out,0)
deallocate(seed,rngs)
- ! Sum up precipitation rates. If not using preciitation fluxes, mixing ratios are
- ! stored in _rate variables.
- allocate(ls_p_rate(nPoints,nLevels),cv_p_rate(nPoints,Nlevels))
- if(use_precipitation_fluxes) then
- ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN
- cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN
- else
- ls_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + mixing_ratio (groupel)
- cv_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow)
- endif
+ ! Sum up precipitation rates.
+ allocate(ls_p_rate(nPoints,nLevels), cv_p_rate(nPoints,Nlevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'ls_p_rate, cv_p_rate')
+ ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN
+ cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN
! Call PREC_SCOPS
- allocate(frac_prec(nPoints,nColumns,nLevels))
+ allocate(frac_prec(nPoints,nColumns,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'frac_prec')
call prec_scops(nPoints,nLevels,nColumns,ls_p_rate,cv_p_rate,cospIN%frac_out,frac_prec)
deallocate(ls_p_rate,cv_p_rate)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Compute precipitation fraction in each gridbox
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- ! Allocate
- allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels), &
- frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels))
+ allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels), &
+ frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'frac_ls,..,prec_cv')
! Initialize
frac_ls(1:nPoints,1:nLevels) = 0._wp
@@ -2945,9 +2488,10 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
! Compute mixing ratios, effective radii and precipitation fluxes for clouds
! and precipitation
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro), &
- Reff(nPoints,nColumns,nLevels,nHydro), &
- Np(nPoints,nColumns,nLevels,nHydro))
+ allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro), &
+ Reff(nPoints,nColumns,nLevels,nHydro), &
+ Np(nPoints,nColumns,nLevels,nHydro), stat=istat)
+ call handle_allocate_error(istat, sub, 'mr_hydro,Reff,Np')
! Initialize
mr_hydro(:,:,:,:) = 0._wp
@@ -3004,26 +2548,14 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
endif
! Precipitation
- if (use_precipitation_fluxes) then
- if (prec_ls(j,k) .ne. 0._r8) then
- fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k)
- fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k)
- fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k)
- endif
- if (prec_cv(j,k) .ne. 0._r8) then
- fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k)
- fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k)
- endif
- else
- if (prec_ls(j,k) .ne. 0._r8) then
- mr_hydro(j,:,k,I_LSRAIN) = mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k)
- mr_hydro(j,:,k,I_LSSNOW) = mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k)
- mr_hydro(j,:,k,I_LSGRPL) = mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k)
- endif
- if (prec_cv(j,k) .ne. 0._r8) then
- mr_hydro(j,:,k,I_CVRAIN) = mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k)
- mr_hydro(j,:,k,I_CVSNOW) = mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k)
- endif
+ if (prec_ls(j,k) .ne. 0._r8) then
+ fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k)
+ fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k)
+ fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k)
+ endif
+ if (prec_cv(j,k) .ne. 0._r8) then
+ fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k)
+ fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k)
endif
enddo
enddo
@@ -3031,48 +2563,48 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Convert precipitation fluxes to mixing ratios
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- if (use_precipitation_fluxes) then
- ! LS rain
- call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
- cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN), &
- alpha_x(I_LSRAIN), c_x(I_LSRAIN), d_x(I_LSRAIN), g_x(I_LSRAIN), &
- a_x(I_LSRAIN), b_x(I_LSRAIN), gamma_1(I_LSRAIN), gamma_2(I_LSRAIN), &
- gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain, &
- mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN))
- ! LS snow
- call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
- cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSSNOW), n_bx(I_LSSNOW), &
- alpha_x(I_LSSNOW), c_x(I_LSSNOW), d_x(I_LSSNOW), g_x(I_LSSNOW), &
- a_x(I_LSSNOW), b_x(I_LSSNOW), gamma_1(I_LSSNOW), gamma_2(I_LSSNOW), &
- gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow, &
- mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW))
- ! CV rain
- call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
- cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN), n_bx(I_CVRAIN), &
- alpha_x(I_CVRAIN), c_x(I_CVRAIN), d_x(I_CVRAIN), g_x(I_CVRAIN), &
- a_x(I_CVRAIN), b_x(I_CVRAIN), gamma_1(I_CVRAIN), gamma_2(I_CVRAIN), &
- gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain, &
- mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN))
- ! CV snow
- call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
- cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW), n_bx(I_CVSNOW), &
- alpha_x(I_CVSNOW), c_x(I_CVSNOW), d_x(I_CVSNOW), g_x(I_CVSNOW), &
- a_x(I_CVSNOW), b_x(I_CVSNOW), gamma_1(I_CVSNOW), gamma_2(I_CVSNOW), &
- gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow, &
- mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW))
- ! LS groupel.
- call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
- cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL), n_bx(I_LSGRPL), &
- alpha_x(I_LSGRPL), c_x(I_LSGRPL), d_x(I_LSGRPL), g_x(I_LSGRPL), &
- a_x(I_LSGRPL), b_x(I_LSGRPL), gamma_1(I_LSGRPL), gamma_2(I_LSGRPL), &
- gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl, &
- mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL))
- endif
+
+ ! LS rain
+ call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
+ cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN), &
+ alpha_x(I_LSRAIN), c_x(I_LSRAIN), d_x(I_LSRAIN), g_x(I_LSRAIN), &
+ a_x(I_LSRAIN), b_x(I_LSRAIN), gamma_1(I_LSRAIN), gamma_2(I_LSRAIN), &
+ gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain, &
+ mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN))
+ ! LS snow
+ call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
+ cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSSNOW), n_bx(I_LSSNOW), &
+ alpha_x(I_LSSNOW), c_x(I_LSSNOW), d_x(I_LSSNOW), g_x(I_LSSNOW), &
+ a_x(I_LSSNOW), b_x(I_LSSNOW), gamma_1(I_LSSNOW), gamma_2(I_LSSNOW), &
+ gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow, &
+ mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW))
+ ! CV rain
+ call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
+ cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN), n_bx(I_CVRAIN), &
+ alpha_x(I_CVRAIN), c_x(I_CVRAIN), d_x(I_CVRAIN), g_x(I_CVRAIN), &
+ a_x(I_CVRAIN), b_x(I_CVRAIN), gamma_1(I_CVRAIN), gamma_2(I_CVRAIN), &
+ gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain, &
+ mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN))
+ ! CV snow
+ call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
+ cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW), n_bx(I_CVSNOW), &
+ alpha_x(I_CVSNOW), c_x(I_CVSNOW), d_x(I_CVSNOW), g_x(I_CVSNOW), &
+ a_x(I_CVSNOW), b_x(I_CVSNOW), gamma_1(I_CVSNOW), gamma_2(I_CVSNOW), &
+ gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow, &
+ mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW))
+ ! LS groupel.
+ call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, &
+ cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL), n_bx(I_LSGRPL), &
+ alpha_x(I_LSGRPL), c_x(I_LSGRPL), d_x(I_LSGRPL), g_x(I_LSGRPL), &
+ a_x(I_LSGRPL), b_x(I_LSGRPL), gamma_1(I_LSGRPL), gamma_2(I_LSGRPL), &
+ gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl, &
+ mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL))
else
cospIN%frac_out(:,:,:) = 1
allocate(mr_hydro(nPoints, 1,nLevels,nHydro),Reff(nPoints,1,nLevels,nHydro), &
- Np(nPoints,1,nLevels,nHydro))
+ Np(nPoints,1,nLevels,nHydro), stat=istat)
+ call handle_allocate_error(istat, sub, 'mr_hydro,Reff,Np')
mr_hydro(:,1,:,I_LSCLIQ) = mr_lsliq
mr_hydro(:,1,:,I_LSCICE) = mr_lsice
mr_hydro(:,1,:,I_CVCLIQ) = mr_ccliq
@@ -3087,7 +2619,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
call t_startf("cloudsat_optics")
if (lradar_sim) then
! Compute gaseous absorption (assume identical for each subcolun)
- allocate(g_vol(nPoints,nLevels))
+ allocate(g_vol(nPoints,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'g_vol')
g_vol(:,:)=0._wp
do i = 1, nPoints
do j = 1, nLevels
@@ -3101,7 +2634,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
end do
! Loop over all subcolumns
- allocate(fracPrecipIce(nPoints,nColumns,nLevels))
+ allocate(fracPrecipIce(nPoints,nColumns,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'fracPrecipIce')
fracPrecipIce(:,:,:) = 0._wp
do k=1,nColumns
call quickbeam_optics(sd, cospIN%rcfg_cloudsat, nPoints, nLevels, R_UNDEF, &
@@ -3124,7 +2658,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
enddo
! Regrid frozen fraction to Cloudsat/Calipso statistical grid
- allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid))
+ allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid), stat=istat)
+ call handle_allocate_error(istat, sub, 'fracPrecipIce_statGrid')
fracPrecipIce_statGrid(:,:,:) = 0._wp
call cosp_change_vertical_grid(Npoints, Ncolumns, Nlevels, cospstateIN%hgt_matrix(:,Nlevels:1:-1), &
cospstateIN%hgt_matrix_half(:,Nlevels:1:-1), fracPrecipIce(:,:,Nlevels:1:-1), Nlvgrid, &
@@ -3133,13 +2668,6 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
! For near-surface diagnostics, we only need the frozen fraction at one layer.
cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,cloudsat_preclvl)
- ! Regrid preipitation mixing-ratios to statistical grid.
- !allocate(tempStatGrid(nPoints,ncol,Nlvgrid))
- !tempStatGrid(:,:,:,:) = 0._wp
- !call cosp_change_vertical_grid(Npoints, ncol, pver, cospstateIN%hgt_matrix(:,pver:1:-1), &
- ! cospstateIN%hgt_matrix_half(:,pver:1:-1), mr_hydro(:,:,:,LSGRPL), &
- ! Nlvgrid,vgrid_zl(Nlvgrid:1:-1), vgrid_zu(Nlvgrid:1:-1), tempStatGrid)
- !
endif
call t_stopf("cloudsat_optics")
@@ -3228,7 +2756,8 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap,
MODIS_snowSize(nPoints,nColumns,nLevels), &
MODIS_opticalThicknessLiq(nPoints,nColumns,nLevels), &
MODIS_opticalThicknessIce(nPoints,nColumns,nLevels), &
- MODIS_opticalThicknessSnow(nPoints,nColumns,nLevels))
+ MODIS_opticalThicknessSnow(nPoints,nColumns,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'MODIS_*')
! Cloud water
call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, &
@@ -3284,6 +2813,11 @@ subroutine construct_cospIN(npoints,ncolumns,nlevels,y)
nlevels ! Number of vertical levels
! Outputs
type(cosp_optical_inputs),intent(out) :: y
+
+ ! local
+ integer :: istat
+ character(len=*), parameter :: sub = 'construct_cospIN'
+ !--------------------------------------------------------------------------------------
! Dimensions
y%Npoints = Npoints
@@ -3311,7 +2845,9 @@ subroutine construct_cospIN(npoints,ncolumns,nlevels,y)
y%tau_mol_calipso( npoints, nlevels),&
y%tautot_S_ice( npoints, ncolumns ),&
y%tautot_S_liq( npoints, ncolumns) ,&
- y%fracPrecipIce(npoints, ncolumns))
+ y%fracPrecipIce(npoints, ncolumns), stat=istat)
+ call handle_allocate_error(istat, sub, 'tau_067,..,fracPrecipIce')
+
end subroutine construct_cospIN
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -3324,15 +2860,37 @@ subroutine construct_cospstateIN(npoints,nlevels,nchan,y)
nlevels, & ! Number of vertical levels
nchan ! Number of channels
! Outputs
- type(cosp_column_inputs),intent(out) :: y
-
- allocate(y%sunlit(npoints),y%skt(npoints),y%land(npoints),y%at(npoints,nlevels), &
- y%pfull(npoints,nlevels),y%phalf(npoints,nlevels+1),y%qv(npoints,nlevels), &
- y%o3(npoints,nlevels),y%hgt_matrix(npoints,nlevels),y%u_sfc(npoints), &
- y%v_sfc(npoints),y%lat(npoints),y%lon(nPoints),y%emis_sfc(nchan), &
- y%cloudIce(nPoints,nLevels),y%cloudLiq(nPoints,nLevels),y%surfelev(nPoints),&
- y%fl_snow(nPoints,nLevels),y%fl_rain(nPoints,nLevels),y%seaice(npoints), &
- y%tca(nPoints,nLevels),y%hgt_matrix_half(npoints,nlevels+1))
+ type(cosp_column_inputs),intent(out) :: y
+
+ ! local
+ integer :: istat
+ character(len=*), parameter :: sub = 'construct_cospstateIN'
+ !--------------------------------------------------------------------------------------
+
+ allocate( &
+ y%sunlit(npoints), &
+ y%at(npoints,nlevels), &
+ y%pfull(npoints,nlevels), &
+ y%phalf(npoints,nlevels+1), &
+ y%qv(npoints,nlevels), &
+ y%hgt_matrix(npoints,nlevels), &
+ y%hgt_matrix_half(npoints,nlevels+1), &
+ y%land(npoints), &
+ y%skt(npoints), &
+ y%surfelev(nPoints), &
+ y%emis_sfc(nchan), &
+ y%u_sfc(npoints), &
+ y%v_sfc(npoints), &
+ y%seaice(npoints), &
+ y%lat(npoints), &
+ y%lon(nPoints), &
+ y%o3(npoints,nlevels), &
+ y%tca(nPoints,nLevels), &
+ y%cloudIce(nPoints,nLevels), &
+ y%cloudLiq(nPoints,nLevels), &
+ y%fl_rain(nPoints,nLevels), &
+ y%fl_snow(nPoints,nLevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'sunlit,..,fl_snow')
end subroutine construct_cospstateIN
! ######################################################################################
@@ -3340,106 +2898,114 @@ end subroutine construct_cospstateIN
!
! This subroutine allocates output fields based on input logical flag switches.
! ######################################################################################
- subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x)
+ subroutine construct_cosp_outputs(Npoints,Ncolumns,Nlevels,Nlvgrid,x)
! Inputs
integer,intent(in) :: &
Npoints, & ! Number of sampled points
Ncolumns, & ! Number of subgrid columns
Nlevels, & ! Number of model levels
- Nlvgrid, & ! Number of levels in L3 stats computation
- Nchan ! Number of RTTOV channels
+ Nlvgrid ! Number of levels in L3 stats computation
! Outputs
type(cosp_outputs),intent(out) :: &
x ! COSP output structure
+
+ ! local
+ integer :: istat
+ character(len=*), parameter :: sub = 'construct_cosp_outputs'
+ !--------------------------------------------------------------------------------------
! ISCCP simulator outputs
if (lisccp_sim) then
- allocate(x%isccp_boxtau(Npoints,Ncolumns))
- allocate(x%isccp_boxptop(Npoints,Ncolumns))
- allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins))
- allocate(x%isccp_totalcldarea(Npoints))
- allocate(x%isccp_meanptop(Npoints))
- allocate(x%isccp_meantaucld(Npoints))
- allocate(x%isccp_meantb(Npoints))
- allocate(x%isccp_meantbclr(Npoints))
- allocate(x%isccp_meanalbedocld(Npoints))
+ allocate( &
+ x%isccp_boxtau(Npoints,Ncolumns), &
+ x%isccp_boxptop(Npoints,Ncolumns), &
+ x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins), &
+ x%isccp_totalcldarea(Npoints), &
+ x%isccp_meanptop(Npoints), &
+ x%isccp_meantaucld(Npoints), &
+ x%isccp_meantb(Npoints), &
+ x%isccp_meantbclr(Npoints), &
+ x%isccp_meanalbedocld(Npoints), stat=istat)
+ call handle_allocate_error(istat, sub, 'isccp_*')
endif
! MISR simulator
if (lmisr_sim) then
- allocate(x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins))
- ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so
- ! they are still computed. Should probably have a logical to control these
- ! outputs.
- allocate(x%misr_dist_model_layertops(Npoints,numMISRHgtBins))
- allocate(x%misr_meanztop(Npoints))
- allocate(x%misr_cldarea(Npoints))
+ allocate( &
+ x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins), &
+ ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so
+ ! they are still computed. Should probably have a logical to control these
+ ! outputs.
+ x%misr_dist_model_layertops(Npoints,numMISRHgtBins), &
+ x%misr_meanztop(Npoints), &
+ x%misr_cldarea(Npoints), stat=istat)
+ call handle_allocate_error(istat, sub, 'misr_*')
endif
! MODIS simulator
if (lmodis_sim) then
- allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints))
- allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints))
- allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints))
- allocate(x%modis_Cloud_Fraction_High_Mean(Npoints))
- allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints))
- allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints))
- allocate(x%modis_Optical_Thickness_Total_Mean(Npoints))
- allocate(x%modis_Optical_Thickness_Water_Mean(Npoints))
- allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints))
- allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints))
- allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints))
- allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints))
- allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints))
- allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints))
- allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints))
- allocate(x%modis_Liquid_Water_Path_Mean(Npoints))
- allocate(x%modis_Ice_Water_Path_Mean(Npoints))
- allocate(x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins))
- allocate(x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins))
- allocate(x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins))
+ allocate( &
+ x%modis_Cloud_Fraction_Total_Mean(Npoints), &
+ x%modis_Cloud_Fraction_Water_Mean(Npoints), &
+ x%modis_Cloud_Fraction_Ice_Mean(Npoints), &
+ x%modis_Cloud_Fraction_High_Mean(Npoints), &
+ x%modis_Cloud_Fraction_Mid_Mean(Npoints), &
+ x%modis_Cloud_Fraction_Low_Mean(Npoints), &
+ x%modis_Optical_Thickness_Total_Mean(Npoints), &
+ x%modis_Optical_Thickness_Water_Mean(Npoints), &
+ x%modis_Optical_Thickness_Ice_Mean(Npoints), &
+ x%modis_Optical_Thickness_Total_LogMean(Npoints), &
+ x%modis_Optical_Thickness_Water_LogMean(Npoints), &
+ x%modis_Optical_Thickness_Ice_LogMean(Npoints), &
+ x%modis_Cloud_Particle_Size_Water_Mean(Npoints), &
+ x%modis_Cloud_Particle_Size_Ice_Mean(Npoints), &
+ x%modis_Cloud_Top_Pressure_Total_Mean(Npoints), &
+ x%modis_Liquid_Water_Path_Mean(Npoints), &
+ x%modis_Ice_Water_Path_Mean(Npoints), &
+ x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins), &
+ x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins), &
+ x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins), &
+ stat=istat)
+ call handle_allocate_error(istat, sub, 'modis_*')
endif
! CALIPSO simulator
if (llidar_sim) then
- allocate(x%calipso_beta_mol(Npoints,Nlevels))
- allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels))
- allocate(x%calipso_srbval(SR_BINS+1))
- allocate(x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid))
- allocate(x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels))
- allocate(x%calipso_lidarcld(Npoints,Nlvgrid))
- allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT))
- allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6))
- allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5))
- allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6))
- ! These 2 outputs are part of the calipso output type, but are not controlled by an
- ! logical switch in the output namelist, so if all other fields are on, then allocate
- allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels))
- allocate(x%calipso_temp_tot(Npoints,Nlevels))
- ! Calipso opaque cloud diagnostics
-! allocate(x%calipso_cldtype(Npoints,LIDAR_NTYPE))
-! allocate(x%calipso_cldtypetemp(Npoints,LIDAR_NTYPE))
-! allocate(x%calipso_cldtypemeanz(Npoints,2))
-! allocate(x%calipso_cldtypemeanzse(Npoints,3))
-! allocate(x%calipso_cldthinemis(Npoints))
-! allocate(x%calipso_lidarcldtype(Npoints,Nlvgrid,LIDAR_NTYPE+1))
+ allocate( &
+ x%calipso_beta_mol(Npoints,Nlevels), &
+ x%calipso_beta_tot(Npoints,Ncolumns,Nlevels), &
+ x%calipso_srbval(SR_BINS+1), &
+ x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid), &
+ x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels), &
+ x%calipso_lidarcld(Npoints,Nlvgrid), &
+ x%calipso_cldlayer(Npoints,LIDAR_NCAT), &
+ x%calipso_lidarcldphase(Npoints,Nlvgrid,6), &
+ x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5), &
+ x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6), &
+ x%calipso_tau_tot(Npoints,Ncolumns,Nlevels), &
+ x%calipso_temp_tot(Npoints,Nlevels), stat=istat)
+ call handle_allocate_error(istat, sub, 'calipso_*')
endif
! PARASOL
if (lparasol_sim) then
- allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL))
- allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL))
+ allocate( &
+ x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL), &
+ x%parasolGrid_refl(Npoints,PARASOL_NREFL), stat=istat)
+ call handle_allocate_error(istat, sub, 'parasol*')
endif
! Cloudsat simulator
if (lradar_sim) then
- allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels))
- allocate(x%cloudsat_cfad_ze(Npoints,CLOUDSAT_DBZE_BINS,Nlvgrid))
- allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid))
- allocate(x%radar_lidar_tcc(Npoints))
- allocate(x%cloudsat_precip_cover(Npoints,nCloudsatPrecipClass))
- allocate(x%cloudsat_pia(Npoints))
+ allocate( &
+ x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels), &
+ x%cloudsat_cfad_ze(Npoints,CLOUDSAT_DBZE_BINS,Nlvgrid), &
+ x%lidar_only_freq_cloud(Npoints,Nlvgrid), &
+ x%radar_lidar_tcc(Npoints), &
+ x%cloudsat_precip_cover(Npoints,nCloudsatPrecipClass), &
+ x%cloudsat_pia(Npoints), stat=istat)
+ call handle_allocate_error(istat, sub, 'cloudsat*')
endif
end subroutine construct_cosp_outputs
diff --git a/src/physics/cam/gw_drag.F90 b/src/physics/cam/gw_drag.F90
index 0f48e661af..f8eca5dd1f 100644
--- a/src/physics/cam/gw_drag.F90
+++ b/src/physics/cam/gw_drag.F90
@@ -1396,7 +1396,7 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat)
call physics_state_copy(state, state1)
! constituents are all treated as wet mmr
- call set_dry_to_wet(state1)
+ call set_dry_to_wet(state1, convert_cnst_type='dry')
lchnk = state1%lchnk
ncol = state1%ncol
diff --git a/src/physics/cam/nucleate_ice_cam.F90 b/src/physics/cam/nucleate_ice_cam.F90
index 922e871b72..7d03297688 100644
--- a/src/physics/cam/nucleate_ice_cam.F90
+++ b/src/physics/cam/nucleate_ice_cam.F90
@@ -261,7 +261,7 @@ subroutine nucleate_ice_cam_init(mincld_in, bulk_scale_in, pbuf2d, aero_props)
call endrun(routine//': ERROR qsatfac is required when subgrid = -1 or subgrid_strat = -1')
end if
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! Updates for PUMAS v1.21+
call addfld('NIHFTEN', (/ 'lev' /), 'A', '1/m3/s', 'Activated Ice Number Concentration tendency due to homogenous freezing')
call addfld('NIDEPTEN', (/ 'lev' /), 'A', '1/m3/s', 'Activated Ice Number Concentration tendency due to deposition nucleation')
@@ -286,7 +286,7 @@ subroutine nucleate_ice_cam_init(mincld_in, bulk_scale_in, pbuf2d, aero_props)
call addfld ('WICE', (/ 'lev' /), 'A','m/s','Vertical velocity Reduction caused by preexisting ice' )
call addfld ('WEFF', (/ 'lev' /), 'A','m/s','Effective Vertical velocity for ice nucleation' )
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! Updates for PUMAS v1.21+
call addfld ('INnso4TEN', (/ 'lev' /), 'A','1/m3/s','Number Concentration tendency so4 (in) to ice_nucleation')
call addfld ('INnbcTEN', (/ 'lev' /), 'A','1/m3/s','Number Concentration tendency bc (in) to ice_nucleation')
@@ -627,7 +627,7 @@ subroutine nucleate_ice_cam_calc( &
! *** Turn off soot nucleation ***
soot_num = 0.0_r8
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
call nucleati( &
wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), &
@@ -768,7 +768,7 @@ subroutine nucleate_ice_cam_calc( &
end if
end if
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
!Updates for pumas v1.21+
naai_hom(i,k) = nihf(i,k)/dtime
@@ -808,7 +808,7 @@ subroutine nucleate_ice_cam_calc( &
endif
endif
- else ! Not cam_dev
+ else ! Not cam7
naai_hom(i,k) = nihf(i,k)
@@ -846,7 +846,7 @@ subroutine nucleate_ice_cam_calc( &
endif
end if
- end if ! cam_dev
+ end if ! cam7
end if freezing
end do iloop
end do kloop
@@ -857,7 +857,7 @@ subroutine nucleate_ice_cam_calc( &
maerosol)
end if
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! Updates for PUMAS v1.21+
call outfld('NIHFTEN', nihf, pcols, lchnk)
call outfld('NIIMMTEN', niimm, pcols, lchnk)
@@ -877,7 +877,7 @@ subroutine nucleate_ice_cam_calc( &
call outfld( 'fhom' , fhom, pcols, lchnk)
call outfld( 'WICE' , wice, pcols, lchnk)
call outfld( 'WEFF' , weff, pcols, lchnk)
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! Updates for PUMAS v1.21+
call outfld('INnso4TEN',INnso4 , pcols,lchnk)
call outfld('INnbcTEN',INnbc , pcols,lchnk)
diff --git a/src/physics/cam/phys_control.F90 b/src/physics/cam/phys_control.F90
index 92ccac1335..1de052c318 100644
--- a/src/physics/cam/phys_control.F90
+++ b/src/physics/cam/phys_control.F90
@@ -242,21 +242,21 @@ subroutine phys_ctl_readnl(nlfile)
endif
endif
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! Check that eddy_scheme, macrop_scheme, shallow_scheme are all set to CLUBB
if (eddy_scheme /= 'CLUBB_SGS' .or. macrop_scheme /= 'CLUBB_SGS' .or. shallow_scheme /= 'CLUBB_SGS') then
- write(iulog,*) 'cam_dev is only compatible with CLUBB. Quitting'
- call endrun('cam_dev is only compatible with eddy, macrop, and shallow schemes = CLUBB_SGS')
+ write(iulog,*) 'cam7 is only compatible with CLUBB. Quitting'
+ call endrun('cam7 is only compatible with eddy, macrop, and shallow schemes = CLUBB_SGS')
end if
! Add a check to make sure SPCAM is not used
if (use_spcam) then
- write(iulog,*)'SPCAM not compatible with cam_dev physics. Quitting'
- call endrun('SPCAM and cam_dev incompatible')
+ write(iulog,*)'SPCAM not compatible with cam7 physics. Quitting'
+ call endrun('SPCAM and cam7 incompatible')
end if
! Add check to make sure we are not trying to use `camrt`
if (trim(radiation_scheme) == 'camrt') then
- write(iulog,*) ' camrt specified and it is not compatible with cam_dev'
- call endrun('cam_dev is not compatible with camrt radiation scheme')
+ write(iulog,*) ' camrt specified and it is not compatible with cam7'
+ call endrun('cam7 is not compatible with camrt radiation scheme')
end if
end if
diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90
index 9b0c23d2ff..03f8022fa8 100644
--- a/src/physics/cam/physics_types.F90
+++ b/src/physics/cam/physics_types.F90
@@ -1481,40 +1481,72 @@ end subroutine set_state_pdry
!===============================================================================
-subroutine set_wet_to_dry (state)
+subroutine set_wet_to_dry(state, convert_cnst_type)
+
+ ! Convert mixing ratios from a wet to dry basis for constituents of type
+ ! convert_cnst_type. Constituents are given a type when they are added
+ ! to the constituent array by a call to cnst_add during the register
+ ! phase of initialization. There are two constituent types: 'wet' for
+ ! water species and 'dry' for non-water species.
use constituents, only: pcnst, cnst_type
type(physics_state), intent(inout) :: state
+ character(len=3), intent(in) :: convert_cnst_type
+ ! local variables
integer m, ncol
+ character(len=*), parameter :: sub = 'set_wet_to_dry'
+ !-----------------------------------------------------------------------------
+
+ ! check input
+ if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
+ write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
+ call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
+ end if
ncol = state%ncol
- do m = 1,pcnst
- if (cnst_type(m).eq.'dry') then
+ do m = 1, pcnst
+ if (cnst_type(m) == convert_cnst_type) then
state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:)
- endif
+ end if
end do
end subroutine set_wet_to_dry
!===============================================================================
-subroutine set_dry_to_wet (state)
+subroutine set_dry_to_wet(state, convert_cnst_type)
+
+ ! Convert mixing ratios from a dry to wet basis for constituents of type
+ ! convert_cnst_type. Constituents are given a type when they are added
+ ! to the constituent array by a call to cnst_add during the register
+ ! phase of initialization. There are two constituent types: 'wet' for
+ ! water species and 'dry' for non-water species.
use constituents, only: pcnst, cnst_type
type(physics_state), intent(inout) :: state
+ character(len=3), intent(in) :: convert_cnst_type
+ ! local variables
integer m, ncol
+ character(len=*), parameter :: sub = 'set_dry_to_wet'
+ !-----------------------------------------------------------------------------
+
+ ! check input
+ if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
+ write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
+ call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
+ end if
ncol = state%ncol
- do m = 1,pcnst
- if (cnst_type(m).eq.'dry') then
+ do m = 1, pcnst
+ if (cnst_type(m) == convert_cnst_type) then
state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:)
- endif
+ end if
end do
end subroutine set_dry_to_wet
diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90
index 1ae79aa016..0aed2c9650 100644
--- a/src/physics/cam/physpkg.F90
+++ b/src/physics/cam/physpkg.F90
@@ -1946,7 +1946,7 @@ subroutine tphysac (ztodt, cam_in, &
!
! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call
!
- call set_dry_to_wet(state)
+ call set_dry_to_wet(state, convert_cnst_type='dry')
if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then
call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,&
diff --git a/src/physics/cam/ref_pres.F90 b/src/physics/cam/ref_pres.F90
index f0d5994b81..1630072d3e 100644
--- a/src/physics/cam/ref_pres.F90
+++ b/src/physics/cam/ref_pres.F90
@@ -11,8 +11,11 @@ module ref_pres
!
!--------------------------------------------------------------------------
-use shr_kind_mod, only: r8=>shr_kind_r8
-use ppgrid, only: pver, pverp
+use shr_kind_mod, only: r8=>shr_kind_r8
+use ppgrid, only: pver, pverp
+use cam_history_support, only: add_vert_coord
+use cam_logfile, only: iulog
+use error_messages, only: alloc_err
implicit none
public
@@ -49,6 +52,11 @@ module ref_pres
logical, protected :: do_molec_diff = .false.
integer, protected :: nbot_molec = 0
+! Data for the trop_pref coordinate. It is the target of a pointer in a hist_coord_t
+! object in the cam_history_support module. It is associated by the call to add_vert_coord.
+real(r8), private, allocatable, target :: trop_pref(:)
+real(r8), private, allocatable, target :: trop_prefi(:)
+
!====================================================================================
contains
!====================================================================================
@@ -111,6 +119,11 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in)
real(r8), intent(in) :: pref_edge_in(:) ! reference pressure at layer edges (Pa)
real(r8), intent(in) :: pref_mid_in(:) ! reference pressure at layer midpoints (Pa)
integer, intent(in) :: num_pr_lev_in ! number of top levels using pure pressure representation
+
+ ! local variables
+ integer :: nlev
+ integer :: istat
+ character(len=*), parameter :: sub = 'ref_pres_init'
!---------------------------------------------------------------------------
pref_edge = pref_edge_in
@@ -137,6 +150,24 @@ subroutine ref_pres_init(pref_edge_in, pref_mid_in, num_pr_lev_in)
top=.false.)
end if
+ ! Add vertical coordinates to history file for use with outputs that are only
+ ! computed in the subdomain bounded by the top of troposphere clouds.
+ nlev = pver - trop_cloud_top_lev + 1
+
+ allocate(trop_pref(nlev), stat=istat)
+ call alloc_err(istat, sub, 'trop_pref', nlev)
+ trop_pref = pref_mid(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa
+
+ call add_vert_coord('trop_pref', nlev, 'troposphere reference pressures', &
+ 'hPa', trop_pref, positive='down')
+
+ allocate(trop_prefi(nlev+1), stat=istat)
+ call alloc_err(istat, sub, 'trop_prefi', nlev+1)
+ trop_prefi = pref_edge(trop_cloud_top_lev:)*0.01_r8 ! convert Pa to hPa
+
+ call add_vert_coord('trop_prefi', nlev+1, 'troposphere reference pressures (interfaces)', &
+ 'hPa', trop_prefi, positive='down')
+
end subroutine ref_pres_init
!====================================================================================
diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90
index 12c50b4234..507e99dc8d 100644
--- a/src/physics/cam/vertical_diffusion.F90
+++ b/src/physics/cam/vertical_diffusion.F90
@@ -449,7 +449,7 @@ subroutine vertical_diffusion_init(pbuf2d)
do_pbl_diags = .true.
call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, karman, eddy_scheme)
!
- ! run HB scheme where CLUBB is not active when running cam_dev or cam6 physics
+ ! run HB scheme where CLUBB is not active when running cam7 or cam6 physics
! else init_hb_diff is called just for diagnostic purposes
!
if (do_hb_above_clubb) then
@@ -911,7 +911,7 @@ subroutine vertical_diffusion_tend( &
! ----------------------- !
! Assume 'wet' mixing ratios in diffusion code.
- call set_dry_to_wet(state)
+ call set_dry_to_wet(state, convert_cnst_type='dry')
rztodt = 1._r8 / ztodt
lchnk = state%lchnk
@@ -1057,7 +1057,7 @@ subroutine vertical_diffusion_tend( &
case ( 'CLUBB_SGS' )
!
- ! run HB scheme where CLUBB is not active when running cam_dev
+ ! run HB scheme where CLUBB is not active when running cam7
!
if (do_hb_above_clubb) then
call compute_hb_free_atm_diff( ncol , &
@@ -1194,7 +1194,7 @@ subroutine vertical_diffusion_tend( &
tauy = 0._r8
shflux = 0._r8
cflux(:,1) = 0._r8
- if (cam_physpkg_is("cam_dev")) then
+ if (cam_physpkg_is("cam7")) then
! surface fluxes applied in clubb emissions module
cflux(:,2:) = 0._r8
else
@@ -1384,7 +1384,7 @@ subroutine vertical_diffusion_tend( &
endif
end do
! convert wet mmr back to dry before conservation check
- call set_wet_to_dry(state)
+ call set_wet_to_dry(state, convert_cnst_type='dry')
if (.not. do_pbl_diags) then
slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt
@@ -1554,7 +1554,7 @@ subroutine vertical_diffusion_tend( &
call outfld( 'KVT' , kvt, pcols, lchnk )
call outfld( 'KVM' , kvm, pcols, lchnk )
call outfld( 'CGS' , cgs, pcols, lchnk )
- dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history
+ dtk(:ncol,:) = dtk(:ncol,:) / cpair / ztodt ! Normalize heating for history
call outfld( 'DTVKE' , dtk, pcols, lchnk )
dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk
call outfld( 'DTV' , dtk, pcols, lchnk )
diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90
index febf576443..b80fcf504d 100644
--- a/src/physics/cam/zm_conv_intr.F90
+++ b/src/physics/cam/zm_conv_intr.F90
@@ -17,7 +17,6 @@ module zm_conv_intr
use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, &
rad_cnst_get_aer_props, rad_cnst_get_mode_props !, &
- use ndrop_bam, only: ndrop_bam_init
use cam_abortutils, only: endrun
use physconst, only: pi
use spmd_utils, only: masterproc
@@ -248,6 +247,12 @@ subroutine zm_conv_init(pref_edge)
real(r8),intent(in) :: pref_edge(plevp) ! reference pressures at interfaces
+ ! local variables
+ real(r8), parameter :: scale_height = 7000._r8 ! std atm scale height (m)
+ real(r8), parameter :: dz_min = 100._r8 ! minimum thickness for using
+ ! zmconv_parcel_pbl=.false.
+ real(r8) :: dz_bot_layer ! thickness of bottom layer (m)
+
character(len=512) :: errmsg
integer :: errflg
@@ -351,6 +356,19 @@ subroutine zm_conv_init(pref_edge)
' which is ',pref_edge(limcnv),' pascals'
end if
+ ! If thickness of bottom layer is less than dz_min, and zmconv_parcel_pbl=.false.,
+ ! then issue a warning.
+ dz_bot_layer = scale_height * log(pref_edge(pverp)/pref_edge(pver))
+ if (dz_bot_layer < dz_min .and. .not. zmconv_parcel_pbl) then
+ if (masterproc) then
+ write(iulog,*)'********** WARNING **********'
+ write(iulog,*)' ZM_CONV_INIT: Bottom layer thickness (m) is ', dz_bot_layer
+ write(iulog,*)' The namelist variable zmconv_parcel_pbl should be set to .true.'
+ write(iulog,*)' when the bottom layer thickness is < ', dz_min
+ write(iulog,*)'********** WARNING **********'
+ end if
+ end if
+
no_deep_pbl = phys_deepconv_pbl()
!CACNOTE - Need to check errflg and report errors
call zm_convr_init(cpair, epsilo, gravit, latvap, tmelt, rair, &
diff --git a/src/physics/cam_dev/cam_snapshot.F90 b/src/physics/cam7/cam_snapshot.F90
similarity index 100%
rename from src/physics/cam_dev/cam_snapshot.F90
rename to src/physics/cam7/cam_snapshot.F90
diff --git a/src/physics/cam_dev/convect_diagnostics.F90 b/src/physics/cam7/convect_diagnostics.F90
similarity index 100%
rename from src/physics/cam_dev/convect_diagnostics.F90
rename to src/physics/cam7/convect_diagnostics.F90
diff --git a/src/physics/cam_dev/micro_pumas_cam.F90 b/src/physics/cam7/micro_pumas_cam.F90
similarity index 100%
rename from src/physics/cam_dev/micro_pumas_cam.F90
rename to src/physics/cam7/micro_pumas_cam.F90
diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam7/physpkg.F90
similarity index 99%
rename from src/physics/cam_dev/physpkg.F90
rename to src/physics/cam7/physpkg.F90
index 3838fc1590..d04cf6197c 100644
--- a/src/physics/cam_dev/physpkg.F90
+++ b/src/physics/cam7/physpkg.F90
@@ -2393,7 +2393,7 @@ subroutine tphysac (ztodt, cam_in, &
!
! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call
!
- call set_dry_to_wet(state)
+ call set_dry_to_wet(state, convert_cnst_type='dry')
if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then
call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,&
diff --git a/src/physics/cam_dev/stochastic_emulated_cam.F90 b/src/physics/cam7/stochastic_emulated_cam.F90
similarity index 100%
rename from src/physics/cam_dev/stochastic_emulated_cam.F90
rename to src/physics/cam7/stochastic_emulated_cam.F90
diff --git a/src/physics/cam_dev/stochastic_tau_cam.F90 b/src/physics/cam7/stochastic_tau_cam.F90
similarity index 100%
rename from src/physics/cam_dev/stochastic_tau_cam.F90
rename to src/physics/cam7/stochastic_tau_cam.F90
diff --git a/src/physics/carma/cam/carma_intr.F90 b/src/physics/carma/cam/carma_intr.F90
index ec935e29b4..03d7ca5fab 100644
--- a/src/physics/carma/cam/carma_intr.F90
+++ b/src/physics/carma/cam/carma_intr.F90
@@ -1036,7 +1036,7 @@ subroutine carma_timestep_tend(state, cam_in, cam_out, ptend, dt, pbuf, dlf, rli
! The CARMA interface assumes that mass mixing ratios are relative to a
! wet atmosphere, so convert any dry mass mixing ratios to wet.
call physics_state_copy(state, state_loc)
- call set_dry_to_wet(state_loc)
+ call set_dry_to_wet(state_loc, convert_cnst_type='dry')
spdiags(:, :, :) = 0.0_r8
gpdiags(:, :, :, :) = 0.0_r8
diff --git a/src/physics/carma/models/cirrus/carma_cloudfraction.F90 b/src/physics/carma/models/cirrus/carma_cloudfraction.F90
index 88be7373bb..0ec202041f 100644
--- a/src/physics/carma/models/cirrus/carma_cloudfraction.F90
+++ b/src/physics/carma/models/cirrus/carma_cloudfraction.F90
@@ -24,8 +24,7 @@ subroutine CARMA_CloudFraction(carma, cstate, cam_in, state, icol, cldfrc, rhcri
use carma_mod
use shr_kind_mod, only: r8 => shr_kind_r8
- use physics_types, only: physics_state, physics_ptend, set_wet_to_dry, &
- set_dry_to_wet
+ use physics_types, only: physics_state, physics_ptend
use constituents, only: cnst_get_ind
use cam_abortutils, only: endrun
diff --git a/src/physics/carma/models/cirrus_dust/carma_cloudfraction.F90 b/src/physics/carma/models/cirrus_dust/carma_cloudfraction.F90
index 88be7373bb..0ec202041f 100644
--- a/src/physics/carma/models/cirrus_dust/carma_cloudfraction.F90
+++ b/src/physics/carma/models/cirrus_dust/carma_cloudfraction.F90
@@ -24,8 +24,7 @@ subroutine CARMA_CloudFraction(carma, cstate, cam_in, state, icol, cldfrc, rhcri
use carma_mod
use shr_kind_mod, only: r8 => shr_kind_r8
- use physics_types, only: physics_state, physics_ptend, set_wet_to_dry, &
- set_dry_to_wet
+ use physics_types, only: physics_state, physics_ptend
use constituents, only: cnst_get_ind
use cam_abortutils, only: endrun
diff --git a/src/physics/simple/physpkg.F90 b/src/physics/simple/physpkg.F90
index a296fd2fdb..8c9c1586ef 100644
--- a/src/physics/simple/physpkg.F90
+++ b/src/physics/simple/physpkg.F90
@@ -654,7 +654,7 @@ subroutine tphysac (ztodt, cam_in, cam_out, state, tend, pbuf)
!
! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call
!
- call set_dry_to_wet(state)
+ call set_dry_to_wet(state, convert_cnst_type='dry')
call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt)
call tot_energy_phys(state, 'phAM')
call tot_energy_phys(state, 'dyAM', vc=vc_dycore)
diff --git a/src/physics/waccmx/ion_electron_temp.F90 b/src/physics/waccmx/ion_electron_temp.F90
index e272b9aaa0..3e5718eaa4 100644
--- a/src/physics/waccmx/ion_electron_temp.F90
+++ b/src/physics/waccmx/ion_electron_temp.F90
@@ -34,6 +34,7 @@ module ion_electron_temp
use spmd_utils, only : masterproc
use cam_logfile, only : iulog ! Output unit
use ionos_state_mod, only : ionos_state
+ use air_composition,only : cpairv
implicit none
@@ -135,16 +136,16 @@ subroutine ion_electron_temp_init(pbuf2d)
!-------------------------------------------------------------------------------
! Add history variables for ionosphere
!-------------------------------------------------------------------------------
- call addfld ('QIonElec' ,(/ 'lev' /), 'I', 'K/s', 'Electron Ion Thermal Heating Rate')
+ call addfld ('QIonElec' ,(/ 'lev' /), 'I', 'K sec-1', 'Electron Ion Thermal Heating Rate')
call addfld ('TElec&IC' ,(/ 'lev' /), 'I', 'K', 'Electron Temperature')
call addfld ('TIon&IC' ,(/ 'lev' /), 'I', 'K', 'Ion Temperature')
call addfld ('TElec' ,(/ 'lev' /), 'I', 'K', 'Electron Temperature')
call addfld ('TIon' ,(/ 'lev' /), 'I', 'K', 'Ion Temperature')
call addfld ('ElecColDens' ,horiz_only , 'I', 'TECU', 'Electron Column Density')
if (.not.steady_state_ion_elec_temp) then
- call addfld ('QIN' ,(/ 'lev' /), 'I', 'J/kg/s', 'Ion-neutral Heating')
- call addfld ('QEN' ,(/ 'lev' /), 'I', ' ', 'Electron-neutral Heating')
- call addfld ('QEI' ,(/ 'lev' /), 'I', ' ', 'Electron-ion Heating')
+ call addfld ('QIN' ,(/ 'lev' /), 'I', 'K sec-1','Ion-neutral Heating Rate')
+ call addfld ('QEN' ,(/ 'lev' /), 'I', 'K sec-1','Electron-neutral Heating Rate')
+ call addfld ('QEI' ,(/ 'lev' /), 'I', 'K sec-1','Electron-ion Heating Rate')
call addfld ('LOSS_g3' ,(/ 'lev' /), 'I', ' ', 'Loss Term g3')
call addfld ('LOSS_EI' ,(/ 'lev' /), 'I', ' ', 'Loss Term EI')
call addfld ('LOSS_IN' ,(/ 'lev' /), 'I', ' ', 'Loss Term IN')
@@ -334,7 +335,6 @@ end subroutine ion_electron_temp_inidat
subroutine ion_electron_temp_tend(state, ptend, pbuf, ztodt)
- use air_composition, only: cpairv
!-------------------------------------------------------------------------------------
! Calculate dry static energy and O+ tendency for extended ionosphere simulation
!-------------------------------------------------------------------------------------
@@ -1037,9 +1037,9 @@ subroutine update_teti(state, dSETendIn, dSETendOut, ztodt, istate, tE, tI, teTi
real(r8), dimension(pcols,pver) :: delZ ! Delta z: midpoints
real(r8), dimension(pcols,pver) :: qjoule ! joule heating
- real(r8), dimension(pcols,pver) :: qen ! electron-neutral heating
- real(r8), dimension(pcols,pver) :: qei ! electron-ion Coulomb heating
- real(r8), dimension(pcols,pver) :: qin ! ion-neutral heating
+ real(r8), dimension(pcols,pver) :: qen ! electron-neutral heating (units: ev/g/s)
+ real(r8), dimension(pcols,pver) :: qei ! electron-ion Coulomb heating (units: ev/g/s)
+ real(r8), dimension(pcols,pver) :: qin ! ion-neutral heating (units: ev/g/s)
real(r8), dimension(pcols,pver) :: rho ! mass density
real(r8), dimension(pcols,pver) :: wrk2
@@ -1053,6 +1053,7 @@ subroutine update_teti(state, dSETendIn, dSETendOut, ztodt, istate, tE, tI, teTi
logical, dimension(pcols) :: colConv ! flag for column converging
logical :: converged ! Flag for convergence in electron temperature
! calculation iteration loop
+ real(r8) :: qrate(pcols,pver) ! heating rate diagnostic
!---------------------------------------------------------------------------------------------------------
! Initialize arrays to zero and column convergence logical to .false.
@@ -1452,9 +1453,14 @@ subroutine update_teti(state, dSETendIn, dSETendOut, ztodt, istate, tE, tI, teTi
dSETendOut(1:ncol,1:teTiBot) = (qei(1:ncol,1:teTiBot)+qen(1:ncol,1:teTiBot)) / sToQConv ! J/kg/s
- call outfld ('QEN', qen, pcols, lchnk)
- call outfld ('QEI', qei, pcols, lchnk)
- call outfld ('QIN', qin, pcols, lchnk)
+ qrate(:ncol,:) = qen(:ncol,:)/sToQConv/cpairv(:ncol,:,lchnk) ! K/s
+ call outfld ('QEN', qrate, pcols, lchnk)
+
+ qrate(:ncol,:) = qei(:ncol,:)/sToQConv/cpairv(:ncol,:,lchnk) ! K/s
+ call outfld ('QEI', qrate, pcols, lchnk)
+
+ qrate(:ncol,:) = qin(:ncol,:)/sToQConv/cpairv(:ncol,:,lchnk) ! K/s
+ call outfld ('QIN', qrate, pcols, lchnk)
return
diff --git a/src/utils/hycoef.F90 b/src/utils/hycoef.F90
index 378f6896c3..455875edee 100644
--- a/src/utils/hycoef.F90
+++ b/src/utils/hycoef.F90
@@ -22,6 +22,10 @@ module hycoef
! interfaces p(k) = hyai(k)*ps0 + hybi(k)*ps
! midpoints p(k) = hyam(k)*ps0 + hybm(k)*ps
!
+! Note: Module data with a target attribute are targets of pointers in hist_coord_t
+! objects in the cam_history_support module. They are associated by the calls
+! to add_hist_coord and add_vert_coord
+!
!-----------------------------------------------------------------------
real(r8), public, target :: hyai(plevp) ! ps0 component of hybrid coordinate - interfaces
@@ -42,7 +46,7 @@ module hycoef
real(r8), public, protected :: ps0 = 1.0e5_r8 ! Base state surface pressure (pascals)
real(r8), public, protected :: psr = 1.0e5_r8 ! Reference surface pressure (pascals)
#endif
-real(r8), target :: alev(plev) ! level values (pascals) for 'lev' coord
+real(r8), target :: alev(plev) ! level values (hPa) for 'lev' coord
real(r8), target :: ailev(plevp) ! interface level values for 'ilev' coord
integer, public :: nprlev ! number of pure pressure levels at top
diff --git a/tools/definehires/Makefile b/tools/definehires/Makefile
deleted file mode 100644
index ef34446982..0000000000
--- a/tools/definehires/Makefile
+++ /dev/null
@@ -1,127 +0,0 @@
-# Makefile to build definesurf on various platforms
-# Note: If netcdf library is not built in the standard location, you must set the environment
-# variables INC_NETCDF and LIB_NETCDF
-
-EXEDIR = .
-EXENAME = definehires
-RM = rm
-
-.SUFFIXES:
-.SUFFIXES: .F90 .o
-
-# Check for the NetCDF library and include directories
-ifeq ($(LIB_NETCDF),$(null))
-LIB_NETCDF := /usr/local/lib
-endif
-
-ifeq ($(INC_NETCDF),$(null))
-INC_NETCDF := /usr/local/include
-endif
-
-# Determine platform
-UNAMES := $(shell uname -s)
-UNAMEM := $(findstring CRAY,$(shell uname -m))
-
-# Architecture-specific flags and rules
-#
-#------------------------------------------------------------------------
-# Cray
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMEM),CRAY)
-FC = f90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# SGI
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),IRIX64)
-FC = f90
-FFLAGS = -c -I$(INC_NETCDF) -64 -mips4 -bytereclen -s -r8
-LDFLAGS = -64 -L/usr/local/lib64/r4i4 -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# SUN
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),SunOS)
-FC = f90
-FFLAGS = -c -stackvar -f -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# AIX
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),AIX)
-FC = xlf90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) -qsuffix=f=F90 $<
-endif
-
-#------------------------------------------------------------------------
-# OSF1
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),OSF1)
-FC = f90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# Linux
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),Linux)
-ifeq ($(USER_FC),$(null))
-FC := pgf90
-FFLAGS = -c -I$(INC_NETCDF) -fast -r8 -byteswapio
-else
-FC := $(USER_FC)
-endif
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-
-ifeq ($(FC),lf95)
- FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF)
- ifeq ($(DEBUG),TRUE)
- #TBH: this works FFLAGS += -g --chk --pca
- #TBH: this FAILS FFLAGS += -g --chk a,e,s,u,x --pca
- FFLAGS += -g --chk a,e,s,u --pca
- else
- FFLAGS += -O
- endif
-endif
-
-.F90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# Default rules and macros
-#------------------------------------------------------------------------
-
-OBJS := gtopo30_to_10min.o shr_kind_mod.o
-
-$(EXEDIR)/$(EXENAME): $(OBJS)
- $(FC) -o $@ $(OBJS) $(LDFLAGS)
-
-clean:
- $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME)
-
-gtopo30_to_10min.o: shr_kind_mod.o
diff --git a/tools/definehires/README b/tools/definehires/README
deleted file mode 100644
index 5834c3961a..0000000000
--- a/tools/definehires/README
+++ /dev/null
@@ -1,114 +0,0 @@
-*** Lahey compiler note If you build definehires with lf95, you must
-*** execute with the -T runtime option, to get the proper byte
-*** ordering on input. Otherwise, you get nonsense. The GTOPO30 input
-*** files are binary, with "bigendian" ordering.
-*** definesurf -Wl,-T
-
-Running gnumake in this directory will create an executable named
-"definehires". Its function is to produce a 10-minute topography
-dataset from a USGS 30-second topographic dataset. The 30-second
-dataset contains only a height field. The 10-minute dataset contains
- height field, a binary land mask, and a fractional land mask.
-
-Ocean points are indicated in the 30-second dataset by a missing data
-flag and are assumed to have elevation 0m. However, the Caspian Sea
-is not flagged as ocean. The definehires program generates a Caspian
-Sea based on elevation, and reports these points as ocean while
-generating the 10-minute dataset. This is done through three calls to
-the new routine expand_sea.
-
-The 30-second dataset needed by definehires can be obtained from the
-following USGS web site:
-
-http://edcdaac.usgs.gov/gtopo30/gtopo30.asp
-
-For each tile in the dataset, both the *.DEM and *.HDR files must be
-present in the directory from which definehires is run. On NCAR
-machines, this may be accomplished by repeating the following snippet
-from a user csh or tcsh shell.
-
->> foreach temp ( /fs/cgd/csm/inputdata/atm/cam2/gtopo30data/* )
-foreach? ln -s $temp
-foreach? end
-
-Once the appropriate data files are in place, simply type:
-./definehires
-
-This will produce a new 10-minute high-resolution dataset named
-topo_gtopo30_10min.nc
-
-
-
--------------------------------------
-Feb 01, 2005
--------------------------------------
-
--------------------------------------
-*********** definehires *************
--------------------------------------
-
-The GTOPO30 30" is converted to a 10' dataset using definehires
- Originally by Jiundar Chern (jchern@dao.gsfc.nasa.gov),
- updated by Jim McCaa (jmccaa@ucar.edu)
- updated by B.A. Boville
-
-./definehires generates file "topo_gtopo30_10min.nc" containing 5 variables
- lon dimension variable of longitudes
- lat dimension variable of latitudes
- variance variance of 30" height w.r.t. 10' grid
- htopo average terrain height on 10' grid
- landfract land fraction on 10' grid,
- cells are either land or ocean on 30" grid
- Caspian sea is identified as ocean, but has nonzero height
-
-The original GTOPO30 files contain only elevation, with a flag for
-ocean points (NODATA=-9999). The Caspian Sea is not connected to the
-oceans and is not at sea level. Definehires identifies the Caspian Sea
-in the 30" data using an algorithm based on elevation. Therefore,
-the land fraction reflects the presence of the Caspian and the
-elevation is nonzero.
-
-method:
-
- Subroutine expand_sea is called 3 times, once for each GTOPO30 tile
- which contains part of the Caspian. The arguments include the x,y
- indices of a start point which is known to be in the Caspian. These
- 3 points had to identified by hand.
-
- 1. the start point is flagged by
- adding NODATA + NODATA to the original height
- setting a flag true for the block of surrounding points:
- (startx-1:startx+1,starty-1:starty+1)
-
- 2. find points with the same elevation as the start point and whose
- flag is true. Flag them the same way as the start point.
-
- This provides an expanding mask of potential Caspian points, which
- are flagged true, and an expanding region of actual Caspian points
- which are flagged with the original elavation + NODATA + NODATA.
-
- Subroutine avg is called to compute the area weighted average and
- land fraction of the 30" data with respect to the 10' grid. The
- weighting accounts for the area change with latitude. Points with
- elavation = NODATA are given elevation = 0 and land fraction =
- 0. Caspian points (elevation < NODATA) are given their original
- elevation (elevation - NODATA - NODATA) and land fraction = 0.
-
- The variance of the 30" height data with respect to the 10' average
- is computed without area weighting.
-
-Note on method. The Caspian terrain height flag is exact because the
-height is an integer. However, I would have preferred to
-
- Convert the height of ocean points from NODATA to ZERO and make a
- land fraction array with 0. or 1.. This could be done with a
- subroutine find_ocn.
-
- Then the Caspian points would retain their original elevations and
- also get land fraction 0 in find_caspian (instead of
- expand_sea). Still called for only the 3 tiles.
-
- Subroutine avg would not have to recognize anything special about
- Caspian points.
-
-
diff --git a/tools/definehires/gtopo30_to_10min.F90 b/tools/definehires/gtopo30_to_10min.F90
deleted file mode 100644
index 50ccae5c2e..0000000000
--- a/tools/definehires/gtopo30_to_10min.F90
+++ /dev/null
@@ -1,721 +0,0 @@
-!
-! DATE CODED: Oct 17, 2000
-! DESCRIPTION: This program reads USGS 30-sec terrain dataset in 33 tiles and converts
-! them to 10-min resolution global dataset in one single NetCDF file.
-!
-! Author: Jiundar Chern (jchern@dao.gsfc.nasa.gov)
-!
-! ** Modified November, 2003 ***
-! This code has been modified by Jim McCaa (jmccaa@ucar.edu) for use at NCAR.
-! In particular:
-! 1) Paths and compiler options have been changed.
-! 2) The code now generates a Caspian Sea based on elevation, and reports these points
-! as ocean. This is done through three calls to the new routine expand_sea.
-!
-! ** Modified February 4, 2005 B.A. Boville ***
-!
-! ROUTINES CALLED:
-! netcdf routines
-!
-! COMPILING:
-!
-! NCAR SGI (chinookfe) f90 -I/usr/local/include -O -64 -mips4 -bytereclen -s
-! -o gtopo30_to_10min gtopo30_to_10min.F90 -L/usr/local/lib64/r4i4 -lnetcdf -r8
-
-! NASA DAO SGI: f90 -I/ford1/local/IRIX64/netcdf/include -O -64 -mips4 -bytereclen -s
-! -o gtopo30_to_10min gtopo30_to_10min.F90 -L/ford1/local/IRIX64/netcdf/lib -lnetcdf -r8
-
- program convterr
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This program converts USGS 30-sec terrain data set to 10-min resolution
-! terrain data set.
-!
- implicit none
-!
- integer, parameter :: ntile = 33 ! number of tiles in USGS GTOPO30 dataset
- integer, parameter :: im10 = 2160 ! total grids in x direction of 10-min global dataset
- integer, parameter :: jm10 = 1080 ! total grids in y direction of 10-min global dataset
- real(r8), parameter :: dx30s = 1.0/120.0 ! space interval for 30-sec data (in degree)
- real(r8), parameter :: dx10m = 1.0/6.0 ! space interval for 10-min data (in degree)
-
- character (len=7) :: nmtile(ntile) ! name of each tile
- integer :: ncols,nrows ! number of columns and rows for 30-sec tile
- integer :: nodata ! integer for ocean point
- integer :: ncol10,nrow10 ! number of columns and rows for 10-min tile
- real(r8):: ulxmap ! longitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8):: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8):: lon1_10m ! longitude at the center of grid (1,1) in the 10-min global data
- real(r8):: lat1_10m ! latitude at the center of grid (1,1) in the 10-min global data
- real(r8):: lonsw10 ! longitude at the center of southwest corner cell in the 10-min tile
- real(r8):: latsw10 ! latitude at the center of southwest corner cell in the 10-min tile
- integer :: i1,j1 ! the (i,j) point of the southwest corner of the 10-min tile in the global grid
- real(r8), dimension(im10,jm10) :: terr ! global 10-min terrain data
- real(r8), dimension(im10,jm10) :: variance ! global 10-min variance of elevation
- real(r8), dimension(im10,jm10) :: land_fraction !global 10-min land fraction
-
- integer :: alloc_error,dealloc_error
- integer :: i,j,n ! index
- integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile
- real(r8), allocatable, dimension(:,:) :: terr10m ! terrain data for 10-min tile
- real(r8), allocatable, dimension(:,:) :: psea10m ! percentage of ocaen for 10-min tile
- real(r8), allocatable, dimension(:,:) :: var10m ! variance of 30-sec elevations for 10-min tile
-!
- lat1_10m=-90.0 + 0.5 * dx10m
- lon1_10m=0.5*dx10m
-!
-! Initialize each tile name
-!
- nmtile(1) = 'W180N90'
- nmtile(2) = 'W140N90'
- nmtile(3) = 'W100N90'
- nmtile(4) = 'W060N90'
- nmtile(5) = 'W020N90'
- nmtile(6) = 'E020N90'
- nmtile(7) = 'E060N90'
- nmtile(8) = 'E100N90'
- nmtile(9) = 'E140N90'
-
- nmtile(10) = 'W180N40'
- nmtile(11) = 'W140N40'
- nmtile(12) = 'W100N40'
- nmtile(13) = 'W060N40'
- nmtile(14) = 'W020N40'
- nmtile(15) = 'E020N40'
- nmtile(16) = 'E060N40'
- nmtile(17) = 'E100N40'
- nmtile(18) = 'E140N40'
-
- nmtile(19) = 'W180S10'
- nmtile(20) = 'W140S10'
- nmtile(21) = 'W100S10'
- nmtile(22) = 'W060S10'
- nmtile(23) = 'W020S10'
- nmtile(24) = 'E020S10'
- nmtile(25) = 'E060S10'
- nmtile(26) = 'E100S10'
- nmtile(27) = 'E140S10'
-
- nmtile(28) = 'W180S60'
- nmtile(29) = 'W120S60'
- nmtile(30) = 'W060S60'
- nmtile(31) = 'W000S60'
- nmtile(32) = 'E060S60'
- nmtile(33) = 'E120S60'
-
- do j = 1, jm10
- do i = 1, im10
- terr(i,j) = -9999.0
- variance(i,j) = -9999.0
- land_fraction(i,j) = -9999.0
- end do
- end do
-
- do n = 1,ntile
-!
-! Read header for each tile
-!
- call rdheader(nmtile(n),nrows,ncols,nodata,ulxmap,ulymap)
-
-!
-! Allocate space for array iterr
-!
- allocate ( iterr(ncols,nrows),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for iterr'
- stop
- end if
-!
-! Read terr data for each tile
-!
- call rdterr(nmtile(n),nrows,ncols,iterr)
-!
-! Allocate space for arrays terr10m and psea10m
-!
- nrow10 =nrows*dx30s/dx10m
- ncol10 =ncols*dx30s/dx10m
- allocate ( terr10m(ncol10,nrow10),psea10m(ncol10,nrow10),var10m(ncol10,nrow10),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr10m, psea10m, and var10m'
- stop
- end if
-!
-! Expand Caspian Sea for tiles 6 and 15
-!
- if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,3600,5300)
- if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,4088,5874)
- if(nmtile(n).eq.'E020N40')call expand_sea(ncols,nrows,iterr,nodata,3600,1)
-!
-! area average of 30-sec tile to 10-min tile
-!
- call avg(ncols,nrows,iterr,nodata,ulymap,dx30s,ncol10,nrow10,terr10m,psea10m,var10m)
-
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(terr10m), maxval(terr10m)
- print *, "min and max variacnes: ", minval(var10m) , maxval(var10m)
- print *, "min and max land frac: ", minval(psea10m), maxval(psea10m)
-!
-! fit the 10-min tile into global 10-min dataset
-! Note: the 30-sec and 10-min tiles are scaned from north to south, the global 10-min dataset are
-! scaned from south to north (90S to 90N) and east to west (0E to -0.1666667W)
-!
- latsw10 = nint(ulymap + 0.5 * dx30s) - nrow10 * dx10m + 0.5 * dx10m
- lonsw10 = nint(ulxmap - 0.5 * dx30s) + 0.5 * dx10m
- if( lonsw10 < 0.0 ) lonsw10=360.0+lonsw10
- i1 = nint( (lonsw10 - lon1_10m) / dx10m )+1
- if( i1 <= 0 ) i1 = i1 + im10
- if( i1 > im10 ) i1 = i1 - im10
- j1 = nint( (latsw10 - lat1_10m) / dx10m )+1
-
-! print*,'ulymap,ulxmap,latsw10,lonsw10 = ',ulymap,ulxmap,latsw10,lonsw10
-! print*,'i1,j1 = ', i1,j1
-
- call fitin(ncol10,nrow10,terr10m,psea10m,var10m,i1,j1,im10,jm10,terr,variance,land_fraction)
-!
-! Deallocate working space for arrays iterr, terr10m and psea10m
-!
- deallocate ( iterr,terr10m,psea10m,var10m,stat=dealloc_error )
- if( dealloc_error /= 0 ) then
- print*,'Unexpected deallocation error for arrays iterr,terr10m,psea10m,var10m'
- stop
- end if
-
- end do
-
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(terr), maxval(terr)
- print *, "min and max variances: ", minval(variance), maxval(variance)
- print *, "min and max land frac: ", minval(land_fraction), maxval(land_fraction)
-!
-! Write 10-min terrain dataset, variance and land_fraction to NetCDF file
-!
- call wrtncdf(im10,jm10,terr,variance, land_fraction,dx10m)
-
- end program convterr
-
- subroutine rdheader(nmtile,nrows,ncols,nodata,ulxmap,ulymap)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine read the header of USGA Global30 sec TOPO data set.
-!
- implicit none
-!
-! Dummy arguments
-!
- character (len=7), intent(in) :: nmtile ! name of the tile
- integer, intent(out) :: nrows ! number of rows
- integer, intent(out) :: ncols ! number of column
- integer, intent(out) :: nodata ! integer for ocean data point
- real(r8), intent(out) :: ulxmap
- real(r8), intent(out) :: ulymap
-!
-! Local variables
-!
- character (len=11) :: flheader ! file name of the header
- character (len=13) :: chars ! dummy character
-
- flheader=nmtile//'.HDR'
-
- print*,'flheader = ', flheader
-!
-! Open GTOPO30 Header File
-!
- open(unit=10,file=flheader,status='old',form='formatted')
-!
-! Read GTOPO30 Header file
-!
- read (10, *)
- read (10, *)
- read (10, *) chars,nrows
- print*,chars,' = ',nrows
- read (10, *) chars,ncols
- print*,chars,' = ',ncols
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *) chars,nodata
- print*,chars,' = ',nodata
- read (10, *) chars,ulxmap
- print*,chars,' = ',ulxmap
- read (10, *) chars,ulymap
- print*,chars,' = ',ulymap
- close(10)
-
- end subroutine rdheader
-
- subroutine rdterr(nmtile,nrows,ncols,iterr)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine read the USGS Global 30-sec terrain data for each tile.
-!
- implicit none
-!
-! Dummy arguments
-!
- character (len=7), intent(in) :: nmtile ! name of the tile
- integer, intent(in) :: nrows ! number of rows
- integer, intent(in) :: ncols ! number of column
- integer*2, dimension(ncols,nrows), intent(out) :: iterr ! terrain data
-!
-! Local variables
-!
- character (len=11) :: flterr ! file name for each terr dataset
- integer :: io_error ! I/O status
- integer :: i,j ! Index
- integer :: length ! record length
-
- flterr=nmtile//'.DEM'
-
-! print*,'flterr = ', flterr
-! print*,'nrows,ncols = ',nrows,ncols
-!
-! Open GTOPO30 Terrain dataset File
-!
-
- length = 2 * ncols * nrows
- io_error=0
- open(unit=11,file=flterr,access='direct',recl=length,iostat=io_error)
- if( io_error /= 0 ) then
- print*,'Open file error in subroutine rdterr'
- print*,'iostat = ', io_error
- stop
- end if
-!
-! Read GTOPO30 Terrain data file
-!
- read (11,rec=1,iostat=io_error) ((iterr(i,j),i=1,ncols),j=1,nrows)
-!
- if( io_error /= 0 ) then
- print*,'Data file error in subroutine rdterr'
- print*,'iostat = ', io_error
- stop
- end if
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(iterr), maxval(iterr)
-!
-! Correct missing data in source files
-!
-! Missing data near dateline
-
- if( nmtile == 'W180S60' ) then
- do j = 1, nrows
- iterr(1,j) = iterr(2,j)
- end do
- else if (nmtile == 'E120S60') then
- do j = 1, nrows
- iterr(ncols-1,j) = iterr(ncols-2,j)
- iterr(ncols,j) = iterr(ncols-2,j)
- end do
- end if
-!
-! Missing data at the southermost row near South pole
-!
- if( nmtile == 'E060S60' .or. nmtile == 'E120S60' .or. nmtile == 'W000S60' .or. &
- nmtile == 'W060S60' .or. nmtile == 'W120S60' .or. nmtile == 'W180S60' ) then
- do i=1,ncols
- iterr(i,nrows) = iterr(i,nrows-1)
- end do
- end if
-!
-! print*,'iterr(1,1),iterr(ncols,nrows) = ', &
-! iterr(1,1),iterr(ncols,nrows)
-
- close (11)
- end subroutine rdterr
-
- subroutine avg(ncols,nrows,iterr,nodata,ulymap,dx30s,ncol10,nrow10,terr10m,psea10m,var10m)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine reduces the resolution of the terrain data from 30-sec to 10-min and
-! compute the percentage of ocean cover (psea10m)
-!
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncols ! number of column for 30-sec tile
- integer, intent(in) :: nrows ! number of rows for 30-sec tile
- integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile
- integer, intent(in) :: nodata ! integer for ocean data point
- real(r8),intent(in) :: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8),intent(in) :: dx30s ! spacing interval for 30-sec data (in degree)
- integer, intent(in) :: nrow10 ! number of rows for 10-min tile
- integer, intent(in) :: ncol10 ! number of columns for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(out) :: terr10m ! terrain data for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(out) :: psea10m ! percentage ocean coverage for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(out) :: var10m ! variance of 30-sec elevations
-!
-! Local variables
-!
- real(r8) :: lats,latn ! latitudes (in rad) for ths south and north edges of each 30-sec cell
- real(r8) :: wt ! area weighting of each 30-sec cell
- real(r8) :: wt_tot ! total weighting of each 10-min cell
- real(r8) :: sumterr ! summation of terrain height of each 10-min cell
- real(r8) :: sumsea ! summation of sea coverage of each 10-min cell
- real(r8) :: pi ! pi=3.1415
- real(r8) :: latul ! latitude of the upper-left coner of 30-sec tile
- integer :: n1,itmp,i1,i2,j1,j2 ! temporary working spaces
- integer :: i,j,ii,jj ! index
- logical, dimension(ncols,nrows) :: oflag
-
- pi = 4.0 * atan(1.0)
-!
- n1 = ncols / ncol10
- print*,'ncols,ncol10,n1 = ',ncols,ncol10,n1
-
- itmp = nint( ulymap + 0.5 * dx30s )
- latul = itmp
- print*,'ulymap,latul = ', ulymap,latul
- oflag = .false.
-
- do j = 1, nrow10
- j1 = (j-1) * n1 + 1
- j2 = j * n1
- do i = 1, ncol10
- i1 = (i-1) * n1 + 1
- i2 = i * n1
- wt_tot = 0.0
- sumterr = 0.0
- sumsea = 0.0
-
- do jj = j1, j2
- latn = ( latul - (jj -1) * dx30s ) * pi / 180.0
- lats = ( latul - jj * dx30s ) * pi / 180.0
- wt = sin( latn ) - sin( lats )
-
- do ii = i1, i2
- wt_tot=wt_tot+wt
- if ( iterr(ii,jj) == nodata ) then
- sumsea = sumsea + wt
- oflag(ii,jj) = .true.
- else
- if ( iterr(ii,jj) .lt.nodata ) then
- ! this can only happen in the expand_sea routine
- sumsea = sumsea + wt
- oflag(ii,jj) = .true.
- iterr(ii,jj) = iterr(ii,jj) - nodata - nodata
- endif
- sumterr = sumterr + iterr(ii,jj) * wt
- end if
- end do
- end do
-
- terr10m(i,j) = sumterr / wt_tot
- psea10m(i,j) = sumsea / wt_tot
-
- end do
- end do
-
- ! Now compute variance of 30-second points
-
- do j = 1, nrow10
- j1 = (j-1) * n1 + 1
- j2 = j * n1
-
- do i = 1, ncol10
- i1 = (i-1) * n1 + 1
- i2 = i * n1
-
- wt_tot = 0.0
- var10m(i,j) = 0.0
- wt = 1.0
- do jj = j1, j2
- do ii = i1, i2
- wt_tot = wt_tot + wt
- if ( .not. oflag(ii,jj) ) then
- var10m(i,j) = var10m(i,j) + wt * (iterr(ii,jj)-terr10m(i,j))**2
- end if
- end do
- end do
- var10m(i,j) = var10m(i,j) / wt_tot
-
- end do
- end do
-
- end subroutine avg
-
- subroutine expand_sea(ncols,nrows,iterr,nodata,startx,starty)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine reduces the resolution of the terrain data from 30-sec to 10-min and
-! compute the percentage of ocean cover (psea10m)
-!
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncols ! number of column for 30-sec tile
- integer, intent(in) :: nrows ! number of rows for 30-sec tile
- integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile
- integer, intent(in) :: nodata ! integer for ocean data point
- integer, intent(in) :: startx, starty ! where to begin the sea
-!
-! Local variables
-!
- real(r8):: maxh
- integer :: i,j,per,ii,jj ! index
- logical, dimension(0:ncols+1,0:nrows+1) :: flag ! terrain data for 30-sec tile
- logical :: found
-
- flag = .false.
-
- maxh = iterr(startx,starty)
-
- iterr(startx,starty) = iterr(startx,starty) + nodata + nodata
- flag(startx-1:startx+1,starty-1:starty+1) = .true.
-
- per = 0
- print *, 'expanding sea at ',maxh,' m '
-
-2112 per = per + 1
- found = .false.
- do j = starty - per, starty + per, per*2
- do i = startx - per, startx + per
- if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then
- if( iterr(i,j).eq.maxh .and. flag(i,j) ) then
- iterr(i,j) = iterr(i,j) + nodata + nodata
- flag(i-1:i+1,j-1:j+1) = .true.
- found = .true.
- endif
- endif
- end do
- end do
-
- do i = startx - per, startx + per, per*2
- do j = starty - per + 1, starty + per - 1
- if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then
- if( iterr(i,j).eq.maxh .and. flag(i,j) ) then
- iterr(i,j) = iterr(i,j) + nodata + nodata
- flag(i-1:i+1,j-1:j+1) = .true.
- found = .true.
- endif
- endif
- end do
- end do
- if (found)goto 2112
- print *, 'done with expand_sea'
- return
-
- end subroutine expand_sea
-
- subroutine fitin(ncol10,nrow10,terr10m,psea10m,var10m,i1,j1,im10,jm10,terr,variance,land_fraction)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine put 10-min tile into the global dataset
-!
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncol10 ! number of columns for 10-min tile
- integer, intent(in) :: nrow10 ! number of rows for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(in) :: terr10m ! terrain data for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(in) :: psea10m ! percentage ocean coverage for 10-min tile
- real(r8), dimension(ncol10,nrow10), intent(in) :: var10m ! variance of 30-sec elev for 10-min tile
- integer, intent(in) :: i1,j1 ! the (i,j) point of the southwest corner of the 10-min tile
- ! in the global grid
- integer, intent(in) :: im10,jm10 ! the dimensions of the 10-min global dataset
- real(r8),dimension(im10,jm10), intent(out) :: terr ! global 10-min terrain data
- real(r8),dimension(im10,jm10), intent(out) :: variance ! global 10-min variance of elev
- real(r8),dimension(im10,jm10), intent(out) :: land_fraction ! global 10-min land fraction
-!
-! Local variables
-!
- integer :: i,j,ii,jj ! index
-
- do j = 1, nrow10
- jj = j1 + (nrow10 - j)
- do i = 1, ncol10
- ii = i1 + (i-1)
- if( ii > im10 ) ii = ii - im10
- terr(ii,jj) = terr10m(i,j)
- land_fraction(ii,jj) = 1.0 - psea10m(i,j)
- variance(ii,jj) = var10m(i,j)
- if( i == 1 .and. j == 1 ) &
- print*,'i,j,ii,jj = ',i,j,ii,jj
- if( i == ncol10 .and. j == nrow10 ) &
- print*,'i,j,ii,jj = ',i,j,ii,jj
- end do
- end do
- end subroutine fitin
-
- subroutine wrtncdf(im10,jm10,terr,variance,land_fraction,dx10m)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine save 10-min terrain data, variance, land fraction to NetCDF file
-!
- implicit none
-
-# include
-
-!
-! Dummy arguments
-!
- integer, intent(in) :: im10,jm10 ! the dimensions of the 10-min global dataset
- real(r8),dimension(im10,jm10), intent(in) :: terr ! global 10-min terrain data
- real(r8),dimension(im10,jm10), intent(in) :: variance ! global 10-min variance data
- real(r8),dimension(im10,jm10), intent(in) :: land_fraction !global 10-min land fraction
- real(r8), intent(in) :: dx10m
-!
-! Local variables
-!
- real(r8),dimension(im10) :: lonar ! longitude array
- real(r8),dimension(im10) :: latar ! latitude array
- character (len=32) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: varianceid
- integer :: htopoid
- integer :: landfid
- integer, dimension(2) :: variancedim,htopodim,landfdim
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j
- character (len=8) :: datestring
-
-!
-! Fill lat and lon arrays
-!
- do i = 1,im10
- lonar(i)= dx10m * (i-0.5)
- enddo
- do j = 1,jm10
- latar(j)= -90.0 + dx10m * (j-0.5)
- enddo
-
- fout='topo_gtopo30_10min.nc'
-!
-! Create NetCDF file for output
-!
- status = nf_create (fout, NF_WRITE, foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create dimensions for output
-!
- status = nf_def_dim (foutid, 'lon', im10, lonid)
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_def_dim (foutid, 'lat', jm10, latid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create variable for output
-!
- variancedim(1)=lonid
- variancedim(2)=latid
- status = nf_def_var (foutid,'variance', NF_FLOAT, 2, variancedim, varianceid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- htopodim(1)=lonid
- htopodim(2)=latid
- status = nf_def_var (foutid,'htopo', NF_FLOAT, 2, htopodim, htopoid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- landfdim(1)=lonid
- landfdim(2)=latid
- status = nf_def_var (foutid,'landfract', NF_FLOAT, 2, landfdim, landfid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! Create attributes for output variables
-!
- status = nf_put_att_text (foutid,varianceid,'long_name', 29, 'variance of 30-sec elevations')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,varianceid,'units', 8, 'meter**2')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,htopoid,'long_name', 41, '10-min elevation from USGS 30-sec dataset')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,landfid,'long_name', 23, '10-minute land fraction')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '10-minute USGS topo data')
- if (status .ne. NF_NOERR) call handle_err(status)
- call DATE_AND_TIME(DATE=datestring)
- status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring )
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! End define mode for output file
-!
- status = nf_enddef (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Write variable for output
-!
- status = nf_put_var_double (foutid, varianceid, variance)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_var_double (foutid, htopoid, terr)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_var_double (foutid, landfid, land_fraction)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_var_double (foutid, latvid, latar)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_var_double (foutid, lonvid, lonar)
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! Close output file
-!
- status = nf_close (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- end subroutine wrtncdf
-!************************************************************************
-!!handle_err
-!************************************************************************
-!
-!!ROUTINE: handle_err
-!!DESCRIPTION: error handler
-!--------------------------------------------------------------------------
-
- subroutine handle_err(status)
-
- implicit none
-
-# include
-
- integer status
-
- if (status .ne. nf_noerr) then
- print *, nf_strerror(status)
- stop 'Stopped'
- endif
-
- end subroutine handle_err
-
-
diff --git a/tools/definehires/shr_kind_mod.F90 b/tools/definehires/shr_kind_mod.F90
deleted file mode 100644
index fc1ed8e94a..0000000000
--- a/tools/definehires/shr_kind_mod.F90
+++ /dev/null
@@ -1,20 +0,0 @@
-!===============================================================================
-! CVS: $Id$
-! CVS: $Source$
-! CVS: $Name$
-!===============================================================================
-
-MODULE shr_kind_mod
-
- !----------------------------------------------------------------------------
- ! precision/kind constants add data public
- !----------------------------------------------------------------------------
- public
- integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
- integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
- integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
- integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
- integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
- integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
-
-END MODULE shr_kind_mod
diff --git a/tools/definesurf/Makefile b/tools/definesurf/Makefile
deleted file mode 100644
index dd13a5bdd4..0000000000
--- a/tools/definesurf/Makefile
+++ /dev/null
@@ -1,144 +0,0 @@
-# Makefile to build definesurf on various platforms
-# Note: If netcdf library is not built in the standard location, you must set the environment
-# variables INC_NETCDF and LIB_NETCDF
-
-EXEDIR = .
-EXENAME = definesurf
-RM = rm
-
-.SUFFIXES:
-.SUFFIXES: .f90 .o
-
-# Check for the NetCDF library and include directories
-ifeq ($(LIB_NETCDF),$(null))
-LIB_NETCDF := /usr/local/lib
-endif
-
-ifeq ($(INC_NETCDF),$(null))
-INC_NETCDF := /usr/local/include
-endif
-
-# Determine platform
-UNAMES := $(shell uname -s)
-UNAMEM := $(findstring CRAY,$(shell uname -m))
-
-# Architecture-specific flags and rules
-#
-#------------------------------------------------------------------------
-# Cray
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMEM),CRAY)
-FC = f90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.f90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# SGI
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),IRIX64)
-FC = f90
-FFLAGS = -64 -c -I$(INC_NETCDF)
-LDFLAGS = -64 -L/usr/local/lib64/r4i4 -lnetcdf
-.f90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# SUN
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),SunOS)
-FC = f90
-FFLAGS = -c -stackvar -f -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.f90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# AIX
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),AIX)
-FC = xlf90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.f90.o:
- $(FC) $(FFLAGS) -qsuffix=f=f90 $<
-endif
-
-#------------------------------------------------------------------------
-# OSF1
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),OSF1)
-FC = f90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.f90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# Linux
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),Linux)
-ifeq ($(USER_FC),$(null))
-FC := pgf90
-FFLAGS = -c -I$(INC_NETCDF) -fast
-else
-FC := $(USER_FC)
-endif
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-
-ifeq ($(FC),lf95)
-FFLAGS = -c --trace --trap -I$(INC_NETCDF) -g
-LDFLAGS += -g
-endif
-
-.f90.o:
- $(FC) $(FFLAGS) $<
-endif
-
-#------------------------------------------------------------------------
-# Default rules and macros
-#------------------------------------------------------------------------
-
-OBJS := ao.o ao_i.o area_ave.o binf2c.o cell_area.o \
- chkdims.o endrun.o fmain.o handle_error.o inimland.o \
- lininterp.o map_i.o max_ovr.o shr_kind_mod.o sghphis.o sm121.o \
- terrain_filter.o varf2c.o wrap_nf.o interplandm.o map2f.o
-
-$(EXEDIR)/$(EXENAME): $(OBJS)
- $(FC) -o $@ $(OBJS) $(LDFLAGS)
-
-clean:
- $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME)
-
-ao.o: shr_kind_mod.o
-ao_i.o: shr_kind_mod.o
-area_ave.o: shr_kind_mod.o
-binf2c.o: shr_kind_mod.o
-cell_area.o: shr_kind_mod.o
-chkdims.o:
-endrun.o:
-fmain.o: shr_kind_mod.o
-handle_error.o:
-inimland.o: shr_kind_mod.o
-lininterp.o: shr_kind_mod.o
-map_i.o: shr_kind_mod.o
-max_ovr.o: shr_kind_mod.o
-shr_kind_mod.o:
-sghphis.o: shr_kind_mod.o
-sm121.o: shr_kind_mod.o
-terrain_filter.o:
-map2f.o:
-varf2c.o: shr_kind_mod.o
-wrap_nf.o:
-interplandm.o:
diff --git a/tools/definesurf/README b/tools/definesurf/README
deleted file mode 100644
index f0d9427e8e..0000000000
--- a/tools/definesurf/README
+++ /dev/null
@@ -1,156 +0,0 @@
-Running gnumake in this directory will create an executable named
-"definesurf". Its function is to compute required CAM initial dataset
-variables SGH, PHIS, and LANDFRAC from a high-resolution topography dataset,
-and LANDM_COSLAT from a T42 "master", then add or replace the values on an
-existing initial dataset. SGH is the standard deviation of PHIS used in the
-gravity wave drag scheme. PHIS is the geopotential height. LANDFRAC is land
-fraction. LANDM_COSLAT is a field derived from LANDFRAC which is required by
-the prognostic cloud water parameterization. There is a cosine(latitude)
-dependence built in to the function.
-
-The cam standard high resolution dataset is now based on the USGS
-GTOPO30 digital elevation model at 30" resolution. It is converted to
-10' resolution by definehires.
-
-The older high resolution topography dataset (10') used by definesurf
-is named topo.nc and is included as part of the CAM distribution in
-the datasets tar file. topo.nc was derived from the U.S. Navy Global
-Elevation 10-MIN dataset DS754.0 Please refer to the following NCAR
-website for more information:
-
-http://www.scd.ucar.edu/dss/catalogs/geo.html
-
-The algorithms within this code should be considered experimental.
-For example, a 1-2-1 smoothing operator (sm121, called from subroutine
-sghphis) is applied twice in succession to the topography variance
-field regardless of horizontal resolution. Also, a spectral filter
-will be applied to the PHIS field within the CAM at model startup
-(except for the fv dycore) if PHIS was defined from the high
-resolution topography dataset. The model determines this by checking
-for the presence of netcdf attribute "from_hires" on variable PHIS.
-
--------------------------------------
-Feb 01, 2005
--------------------------------------
--------------------------------------
-*********** definesurf **************
--------------------------------------
-
-A 10' data file is read in and averaged to the model grid by
-definesurf. The present form of definesurf also takes a model initial
-condition file as input and gets model grid description from it. The
-terrain data mapped to the model grid is output on a new file.
-
-Command line flags are used for
- -t name - (required) name of 10' data file
- -g name - (required) name of cam initial condition file containing grid description
- -l name - (required) name of land mask file on ?? grid
- -r - (optional) do not extend Ross sea (default is extend)
- -v - (optional) verbose (default is false)
- -del2 - (optional) filter the elevations with a del2 filter (use for fv only)
- -remap - (optional) filter the elevations with a remapping filter (use for fv only)
- -sgh - (optional) filter the standard deviations with same filter as height
- name - (required) name of i.c. file with existing terrain data,
- must be final argument
-
-definesurf -t topo_gtopo30_10min.nc -g cami_*.nc -l landm_coslat.nc -remap oro_GTOPO30.nc
-generates the file oro_GTOPO30.nc using the remapping filter.
-
-definesurf calls shgphis, which recognizes 2 input 10' data file formats
- Old style, no 30" variance data on 10' grid, variance = -1
- land fraction called "ftopo"
- New style, 30" variance data is present
- land fraction called "landfract"
-
- Land fraction and 30" variance (if present) are averaged to the
- model grid.
-
- if plon >= 128 then
- Height is averaged to the model grid and the variance w.r.t to the
- 10' data is computed.
- if plon < 128 then
- Height is averaged to a 3 degree grid and the variance w.r.t to the
- 10' data is computed. The avg height and the variance of
- the 3 degree data are then averaged to the model grid.
-
- 1-2-1 smoothers are applied twice to the model grid averaged values
- of the two variance fields: 10' w.r.t. model grid; 30" w.r.t. 10'
- (if 30" variance is present).
-
- The averaged and smoothed variances are converted to standard
- deviations.
-
- The averaged height is converted to a geopotential (z*9.80616)
-
-Attributes are added to input file to describe what definesurf is doing.
-
-Land mask for clouds is interpolated to model grid.
-
-Extend land to -79 degrees for Ross ice shelf, unless -r flag was
-set.
-
-Run terrain filter, if requested (-remap or -del2). Should only be
-done for fv grids. For spectral grid, filtering is done in the model
-based on the value of the attribute "from_hires".
- Diffusive filter or remapping is appled to
- surface geopotential
- standard deviation of 10' data w.r.t. model grid
- standard deviation of 30" data w.r.t. 10' grid (if present)
-
-**** It is not clear that the filter should be applied to the
-**** standard deviations.
-
- The remapping filter removes structure near grid scale by using the
- ppm mapping code to go to a half resolution grid and back to the
- full resolution grid. Order (accuracy) parameters iord=7 and jord=3
- are used. A polar filter is also applied.
-
--------------------------------------------------------
-******* diffusive (-del2) terrain filter notes ********
--------------------------------------------------------
-
-The del2 filter is a bit of a pain to figure out from the code (as is the
-spectral one applied in the model for eul and sld dycores). It looks like
-
-(1) h(n+1) = h(n) + c*del2(h(n)), c=0.25
-
-del2(h) = div(grad(h))
-
-however, buried inside the del2 routine is a scaling by
-CD = 0.25*DL*DP*coszc**2,
-
-coszc = cos(60*pi/180) [= 0.5]
-DL = 2*pi/NLON is delta lambda
-DP = pi / (NLAT-1) is delta phi
-so
-CD = 0.0625 * 2*pi/NLON * pi/(NLAT-1) = 0.4 / NLON / (NLAT-1)
-
-So the scaling factor reduces as the square of the resolution, just like
-a del2 coefficient should, in order to maintain a constant damping rate
-at the truncation limit.
-CD = 3E-5, for 2x2.5
-
-However, the number of iterations is NLON/12, so there is an additional
-scaling upward of diffusion with resolution.
-
-going back to (1)
-h(n+1) = h(n) + c*CD*del2(h(n))
-c*CD = 7.57E-6 for 2x2.5
-c*CD is just dt*k for a normal diffusion equation, where dt is the time
-step and k is the diffusivity on the unit sphere. For a sphere with
-radius a (=6.37E6), the diffusivity is K=k*a**2 .
-Then dt*K = c*CD*a**2 = 3E8 and assuming dt=3600, K = 8.5E4
-
-The del4 diffusivity in the spectral case is 5E15 at T63. The equivalent
-del2 coefficient is K = 5E15 * 63*64/a**2 = 5E5 to damp wave 63 at the
-same rate.
-
-So, we have K_fv ~ 8.5E4 and K_eul ~ 5E5. So the fv damping should
-actually be less than the spectral/eulerian damping.
-
-Also, the damping is applied 25 times in the spectral case and NLON/12
-times for fv. NLON/12 =12 for 2x2.5, =24 for 1x1.25 and =48 for
-0.5x0.625.
-
-The big difference is that the spectral/eulerian actually uses del4,
-which confines the damping much closer to grid scale.
diff --git a/tools/definesurf/ao.f90 b/tools/definesurf/ao.f90
deleted file mode 100644
index 33d7494215..0000000000
--- a/tools/definesurf/ao.f90
+++ /dev/null
@@ -1,141 +0,0 @@
-subroutine ao (nlon_i , nlat_i , numlon_i, lon_i , lat_i , &
- nlon_o , nlat_o , numlon_o, lon_o , lat_o , &
- area_o , re , mx_ovr , n_ovr , i_ovr , &
- j_ovr , w_ovr )
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-! -----------------------------------------------------------------
- implicit none
-! ------------------------ code history ---------------------------
-! source file: ao.F
-! purpose: weights and indices for area of overlap between
-! input and output grids
-! date last revised: March 1996
-! author: Gordon Bonan
-! standardized:
-! reviewed:
-! -----------------------------------------------------------------
-
-! ------------------- input variables -----------------------------
- integer nlon_i !maximum number of input longitude points
- integer nlat_i !number of input latitude points
- integer numlon_i(nlat_i) !number of input lon pts for each latitude
- integer nlon_o !maximum number of output longitude points
- integer nlat_o !number of output latitude points
- integer numlon_o(nlat_o) !number of output lon pts for each latitude
- integer mx_ovr !maximum number of overlapping input cells
-
- real(r8) lon_i(nlon_i+1,nlat_i) !input grid cell longitude, w. edge (deg)
- real(r8) lon_o(nlon_o+1,nlat_o) !output grid cell longitude, w. edge (deg)
- real(r8) lat_i(nlat_i+1) !input grid cell latitude, s. edge (deg)
- real(r8) lat_o(nlat_o+1) !output grid cell latitude, s. edge (deg)
- real(r8) area_o(nlon_o,nlat_o) !area of output grid cell
- real(r8) re !radius of earth
-! -----------------------------------------------------------------
-
-! ------------------- input/output variables ----------------------
- integer n_ovr(nlon_o,nlat_o ) !number of overlapping input cells
- integer i_ovr(nlon_o,nlat_o,mx_ovr) !lon index, overlapping input cell
- integer j_ovr(nlon_o,nlat_o,mx_ovr) !lat index, overlapping input cell
-
- real(r8) w_ovr(nlon_o,nlat_o,mx_ovr) !overlap weights for input cells
-! -----------------------------------------------------------------
-
-! ------------------- local variables -----------------------------
- integer io,ii !output and input grids longitude loop index
- integer jo,ji !output and input grids latitude loop index
-
- real(r8) lonw,lone,dx !west, east longitudes of overlap and difference
- real(r8) lats,latn,dy !south, north latitudes of overlap and difference
- real(r8) deg2rad !pi/180
- real(r8) a_ovr !area of overlap
- real(r8) zero,one
- parameter (zero=0.0) ! Needed as arg to "max"
- parameter (one=1.) ! Needed as arg to "atan"
-! -----------------------------------------------------------------
-
- deg2rad = (4.*atan(one)) / 180.
-
-! -----------------------------------------------------------------
-! for each output grid cell: find overlapping input grid cell and area of
-! input grid cell that overlaps with output grid cell. cells overlap if:
-!
-! southern edge of input grid < northern edge of output grid AND
-! northern edge of input grid > southern edge of output grid
-!
-! western edge of input grid < eastern edge of output grid AND
-! eastern edge of input grid > western edge of output grid
-!
-! lon_o(io,jo) lon_o(io+1,jo)
-!
-! | |
-! --------------------- lat_o(jo+1)
-! | |
-! | |
-! xxxxxxxxxxxxxxx lat_i(ji+1) |
-! x | x |
-! x input | x output |
-! x cell | x cell |
-! x ii,ji | x io,jo |
-! x | x |
-! x ----x---------------- lat_o(jo )
-! x x
-! xxxxxxxxxxxxxxx lat_i(ji )
-! x x
-! lon_i(ii,ji) lon_i(ii+1,ji)
-! -----------------------------------------------------------------
-
-! note that code does not vectorize but is only called during
-! initialization.
-
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
-
-! loop through all input grid cells to find overlap with output grid.
-
- do ji = 1, nlat_i
- if ( lat_i(ji ).lt.lat_o(jo+1) .and. &
- lat_i(ji+1).gt.lat_o(jo ) ) then !lat ok
-
- do ii = 1, numlon_i(ji)
- if ( lon_i(ii ,ji).lt.lon_o(io+1,jo) .and. &
- lon_i(ii+1,ji).gt.lon_o(io ,jo) ) then !lon okay
-
-! increment number of overlapping cells. make sure 0 < n_ovr < mx_ovr
-
- n_ovr(io,jo) = n_ovr(io,jo) + 1
-! if (n_ovr(io,jo) .gt. mx_ovr) then
-! write (6,*) 'AO error: n_ovr= ',n_ovr(io,jo), &
-! ' exceeded mx_ovr = ',mx_ovr, &
-! ' for output lon,lat = ',io,jo
-! call endrun
-! end if
-
-! determine area of overlap
-
- lone = min(lon_o(io+1,jo),lon_i(ii+1,ji))*deg2rad !e edge
- lonw = max(lon_o(io ,jo),lon_i(ii ,ji))*deg2rad !w edge
- dx = max(zero,(lone-lonw))
- latn = min(lat_o(jo+1),lat_i(ji+1))*deg2rad !n edge
- lats = max(lat_o(jo ),lat_i(ji ))*deg2rad !s edge
- dy = max(zero,(sin(latn)-sin(lats)))
- a_ovr = dx*dy*re*re
-
-! determine indices and weights. re cancels in the division by area
-
- i_ovr(io,jo,n_ovr(io,jo)) = ii
- j_ovr(io,jo,n_ovr(io,jo)) = ji
- w_ovr(io,jo,n_ovr(io,jo)) = a_ovr/area_o(io,jo)
-
- end if
- end do
-
- end if
- end do
-
- end do
- end do
-
- return
-end subroutine ao
diff --git a/tools/definesurf/ao_i.f90 b/tools/definesurf/ao_i.f90
deleted file mode 100644
index 87b96eb815..0000000000
--- a/tools/definesurf/ao_i.f90
+++ /dev/null
@@ -1,178 +0,0 @@
-subroutine ao_i(nlon_i , nlat_i , numlon_i, lon_i , lat_i , &
- nlon_o , nlat_o , numlon_o, lon_o , lat_o , &
- mx_ovr , i_ovr , j_ovr , w_ovr , re , &
- area_o , relerr )
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-! -----------------------------------------------------------------
- implicit none
-! ------------------------ code history ---------------------------
-! source file: ao_i.F
-! purpose: area averaging initialization: indices and weights
-! date last revised: November 1996
-! author: Gordon Bonan
-! standardized:
-! reviewed:
-! -----------------------------------------------------------------
-
-! ------------------------ notes ----------------------------------
-! get indices and weights for area-averaging between input and output grids
-
-! o input grid does not have to be finer resolution than output grid
-
-! o both grids must be oriented south to north, i.e., cell(lat+1)
-! must be north of cell(lat). the southern edge of the first row
-! must be -90 (south pole) and the northern edge of the last row
-! must be +90 (north pole)
-
-! o both grids must be oriented eastwards, i.e., cell(lon+1) must be
-! east of cell(lon). but the two grids do not have to start at the
-! same longitude, i.e., one grid can start at dateline and go east;
-! the other grid can start at greenwich and go east. longitudes for
-! the western edge of the cells must increase continuously and span
-! 360 degrees. examples
-! dateline : -180 to 180 (- longitudes west of greenwich)
-! greenwich : 0 to 360
-! greenwich (centered): -dx/2 to -dx/2 + 360 (- longitudes west of greenwich)
-
-! for each output grid cell
-! o number of input grid cells that overlap with output grid cell (n_ovr)
-! o longitude index (1 <= i_ovr <= nlon_i) of the overlapping input grid cell
-! o latitude index (1 <= j_ovr <= nlat_i) of the overlapping input grid cell
-
-! for field values fld_i on an input grid with dimensions nlon_i and nlat_i
-! field values fld_o on an output grid with dimensions nlon_o and nlat_o are
-! fld_o(io,jo) =
-! fld_i(i_ovr(io,jo, 1),j_ovr(io,jo, 1)) * w_ovr(io,jo, 1) +
-! ... + ... +
-! fld_i(i_ovr(io,jo,mx_ovr),j_ovr(io,jo,mx_ovr)) * w_ovr(io,jo,mx_ovr)
-
-! error check: overlap weights of input cells sum to 1 for each output cell
-! -----------------------------------------------------------------
-
-! ------------------- input variables -----------------------------
- integer nlon_i !input grid max number of input longitude points
- integer nlat_i !input grid number of input latitude points
- integer numlon_i(nlat_i) !input grid number of lon points for each lat
- integer nlon_o !output grid max number of output lon points
- integer nlat_o !output grid number of output latitude points
- integer numlon_o(nlat_o) !output grid number of lon points for each lat
- integer mx_ovr !max num of input cells that overlap output cell
-
- real(r8) lon_i(nlon_i+1,nlat_i) !input grid cell lon, western edge (degrees)
- real(r8) lon_o(nlon_o+1,nlat_o) !output grid cell lon, western edge (degrees)
- real(r8) lat_i(nlat_i+1) !input grid cell lat, southern edge (degrees)
- real(r8) lat_o(nlat_o+1) !output grid cell lat, southern edge (degrees)
- real(r8) area_o(nlon_o,nlat_o) !cell area on output grid
- real(r8) re !radius of earth
- real(r8) relerr !max error: sum overlap weights ne 1
-! -----------------------------------------------------------------
-
-! ------------------- output variables ----------------------------
- integer i_ovr(nlon_o,nlat_o,mx_ovr) !lon index, overlapping input cell
- integer j_ovr(nlon_o,nlat_o,mx_ovr) !lat index, overlapping input cell
- real(r8) w_ovr(nlon_o,nlat_o,mx_ovr) !overlap weights for input cells
-! -----------------------------------------------------------------
-
-! ------------------- local variables -----------------------------
- integer io,ii !input and output grids longitude loop index
- integer jo,ji !input and output grids latitude loop index
- integer n !overlapping cell index
-
- real(r8) offset !used to shift x-grid 360 degrees
- real(r8) f_ovr !sum of overlap weights for cells on output grid
-!
-! Dynamic
-!
- integer n_ovr(nlon_o,nlat_o) !number of overlapping input cells
-
-! -----------------------------------------------------------------
-! initialize overlap weights on output grid to zero for maximum
-! number of overlapping points. set lat and lon indices of overlapping
-! input cells to dummy values. set number of overlapping cells to zero
-! -----------------------------------------------------------------
-
- do n = 1, mx_ovr
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
- i_ovr(io,jo,n) = 1
- j_ovr(io,jo,n) = 1
- w_ovr(io,jo,n) = 0.
- end do
- end do
- end do
-
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
- n_ovr(io,jo) = 0
- end do
- end do
-
-! -----------------------------------------------------------------
-! first pass to find cells that overlap, area of overlap, and weights
-! -----------------------------------------------------------------
-
- call ao (nlon_i , nlat_i , numlon_i, lon_i , lat_i , &
- nlon_o , nlat_o , numlon_o, lon_o , lat_o , &
- area_o , re , mx_ovr , n_ovr , i_ovr , &
- j_ovr , w_ovr )
-
-! -----------------------------------------------------------------
-! second pass to find cells that overlap, area of overlap, and weights
-! -----------------------------------------------------------------
-
-! shift x-grid to locate periodic grid intersections
-! the following assumes that all lon_i(1,:) have the same value
-! independent of latitude and that the same holds for lon_o(1,:)
-
- if (lon_i(1,1) .lt. lon_o(1,1)) then
- offset = 360.0
- else
- offset = -360.0
- end if
-
- do ji = 1,nlat_i
- do ii = 1, numlon_i(ji) + 1
- lon_i(ii,ji) = lon_i(ii,ji) + offset
- end do
- end do
-
-! find overlap
-
- call ao (nlon_i , nlat_i , numlon_i , lon_i , lat_i , &
- nlon_o , nlat_o , numlon_o , lon_o , lat_o , &
- area_o , re , mx_ovr , n_ovr , i_ovr , &
- j_ovr , w_ovr )
-
-! restore x-grid (un-shift x-grid)
-
- do ji = 1,nlat_i
- do ii = 1, numlon_i(ji) + 1
- lon_i(ii,ji) = lon_i(ii,ji) - offset
- end do
- end do
-
-! -----------------------------------------------------------------
-! error check: overlap weights for input grid cells must sum to 1
-! -----------------------------------------------------------------
-
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
- f_ovr = 0.
-
- do n = 1, mx_ovr
- f_ovr = f_ovr + w_ovr(io,jo,n)
- end do
-
- if (abs(f_ovr-1.) .gt. relerr) then
- write (6,*) 'AO_I error: area not conserved for',' lon,lat = ', io,jo
- write (6,'(a30,e20.10)') ' sum of overlap weights = ', f_ovr
- call endrun
- end if
-
- end do
- end do
-
- return
-end subroutine ao_i
diff --git a/tools/definesurf/area_ave.f90 b/tools/definesurf/area_ave.f90
deleted file mode 100644
index cbcdbcd3af..0000000000
--- a/tools/definesurf/area_ave.f90
+++ /dev/null
@@ -1,59 +0,0 @@
-subroutine area_ave (nlat_i , nlon_i , numlon_i, fld_i , &
- nlat_o , nlon_o , numlon_o, fld_o , &
- i_ovr , j_ovr , w_ovr , nmax )
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
-! ------------------------ code history ---------------------------
-! source file: area_ave.F
-! purpose: area averaging of field from input to output grids
-! date last revised: November 1996
-! author: Gordon Bonan
-! standardized:
-! reviewed:
-! -----------------------------------------------------------------
-
-! ------------------- input variables -----------------------------
- integer nlat_i ! number of latitude points for input grid
- integer nlat_o ! number of latitude points for output grid
- integer nlon_i ! maximum number of longitude points for input grid
- integer nlon_o ! maximum number of longitude points for output grid
- integer nmax ! maximum number of overlapping cells
- integer numlon_i(nlat_i) ! input grid number of lon points at each lat
- integer numlon_o(nlat_o) ! input grid number of lon points at each lat
- integer i_ovr(nlon_o,nlat_o,nmax) ! lon index, overlapping input cell
- integer j_ovr(nlon_o,nlat_o,nmax) ! lat index, overlapping input cell
-
- real(r8) fld_i(nlon_i,nlat_i) !field for input grid
- real(r8) w_ovr(nlon_o,nlat_o,nmax) ! overlap weights for input cells
-! -----------------------------------------------------------------
-
-! ------------------- output variables ----------------------------
- real(r8) fld_o(nlon_o,nlat_o) !field for output grid
-! -----------------------------------------------------------------
-
-! ------------------- local variables -----------------------------
- integer jo,ji !latitude index for output,input grids
- integer io,ii !longitude index for output,input grids
- integer n !overlapping cell index
-! -----------------------------------------------------------------
-
- do jo = 1, nlat_o
- do io =1, numlon_o(jo)
- fld_o(io,jo) = 0.
- end do
- end do
-
- do n = 1, nmax
- do jo = 1, nlat_o
- do io =1, numlon_o(jo)
- ii = i_ovr(io,jo,n)
- ji = j_ovr(io,jo,n)
- fld_o(io,jo) = fld_o(io,jo) + w_ovr(io,jo,n)*fld_i(ii,ji)
- end do
- end do
- end do
-
- return
-end subroutine area_ave
diff --git a/tools/definesurf/binf2c.f90 b/tools/definesurf/binf2c.f90
deleted file mode 100644
index f43ca19ee4..0000000000
--- a/tools/definesurf/binf2c.f90
+++ /dev/null
@@ -1,218 +0,0 @@
-subroutine binf2c(flon , flat ,nflon ,nflat ,fine , &
- clon , clat ,nclon ,nclat ,cmean )
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-!-----------------------------------------------------------------------------
-! Bin going from a fine grid to a coarse grid.
-! A schematic for the coarse and fine grid systems is shown in
-! Figure 1. This code assumes that each data point is represent
-! it's surrounding area, called a cell. The first grid data point
-! for both grids is assumed to be located at 0E (GM). This
-! implies that the 1st cell for both the fine and the coarse grids
-! strattles the Greenwich Meridian (GM). This code also assumes
-! that there is no data wraparound (last data value is located at
-! 360-dx).
-!
-! FIGURE 1: Overview of the coarse (X) and fine (@) grids
-! longitudinal structure where:
-! X = location of each coarse grid data point
-! @ = location of each fine grid data point
-!
-! Greenwich Greenwich
-! 0 Coarse cells 360
-! : v :
-! clon(1): clon(2) v clon(3) clon(nclon):
-! v : v v v v :
-! xxxxxxxxxxxxxxxxxxxxxxxxxxxx..xxxxxxxxxxxxxxxx :
-! x x x x x :
-! x x x x x :
-! x c(1) x c(2) x x c(nclon)x :
-! x X x X x x X x :
-! x ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ :
-! x | | | | | | | | | | | | | :
-! x | @ | @ | @ | @ | @ | @ |..| @ | @ | @ | @ | @ | :
-! xxx|___|___|___|___|___|___| |___|___|___|___|___| :
-! v v v v v :
-! flon(1) flon(3) v flon(nflon-1) flon(nflon)
-! : v :
-! : Fine cells :
-! 0 360
-!
-! The Longitude/Latitude search:
-! ------------------------------
-!
-! Given a coarse grid cell with west and east boundaries of cWest
-! and cEast and south and north boundaries of cSouth and cNorth
-! (outlined by "x" in figure 2), find the indices of the fine grid
-! points which are contained within the coarse grid cell. imin and
-! imax are the indices fine grid points which overlap the western
-! and eastern boundary of the coarse cell. jmin and jmax are the
-! corresponding indices in the S-N direction. Bin these overlapping
-! values to generate coarse(n), the coarse grid data values.
-!
-! FIGURE 2: Detail of Coarse and Fine cell overlap.
-! @ = fine grid data point
-! X = coarse grid data point
-!
-! cWest cEast
-! | | x | | x |
-! -@-------@---x---@-------@-----x-@-
-! | | x*xxxxxxxxxxxxxxxxx*x|xx cNorth
-! | | x | | x |
-! | | x | | x |
-! @-------@---x---@-------@-----x-@- jmax
-! | | x | c(n) | x |
-! | @ | x | | x |
-! | | x | | x |
-! @-------@---x---@-------@-----x-@- jmin
-! | | x | | x |
-! | @ | x*xxxxxxx@xxxxxxxxx*x|xx cSouth
-! | | x | | x |
-! -@-------@---x---@-------@-----x-@-
-! | imin imax |
-!
-!
-! When a cell coarse cell strattles the Greenwich Meridian
-! ---------------------------------------------------------
-!
-! The first coarse grid cell strattles the GM, so when the western
-! boundary of the coarse cell is < 0, an additional search is carried out.
-! It ASSUMES that the easternmost fine grid point overlaps and searches
-! westward from nflon, looking for a grid point west of clon(1)
-! This generates a second set of longitudinal indices, imin1 and imax1.
-! See Figure 3.
-!
-! Figure 3: Detail of Coarse cell strattling GM:
-! -----------------------------------------------
-!
-! Greenwich Greenwich
-! 0 360
-! cWest : cEast cWest :
-! clon(1): clon(2) clon(nclon+1)=clon(1)
-! v : v v :
-! xxxxxxxxxxxxxxxxxxxxxxx ... xxxxxxxxxxxxxxxx :
-! x x x x x :
-! x x x x x :
-! x c(1) x x x c(nclon)x :
-! x X x x x X x :
-! x ___ ___ ___ _ ___ ___ ___ :
-! x | | | | | | | :
-! x | @ | @ | @ | @ | @ | @ | :
-! xxx|___|___|___|_ ___|___|___| :
-! ^ : ^ ^ ^ ^ :
-! flon(1): ^ flon(3) flon(nflon-1) ^ :
-! ^ : ^ ^ ^ :
-! ^ :flon(2) ^ flon(nflon)
-! ^ : ^ ^ ^ :
-! imin : imax imin1 imax1 :
-! : :
-!
-!
-! In this case, imin=1, imax=2, imin1=nflon-1 and imax1=nflon.
-! because the last two cells of the fine grid will have some
-! contribution the the 1st cell of the coarse grid.
-!
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------Arguments---------------------------------
-
- integer nflon ! Input: number of fine longitude points
- integer nflat ! Input: number of fine latitude points
- integer nclon ! Input: number of coarse longitude points
- integer nclat ! Input: number of coarse latitude points
-
- real(r8) flon(nflon) ! Input: fine grid lons, centers (deg)
- real(r8) flat(nflat) ! Input: fine grid lats, centers (deg)
- real(r8) fine(nflon,nflat) ! Input: Fine grid data array
- real(r8) clon(nclon+1,nclat) ! Input: coarse grid cell lons, west edge (deg)
- real(r8) clat(nclat+1) ! Input: coarse grid cell lat, south edge (deg)
- real(r8) cmean(nclon,nclat) ! Output: mean of fine grid points over coarse cell
-
-!--------------------------Local variables------------------------------
-
- real(r8) cWest ! Coarse cell longitude, west edge (deg)
- real(r8) cEast ! Coarse cell longitude, east edge (deg)
- real(r8) cSouth ! Coarse cell latitude, south edge (deg)
- real(r8) cNorth ! Coarse cell latitude, notrh edge (deg)
- real(r8) sum ! coarse tmp value
-
- integer i,j ! Indices
- integer imin ,imax ! Max/Min E-W indices of intersecting fine cell.
- integer imin1,imax1 ! fine E-W indices when coarse cell strattles GM
- integer jmin ,jmax ! Max/Min N-S indices of intersecting fine cell.
- integer iclon,jclat ! coarse grid indices
- integer num ! increment
-
-!-----------------------------------------------------------------------------
-
- do jclat= 1,nclat ! loop over coarse latitudes
- cSouth = clat(jclat)
- cNorth = clat(jclat+1)
-
- do iclon=1,nclon ! loop over coarse longitudes
- cWest = clon(iclon,jclat)
- cEAST = clon(iclon+1,jclat)
-
-! 1. Normal longitude search: Find imin and imax
-
- imin = 0
- imax = 0
- do i=1,nflon-1 ! loop over fine lons, W -> E
- if (flon(i) .gt. cEast) goto 10 ! fine grid point is E of coarse box
- if (flon(i) .ge. cWest .and. imin.eq.0) imin=i
- imax=i
- enddo
-
-! 2. If cWest < 0, then coarse cell strattles GM. Hunt westward
-! from the end to find indices of any overlapping fine grid cells:
-! imin1 and imax1.
-
-10 imin1 = 0 ! borders for cWest, cEast
- imax1 = -1 ! borders for cWest, cEast
- if (cWest .lt. 0) then
- cWest = cWest + 360.
- imax1 = nflon
- do i=nflon,1,-1 ! loop over fine lons, E -> W
- imin1=i
- if (flon(i) .le. cWest) goto 20 ! fine grid point is W of coarse box
- enddo
- endif
-
-! 3. Do the latitude search S -> N for jmin and jmax
-
-20 jmin = 0
- jmax = 0
- do j=1,nflat ! loop over fine lats, S -> N
- if (flat(j) .gt. cNorth) goto 30 ! fine grid point is N of coarse box
- if (flat(j) .ge. cSouth .and. jmin.eq.0) jmin=j
- jmax=j
- enddo
-30 continue
-
-! 4. Sum
-
- sum = 0. ! Initialize coarse data value
- num = 0
-
- do j=jmin,jmax ! loop over fine lats, S -> N
- do i=imin,imax ! loop over fine lons, W -> E
- sum = sum + fine(i,j)
- num = num + 1
- enddo
- do i=imin1,imax1 ! If coarse cell strattles GM
- sum = sum + fine(i,j)
- num = num + 1
- enddo
- enddo
-
- if (num .gt. 0) then
- cmean(iclon,jclat) = sum/num
- else
- cmean(iclon,jclat) = 1.e30
- endif
-
- end do
- end do
- return
-end subroutine binf2c
diff --git a/tools/definesurf/cell_area.f90 b/tools/definesurf/cell_area.f90
deleted file mode 100644
index 2e8272aaeb..0000000000
--- a/tools/definesurf/cell_area.f90
+++ /dev/null
@@ -1,51 +0,0 @@
-subroutine cell_area (nlat, nlon, numlon, lon_w, lat_s, re, area)
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
-! ------------------------ code history ---------------------------
-! source file: cell_area.F
-! purpose: area of grid cells
-! date last revised: March 1996
-! author: Gordon Bonan
-! standardized:
-! reviewed:
-! -----------------------------------------------------------------
-
-! ------------------- input variables -----------------------------
- integer nlat !number of latitude points
- integer nlon !maximum number of longitude points
- integer numlon(nlat) !number of longitude points for each latitude
- real(r8) lon_w(nlon+1,nlat) !grid cell longitude, western edge (degrees)
- real(r8) lat_s(nlat+1) !grid cell latitude, southern edge (degrees)
-! -----------------------------------------------------------------
-
-! ------------------- output variables ----------------------------
- real(r8) re !radius of earth (km)
- real(r8) area(nlon,nlat) !cell area (km**2)
-! -----------------------------------------------------------------
-
-! ------------------- local variables -----------------------------
- integer i !longitude index
- integer j !latitude index
-
- real(r8) dx !cell width
- real(r8) dy !cell length
- real(r8) deg2rad !pi/180
- real(r8) one
- parameter (one=1.) ! Argument to atan
-! -----------------------------------------------------------------
-
- deg2rad = (4.*atan(one)) / 180.
- re = 6371.227709
-
- do j = 1, nlat
- do i = 1, numlon(j)
- dx = (lon_w(i+1,j)-lon_w(i,j)) * deg2rad
- dy = sin(lat_s(j+1)*deg2rad) - sin(lat_s(j)*deg2rad)
- area(i,j) = dx*dy*re*re
- end do
- end do
-
- return
-end subroutine cell_area
diff --git a/tools/definesurf/chkdims.f90 b/tools/definesurf/chkdims.f90
deleted file mode 100644
index cb9be4ce32..0000000000
--- a/tools/definesurf/chkdims.f90
+++ /dev/null
@@ -1,52 +0,0 @@
-subroutine chkdims (fileid, name, varid, londimid, latdimid, timdimid, verbose)
-
- implicit none
-
- include 'netcdf.inc'
-
- integer fileid, varid, londimid, latdimid
- integer timdimid
- logical verbose
- character*(*) name
-
- integer ret
- integer ndims, dimids(nf_max_dims)
-
- ret = nf_inq_varid (fileid, name, varid)
-
- if (ret.eq.NF_NOERR) then
-
- dimids(:) = -999
- ret = nf_inq_varndims (fileid, varid, ndims)
- ret = nf_inq_vardimid (fileid, varid, dimids)
-
- if (ret.ne.NF_NOERR) then
- write(6,*)'NF_INQ_VAR failed for ',name
- call handle_error (ret)
- end if
-
- if (ndims.eq.3 .and. dimids(3).ne.timdimid) then
- write(6,*)'3rd dim of ', name, ' must be time'
- call endrun
- end if
-
- if (dimids(1).ne.londimid .or. dimids(2).ne.latdimid) then
- write(6,*)'Dims of ', name,' must be lon by lat'
- call endrun
- end if
-
- if (verbose) write(6,*)'Overwriting existing ',name,' with hi-res topo'
-
- else
-
- dimids(1) = londimid
- dimids(2) = latdimid
- dimids(3) = timdimid
- if (verbose) write(6,*)name,' does not exist on netcdf file: Creating.'
- ret = nf_redef (fileid)
- ret = nf_def_var (fileid, name, NF_DOUBLE, 3, dimids, varid)
- if (ret.ne.NF_NOERR) call handle_error (ret)
- ret = nf_enddef (fileid)
-
- end if
-end subroutine chkdims
diff --git a/tools/definesurf/endrun.f90 b/tools/definesurf/endrun.f90
deleted file mode 100644
index 71b2194a6f..0000000000
--- a/tools/definesurf/endrun.f90
+++ /dev/null
@@ -1,7 +0,0 @@
-subroutine endrun
- implicit none
- include 'netcdf.inc'
-
- call abort
- stop 999
-end subroutine endrun
diff --git a/tools/definesurf/fmain.f90 b/tools/definesurf/fmain.f90
deleted file mode 100644
index c14b337c64..0000000000
--- a/tools/definesurf/fmain.f90
+++ /dev/null
@@ -1,458 +0,0 @@
-program fmain
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
-
- include 'netcdf.inc'
-!
-! Local workspace
-!
- real(r8), parameter :: fillvalue = 1.d36
- real(r8), parameter :: filter_coefficient = 0.25D0
-
- character(len=128) :: topofile = ' ' ! input high resolution (10 min) file name
- character(len=128) :: landmfile = ' ' ! input land mask file name
- character(len=128) :: gridfile = ' ' ! input initial condition file with grid definition
- character(len=128) :: outbcfile = ' ' ! output boundary condition file with PHIS, SGH, etc.
- character(len= 80) :: arg ! used for parsing command line arguments
- character(len=256) :: cmdline ! input command line
- character(len=256) :: history ! history attribute text
- character(len= 8) :: datestring
- character(len= 32) :: z_filter_type ! type of filter applied to height
- character(len= 32) :: s_filter_type ! type of filter applied to standard deviations
-
- logical verbose ! Add print statements
- logical make_ross ! Make Ross ice shelf south of -79
- logical filter_del2 ! Execute SJ Lin's del2 terrain filter
- logical filter_remap ! Execute SJ Lin's newer remapping terrain filter
- logical filter_sgh ! Filter SGH and SGH30 in addition to height
- logical reduced_grid ! reduced grid defined
- logical have_sgh30 ! input topofile has sgh30, output will also
-
- integer cmdlen ! character array lengths
- integer gridid
- integer foutid ! output file id
- integer lonid, londimid, rlonid ! longitude dimension variable ids
- integer latid, latdimid ! latitude dimension variable ids
- integer sghid, phisid, landfid, nlonid, landmid, sgh30id ! output variable netcdf ids
- integer start(4), count(4)
- integer plon, nlat
- integer i, j
- integer ret
- integer nargs ! input arg
- integer n ! index loops thru input args
-
- integer dim(2) ! dimension list for output variables
-
- integer , allocatable :: nlon(:)
- real(r8), allocatable :: mlatcnts(:) ! model cell center latitudes
- real(r8), allocatable :: mloncnts(:,:) ! model cell center longitudes
- real(r8), allocatable :: sgh(:,:)
- real(r8), allocatable :: sgh30(:,:)
- real(r8), allocatable :: phis(:,:)
- real(r8), allocatable :: fland(:,:)
- real(r8), allocatable :: landm(:,:)
-
- integer iargc
- external iargc
-!
-! Default settings before parsing argument list
-!
- verbose = .false.
- make_ross = .true.
- filter_del2 = .false.
- filter_remap = .false.
- filter_sgh = .false.
- reduced_grid = .false.
-
-! parse input arguments
-
- nargs = iargc()
- n = 1
- cmdline = char(10) // 'definesurf '
- do while (n .le. nargs)
- arg = ' '
- call getarg (n, arg)
- n = n + 1
-
- select case (arg)
-! topography file name (10')
- case ('-t')
- call getarg (n, arg)
- n = n + 1
- topofile = arg
- cmdline = trim(cmdline) // ' -t ' // trim(topofile)
-! grid file name
- case ('-g')
- call getarg (n, arg)
- n = n + 1
- gridfile = arg
- cmdline = trim(cmdline) // ' -g ' // trim(gridfile)
-! verbose mode
- case ('-v')
- verbose = .true.
- cmdline = trim(cmdline) // ' -v'
-! landmask file name
- case ('-l')
- call getarg (n, arg)
- n = n + 1
- landmfile = arg
- cmdline = trim(cmdline) // ' -l ' // trim(landmfile)
-! extend Ross Sea
- case ('-r')
- make_ross = .false.
- cmdline = trim(cmdline) // ' -r'
-! use del2 filter on heights
- case ('-del2')
- filter_del2 = .true.
- cmdline = trim(cmdline) // ' -del2'
-! use remap filter on heights
- case ('-remap')
- filter_remap = .true.
- cmdline = trim(cmdline) // ' -remap'
-! apply filter to sgh (and sgh30) in addition to height
- case ('-sgh')
- filter_sgh = .true.
- cmdline = trim(cmdline) // ' -sgh'
-! not one of the above, must be output file name
- case default
- if (outbcfile .eq. ' ') then
- outbcfile = arg
- else
- write (6,*) 'Argument ', arg,' is not known'
- call usage_exit (' ')
- end if
- cmdline = trim(cmdline) // ' ' // trim(arg)
- end select
- end do
-
- if (outbcfile == ' ') then
- call usage_exit ('Must enter an output file name')
- end if
-
- if (gridfile == ' ') then
- call usage_exit ('Must enter gridfile name via -g arg (can use a model history file)')
- end if
-
- if (topofile == ' ') then
- call usage_exit ('Must enter topofile name via -t arg')
- end if
-
- if (filter_remap .and. filter_del2) then
- write(6,*)'Both filter_remap and filter_del2 set: using filter_remap'
- end if
-
- if (.not. filter_remap .and. .not. filter_del2) then
- write(6,*)'No filter being applied to height field'
- if (filter_sgh) call usage_exit ('Must filter height to filter sgh')
- end if
-
- if (landmfile == ' ') then
- call usage_exit ('Must enter landmfile name via -l arg')
- end if
-
-! Open the grid file
- ret = nf_open (trim(gridfile), nf_nowrite, gridid)
- if (ret /= nf_noerr) then
- write(6,*)nf_strerror(ret)
- write(6,*)'Unable to open input file ', trim(gridfile), ' for writing'
- stop 999
- end if
-
-! Get the grid dimensions from the grid file
- call wrap_inq_dimid (gridid, 'lon', londimid)
- call wrap_inq_dimlen (gridid, londimid, plon )
- call wrap_inq_dimid (gridid, 'lat', latdimid)
- call wrap_inq_dimlen (gridid, latdimid, nlat )
-!
-! Get longitude and latitude arrays for model grid.
-! If reduced grid, 2-d variable containing lon values for each lat is called "rlon".
-! First allocate space for dynamic arrays now that sizes are known
-!
- allocate (nlon(nlat))
- allocate (mlatcnts(nlat))
- allocate (mloncnts(plon,nlat))
-
- if (nf_inq_varid (gridid, 'nlon', nlonid) == nf_noerr) then
- if (nf_get_var_int (gridid, nlonid, nlon) /= nf_noerr) then
- write(6,*)'nf_get_var_int() failed for nlon'
- call endrun
- end if
- reduced_grid = .true.
- else
- nlon(:) = plon
- end if
-
- do j=1,nlat
- if (nlon(j)<1 .or. nlon(j)>plon) then
- write(6,*)'nlon(',j,')=',nlon(j),' is invalid.'
- write(6,*)'Must be between 1 and ',plon
- call endrun
- end if
- end do
-
- call wrap_inq_varid (gridid, 'lat', latid)
- call wrap_get_var8 (gridid, latid, mlatcnts)
-
- if (nf_inq_varid (gridid, 'lon', lonid) == nf_noerr) then
- call wrap_get_var8 (gridid, lonid, mloncnts(1,1))
- do j=2,nlat
- mloncnts(:,j) = mloncnts(:,1)
- end do
- else
- call wrap_inq_varid (gridid, 'rlon', rlonid)
- call wrap_get_var8 (gridid, rlonid, mloncnts)
- end if
-
-! Close the grid file
- if (nf_close (gridid) == nf_noerr) then
- write(6,*) 'close grid file ', trim(gridfile)
- else
- write(6,*) 'ERROR CLOSING NETCDF FILE ',trim(gridfile)
- end if
-!
-! Allocate space for variables
-!
- allocate (sgh(plon,nlat))
- allocate (sgh30(plon,nlat))
- allocate (phis(plon,nlat))
- allocate (fland(plon,nlat))
- allocate (landm(plon,nlat))
-!
-! Determine model topographic height and 2 standard deviations
-!
- call sghphis (plon, nlat, nlon, mlatcnts, mloncnts, topofile, &
- verbose, sgh, sgh30, have_sgh30, phis, fland)
-
-! Do the terrain filter.
-! Note: not valid if a reduced grid is used.
- if (filter_remap) then
- z_filter_type = 'remap'
- write(6,*)'Remapping terrain filtering'
-! 7 and 3 are the recommended mapping accuracy settings
- call map2f (plon, nlat, phis, 7, 3, .true.)
- if (filter_sgh) then
- s_filter_type = 'remap'
- write(6,*)'Filtering standard deviation'
- call map2f (plon, nlat, sgh, 7, 3, .true.)
- if(have_sgh30) call map2f(plon, nlat, sgh30, 7, 3, .true.)
- else
- s_filter_type = 'none (2x[1-2-1])'
- write(6,*)'Not filtering standard deviation'
- end if
- else if (filter_del2) then
- z_filter_type = 'del2'
- write(6,*) 'Del2 Terrain filtering'
- call sm2(plon, nlat, phis, plon/12, filter_coefficient)
- if (filter_sgh) then
- s_filter_type = 'del2'
- write(6,*)'Filtering standard deviation'
- call sm2(plon, nlat, sgh, plon/12, filter_coefficient)
- if(have_sgh30) call sm2(plon, nlat, sgh30, plon/12, filter_coefficient)
- else
- s_filter_type = 'none (2x[1-2-1])'
- write(6,*)'Not filtering standard deviation'
- end if
- else
- z_filter_type = 'none'
- s_filter_type = 'none (2x[1-2-1])'
- endif
-!
-! Adjustments to land fraction:
-! 1. Extend land fraction for Ross Ice shelf
-! 2. Set land fractions < .001 to 0.0
-! 3. flag regions outside reduced grid
-!
- do j=1,nlat
- do i=1,nlon(j)
-!
-! Overwrite FLAND flag as land for Ross ice shelf
- if (make_ross .and. mlatcnts(j) < -79.) then
- fland(i,j) = 1.
- end if
-
- if (fland(i,j) < .001_r8) fland(i,j) = 0.0
-
- end do
-!
-! Fill region outside reduced grid with flag values
- do i=nlon(j)+1,plon
- sgh(i,j) = fillvalue
- if(have_sgh30) sgh30(i,j) = fillvalue
- phis(i,j) = fillvalue
- fland(i,j) = fillvalue
- landm(i,j) = fillvalue
- end do
- end do
-!
-! Calculate LANDM field required by cloud water.
-!
-!JR Replace original resolution-dependent calculation with interpolation.
-!JR
-!JR call inimland (plon, nlat, nlon, mlatcnts, mloncnts, topofile, &
-!JR verbose, make_ross, landm)
-!
- call interplandm (plon, nlat, nlon, mlatcnts, mloncnts, &
- landmfile, landm)
-
-! Create NetCDF file for output
- ret = nf_create (outbcfile, NF_CLOBBER, foutid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
-
-! Create dimensions for output
- call wrap_def_dim (foutid, 'lon', plon, lonid)
- call wrap_def_dim (foutid, 'lat', nlat, latid)
- dim(1)=lonid
- dim(2)=latid
-
-! Create latitude dimension variable for output
- ret = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latdimid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_text (foutid,latdimid,'long_name', 'latitude')
- call wrap_put_att_text (foutid,latdimid,'units' , 'degrees_north')
-
-! Create longitude dimension variable for output
- if (.not.reduced_grid) then
- ret = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, londimid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_text (foutid,londimid,'long_name', 'longitude')
- call wrap_put_att_text (foutid,londimid,'units' , 'degrees_east')
-
-! For reduced grid, add longitude limits (nlon) and lons (rlon)
- else
- ret = nf_def_var (foutid,'nlon', NF_INT, 1, lonid, londimid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- ret = nf_def_var (foutid,'rlon', NF_DOUBLE, 2, dim, rlonid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_text (foutid,rlonid,'long_name', 'longitude')
- call wrap_put_att_text (foutid,rlonid,'units' , 'degrees_east')
- end if
-
-! Create variables for output
- ret = nf_def_var (foutid,'PHIS' , NF_DOUBLE, 2, dim, phisid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_double (foutid, phisid, '_FillValue', nf_double, 1, fillvalue)
- call wrap_put_att_double (foutid, phisid, 'missing_value', nf_double, 1, fillvalue)
- call wrap_put_att_text (foutid, phisid, 'long_name' , 'surface geopotential')
- call wrap_put_att_text (foutid, phisid, 'units' , 'm2/s2')
- call wrap_put_att_text (foutid, phisid, 'from_hires', 'true')
- call wrap_put_att_text (foutid, phisid, 'filter' , z_filter_type)
-
- ret = nf_def_var (foutid,'SGH' , NF_DOUBLE, 2, dim, sghid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_double (foutid, sghid, '_FillValue', nf_double, 1, fillvalue)
- call wrap_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue)
- call wrap_put_att_text (foutid, sghid, 'long_name' , 'standard deviation of 10-min elevations')
- call wrap_put_att_text (foutid, sghid, 'units' , 'm')
- call wrap_put_att_text (foutid, sghid, 'from_hires', 'true')
- call wrap_put_att_text (foutid, sghid, 'filter' , s_filter_type)
-
- if (have_sgh30) then
- ret = nf_def_var (foutid,'SGH30' , NF_DOUBLE, 2, dim, sgh30id)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_double (foutid, sgh30id, '_FillValue', nf_double, 1, fillvalue)
- call wrap_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue)
- call wrap_put_att_text (foutid, sgh30id, 'long_name' , 'standard deviation of elevation from 30s to 10m')
- call wrap_put_att_text (foutid, sgh30id, 'units' , 'm')
- call wrap_put_att_text (foutid, sgh30id, 'from_hires', 'true')
- call wrap_put_att_text (foutid, sgh30id, 'filter' , s_filter_type)
- endif
-
- ret = nf_def_var (foutid,'LANDFRAC' , NF_DOUBLE, 2, dim, landfid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_double (foutid, landfid, '_FillValue', nf_double, 1, fillvalue)
- call wrap_put_att_double (foutid, landfid, 'missing_value', nf_double, 1, fillvalue)
- call wrap_put_att_text (foutid, landfid, 'long_name' , 'gridbox land fraction')
- call wrap_put_att_text (foutid, landfid, 'from_hires', 'true')
-
- ret = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, dim, landmid)
- if (ret .ne. NF_NOERR) call handle_error(ret)
- call wrap_put_att_double (foutid, landmid, '_FillValue', nf_double, 1, fillvalue)
- call wrap_put_att_double (foutid, landmid, 'missing_value', nf_double, 1, fillvalue)
- call wrap_put_att_text (foutid, landmid, 'long_name' , &
- 'land ocean transition mask: ocean (0), continent (1), transition (0-1)')
- call wrap_put_att_text (foutid, landmid, 'from_hires', 'true')
-
-! Define history attribute.
- call DATE_AND_TIME(DATE=datestring)
- history = 'Written on date: ' // datestring // cmdline
- call wrap_put_att_text (foutid, nf_global, 'history', history)
-
-! Define Ross Sea attribute
- if (make_ross) then
- write (6,*) 'Extending Ross ice shelf south of -79 degrees'
- call wrap_put_att_text (foutid, nf_global, 'make_ross', 'true')
- else
- write (6,*) 'Not doing anything special for Ross ice shelf'
- call wrap_put_att_text (foutid, nf_global, 'make_ross', 'false')
- end if
-
-! Define source file attributes
- call wrap_put_att_text (foutid, nf_global, 'topofile', topofile)
- cmdlen = len_trim (gridfile)
- call wrap_put_att_text (foutid, nf_global, 'gridfile', gridfile)
- cmdlen = len_trim (landmfile)
- call wrap_put_att_text (foutid, nf_global, 'landmask', landmfile)
-
-
-! End definition of netCDF file
- ret = nf_enddef (foutid)
- if (ret/=NF_NOERR) call handle_error (ret)
-
-
-! Write data to file
- write(6,*) 'Writing surface quantities'
-
-! Write dimension variables
- call wrap_put_var8 (foutid, latdimid, mlatcnts)
- if (.not.reduced_grid) then
- call wrap_put_var8 (foutid, londimid, mloncnts(:,1))
- else
- ret = nf_put_var_int (foutid, nlonid, nlon)
- if (ret/=NF_NOERR) call handle_error (ret)
- call wrap_put_vara8 (foutid, rlonid, start, count, mloncnts)
- end if
-
- start(:) = 1
- count(1) = plon
- count(2) = nlat
- count(3:) = 1
-
- call wrap_put_vara8 (foutid, sghid, start, count, sgh)
- if(have_sgh30) call wrap_put_vara8 (foutid, sgh30id, start, count, sgh30)
- call wrap_put_vara8 (foutid, phisid , start, count, phis)
- call wrap_put_vara8 (foutid, landfid, start, count, fland)
- call wrap_put_vara8 (foutid, landmid, start, count, landm)
-
- if (nf_close (foutid) == nf_noerr) then
- write(6,*) 'Successfully defined surface quantities on ', trim(outbcfile)
- else
- write(6,*) 'ERROR CLOSING NETCDF FILE ',trim(outbcfile)
- end if
-
- deallocate (nlon)
- deallocate (mlatcnts)
- deallocate (mloncnts)
- deallocate (sgh)
- deallocate (sgh30)
- deallocate (phis)
- deallocate (fland)
- deallocate (landm)
-
- stop 0
-end program fmain
-
-subroutine usage_exit (arg)
- implicit none
- character*(*) arg
-
- if (arg /= ' ') write (6,*) arg
- write (6,*) 'Usage: definesurf -t topofile -g gridfile -l landmfile [-v] [-r] [-del2] [-remap] outfile'
- write (6,*) ' -v verbose mode'
- write (6,*) ' -r Do *not* extend Ross Ice Shelf as land ice'
- write (6,*) ' -del2 use del2 terrain filter (not a valid option for reduced grid)'
- write (6,*) ' -remap use remapping filter (not a valid option for reduced grid)'
- write (6,*) ' -sgh filter sgh and sgh30 using same terrain filter'
- stop 999
-end subroutine usage_exit
diff --git a/tools/definesurf/handle_error.f90 b/tools/definesurf/handle_error.f90
deleted file mode 100644
index 519f829097..0000000000
--- a/tools/definesurf/handle_error.f90
+++ /dev/null
@@ -1,11 +0,0 @@
-subroutine handle_error (ret)
- implicit none
-
- integer ret
-
- include 'netcdf.inc'
-
- write(6,*) nf_strerror (ret)
- call abort
- stop 999
-end subroutine handle_error
diff --git a/tools/definesurf/inimland.f90 b/tools/definesurf/inimland.f90
deleted file mode 100644
index af929f1b98..0000000000
--- a/tools/definesurf/inimland.f90
+++ /dev/null
@@ -1,205 +0,0 @@
-subroutine inimland (plon, nlat, nlon_reduced, mlatcnts, mloncnts, topofile, &
- verbose, make_ross, landm_reduced)
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
-!
-! Input arguments
-!
- integer , intent(in) :: plon ! number of longitudes
- integer , intent(in) :: nlat ! number of latitudes
- integer , intent(in) :: nlon_reduced(nlat) ! number of reduced latitudes
- real(r8), intent(in) :: mlatcnts(nlat) ! latitude at center of grid cell
- real(r8), intent(in) :: mloncnts(plon,nlat) ! model cell ceneter longitudes
- character(len=*), intent(in) :: topofile ! high res topo file
- logical, intent(in) :: verbose ! verbose output
- logical, intent(in) :: make_ross ! flag to make Ross ice shelf
-!
-! Output arguments
-!
- real(r8), intent(out) :: landm_reduced(plon,nlat) ! landm on reduced grid
-
-! Local variables
-
- real(r8) landm(plon,nlat) ! landm on full grid
- real(r8) clon(plon)
- real(r8) clon_reduced(plon,nlat)
- real(r8) cont(plon,nlat)
- real(r8) temp(plon,nlat)
- real(r8) dmax
- real(r8) arad
- real(r8) dist
- real(r8) sum
- real(r8) cs(nlat)
- real(r8) ss(nlat)
- real(r8) c1
- real(r8) s1
- real(r8) c2
- real(r8) s2
- real(r8) dx
- real(r8) dy
- real(r8) term
- real(r8) pi
- real(r8) sgh(plon,nlat) ! required by SGHPHIS (unused locally)
- real(r8) phis(plon,nlat) ! required by SGHPHIS (unused locally)
- real(r8) oro(plon,nlat) ! land/ocean flag
- real(r8) fland(plon,nlat) ! land fraction output from SGHPHIS
- real(r8) mloncnts_full(plon,nlat) ! longitudes for rectangular grid
-
- integer i
- integer j
- integer ii
- integer jj
- integer iplm1
- integer jof
- integer iof
- integer itmp
- integer jmin, jmax
- integer nlon(nlat)
- integer latid
-
- pi = acos(-1.d0)
-!
-! Define longitudes for a rectangular grid: index nlat/2+1 will be a latitude
-! closest to the equator, i.e. with the most points in a reduced grid.
-!
- nlon(:) = plon
- do j=1,nlat
- mloncnts_full(:,j) = mloncnts(:,nlat/2+1)
- end do
-
- call sghphis (plon, nlat, nlon, mlatcnts, mloncnts_full, topofile, &
- verbose, sgh, phis, fland)
-!
-! Define land mask. Set all non-land points to ocean (i.e. not sea ice).
-!
- where (fland(:,:) >= 0.5)
- oro(:,:) = 1.
- elsewhere
- oro(:,:) = 0.
- endwhere
-!
-! Overwrite ORO flag as land for Ross ice shelf: note that the ORO field
-! defined in this routine is only used locally.
-!
- do j=1,nlat
- if (make_ross .and. mlatcnts(j) < -79.) then
- do i=1,plon
- oro(i,j) = 1.
- end do
- end if
- end do
-!
-! Code lifted directly from cldwat.F
-!
- dmax = 2.e6 ! distance to carry the mask
- arad = 6.37e6
- do i = 1,plon
- clon(i) = 2.*(i-1)*pi/plon
- end do
-!
-! first isolate the contenents
-! as land points not surrounded by ocean or ice
-!
- do j = 1,nlat
- cs(j) = cos(mlatcnts(j)*pi/180.)
- ss(J) = sin(mlatcnts(j)*pi/180.)
- do i = 1,plon
- cont(i,j) = 0.
- if (nint(oro(i,j)) .eq. 1) then
- cont(i,j) = 1.
- endif
- end do
- temp(1,j) = cont(1,j)
- temp(plon,j) = cont(plon,j)
- end do
-
- do i = 1,plon
- temp(i,1) = cont(i,1)
- temp(i,nlat) = cont(i,nlat)
- end do
-!
-! get rid of one and two point islands
-!
- do j = 2,nlat-1
- do i = 2,plon-1
- sum = cont(i ,j+1) + cont(i ,j-1) &
- + cont(i+1,j+1) + cont(i+1,j-1) &
- + cont(i-1,j+1) + cont(i-1,j-1) &
- + cont(i+1,j ) + cont(i-1,j) &
- + cont(i ,j )
- if (sum.le.2.) then
- temp(i,j) = 0.
- else
- temp(i,j) = 1.
- endif
- enddo
- end do
-
- do j = 1,nlat
- do i = 1,plon
- cont(i,j) = temp(i,j)
- end do
- end do
-!
-! construct a function which is one over land,
-! zero over ocean points beyond dmax from land
-!
- iplm1 = 2*plon - 1
- dy = pi*arad/nlat
- jof = dmax/dy + 1
-! write (6,*) ' lat bands to check ', 2*jof+1
- do j = 1,nlat
- c1 = cs(j)
- s1 = ss(j)
- dx = 2*pi*arad*cs(j)/plon
-!
-! if dx is too small, int(dmax/dx) may exceed the maximum size
-! of an integer, especially on Suns, causing a core dump. Test
-! to avoid that.
-!
- if (dx .lt. 1. .and. dmax .gt. 10000.) then
- iof = plon
- else
- iof = min(int(dmax/dx) + 1, plon)
- end if
- do i = 1,plon
- temp(i,j) = 0.
- landm(i,j) = 0.
- jmin = max(1,j-jof)
- jmax = min(nlat,j+jof)
- do jj = jmin, jmax
- s2 = ss(jj)
- c2 = cs(jj)
- do itmp = -iof,iof
- ii = mod(i+itmp+iplm1,plon)+1
- term = s1*s2 + c1*c2*cos(clon(ii)-clon(i))
- if (term.gt.0.9999999) term = 1.
- dist = arad*acos(term)
- landm(i,j) = max(landm(i,j), (1.-dist/dmax)*cont(ii,jj))
-! if (dist.lt.dmax .and. cont(ii,jj).eq.1) then
-! landm(i,j) = max(landm(i,j), 1.-dist/dmax)
-! endif
- end do
- end do
- end do
- end do
-!
-! Interpolate to reduced grid. Redefine clon in terms of degrees for interpolation
-!
- do i = 1,plon
- clon(i) = (i-1)*360./plon
- end do
- do j=1,nlat
- do i=1,nlon_reduced(j)
- clon_reduced(i,j) = (i-1)*360./nlon_reduced(j)
- end do
- end do
-
- do j=1,nlat
- call lininterp (landm(1,j), plon, 1, clon, &
- landm_reduced(1,j), nlon_reduced(j), 1, clon_reduced(1,j), .true.)
- end do
-
- return
- end
diff --git a/tools/definesurf/interplandm.f90 b/tools/definesurf/interplandm.f90
deleted file mode 100644
index 88e5fd3d17..0000000000
--- a/tools/definesurf/interplandm.f90
+++ /dev/null
@@ -1,92 +0,0 @@
-subroutine interplandm (plono, nlato, nlono, lato, rlono, &
- landmfile, landmo)
-!
-! Read LANDM_COSLAT from input file and interpolate to output grid.
-! The input grid is assumed rectangular, but the output grid may
-! be reduced.
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
-
- include 'netcdf.inc'
-!
-! Input arguments
-!
- integer , intent(in) :: plono ! output longitude dimension
- integer , intent(in) :: nlato ! number of latitudes
- integer , intent(in) :: nlono(nlato) ! number of reduced latitudes
- real(r8), intent(in) :: lato(nlato) ! latitude at center of grid cell
- real(r8), intent(in) :: rlono(plono,nlato) ! longitude on (potentially reduced) output grid
- character(len=*), intent(in) :: landmfile ! file containing input LANDM_COSLAT
-!
-! Output arguments
-!
- real(r8), intent(out) :: landmo(plono,nlato) ! landm on reduced grid
-
-! Local variables
-
- integer :: nloni
- integer :: nlati
- integer :: i,j ! spatial indices
- integer :: ret ! return code
-
- integer :: landmfileid ! netcdf file id for landm file
- integer :: londimid, latdimid ! lon, lat dimension ids
- integer :: lonid, latid ! lon, lat var ids
- integer :: landmid ! landm variable id
-
- real(r8), allocatable :: landmi(:,:) ! landm on full grid
- real(r8), allocatable :: lati(:)
- real(r8), allocatable :: loni(:)
- real(r8), allocatable :: xtemp(:,:) ! temporary for interpolation
-
- ret = nf_open (landmfile, nf_nowrite, landmfileid)
- if (ret /= nf_noerr) then
- write(6,*)nf_strerror(ret)
- write(6,*)'Unable to open input file ', trim (landmfile)
- stop 999
- end if
-!
-! Retrieve grid info and LANDM_COSLAT field from from offline file.
-!
- call wrap_inq_dimid (landmfileid, 'lat', latdimid)
- call wrap_inq_dimlen (landmfileid, latdimid, nlati)
-
- call wrap_inq_dimid (landmfileid, 'lon', londimid)
- call wrap_inq_dimlen (landmfileid, londimid, nloni)
-
- allocate (lati(nlati))
- allocate (loni(nloni))
- allocate (landmi(nloni,nlati))
-
- call wrap_inq_varid (landmfileid, 'lat', latid)
- call wrap_get_var8 (landmfileid, latid, lati)
-
- call wrap_inq_varid (landmfileid, 'lon', lonid)
- call wrap_get_var8 (landmfileid, lonid, loni)
-
- call wrap_inq_varid (landmfileid, 'LANDM_COSLAT', landmid)
- call wrap_get_var8 (landmfileid, landmid, landmi)
-
- allocate (xtemp(nloni,nlato))
-!
-! For rectangular -> reduced, interpolate first in latitude, then longitude
-!
- do i=1,nloni
- call lininterp (landmi(i,1), nlati, nloni, lati, &
- xtemp(i,1), nlato, nloni, lato, .false.)
- end do
-
- do j=1,nlato
- call lininterp (xtemp(1,j), nloni, 1, loni, &
- landmo(1,j), nlono(j), 1, rlono(1,j), .true.)
- end do
-
- deallocate (xtemp)
- deallocate (lati)
- deallocate (loni)
- deallocate (landmi)
-
- return
-end subroutine interplandm
diff --git a/tools/definesurf/lininterp.f90 b/tools/definesurf/lininterp.f90
deleted file mode 100644
index 9d5d9d9e76..0000000000
--- a/tools/definesurf/lininterp.f90
+++ /dev/null
@@ -1,174 +0,0 @@
-subroutine lininterp (arrin, nxin, incin, xin, &
- arrout, nxout, incout, xout, periodic)
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-!-----------------------------------------------------------------------
-!
-! Do a linear interpolation from input mesh defined by xin to output
-! mesh defined by xout. Where extrapolation is necessary, values will
-! be copied from the extreme edge of the input grid.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: J. Rosinski
-!
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- integer nxin, incin
- integer nxout, incout
-
- real(r8) xin(nxin), xout(nxout)
- real(r8) arrin(incin,nxin)
- real(r8) arrout(incout,nxout)
-
- logical periodic
-!
-! Local workspace
-!
- integer i, ii ! input grid indices
- integer im, ip, iiprev ! input grid indices
- integer icount ! number of values
-
- real(r8) extrap ! percent grid non-overlap
- real(r8) dxinwrap ! delta-x on input grid for 2-pi
- real(r8) avgdxin ! avg input delta-x
- real(r8) ratio ! compare dxinwrap to avgdxin
-!
-! Dynamic
-!
- integer iim(nxout) ! interp. indices minus
- integer iip(nxout) ! interp. indices plus
-
- real(r8) wgtm(nxout) ! interp. weight minus
- real(r8) wgtp(nxout) ! interp. weight plus
-!
-! Just copy the data and return if input dimensions are 1
-!
- if (nxin.eq.1 .and. nxout.eq.1) then
- arrout(1,1) = arrin(1,1)
- else if (nxin.eq.1) then
- write(6,*)'LININTERP: Must have at least 2 input points'
- call abort
- end if
- icount = 0
- do i=1,nxin-1
- if (xin(i).gt.xin(i+1)) icount = icount + 1
- end do
- do i=1,nxout-1
- if (xout(i).gt.xout(i+1)) icount = icount + 1
- end do
- if (icount.gt.0) then
- write(6,*)'LININTERP: Non-monotonic coordinate array(s) found'
- call abort
- end if
-!
-! Initialize index arrays for later checking
-!
- do i=1,nxout
- iim(i) = 0
- iip(i) = 0
- end do
- if (periodic) then
-!
-! Periodic case: for values which extend beyond boundaries, assume
-! periodicity and interpolate between endpoints. First check for sane
-! periodicity assumption.
-!
- if (xin(1).lt.0. .or. xin(nxin).gt.360.) then
- write(6,*)'LININTERP: For periodic Input x-grid must be between 0 and 360'
- call abort
- end if
- if (xout(1).lt.0. .or. xout(nxout).gt.360.) then
- write(6,*)'Output x-grid must be between 0 and 360'
- call abort
- end if
- dxinwrap = xin(1) + 360. - xin(nxin)
- avgdxin = (xin(nxin)-xin(1))/(nxin-1.)
- ratio = dxinwrap/avgdxin
- if (ratio.lt.0.9 .or. ratio.gt.1.1) then
- write(6,*)'LININTERP: Insane dxinwrap value =',dxinwrap,' avg=', avgdxin
- call abort
- end if
- do im=1,nxout
- if (xout(im).gt.xin(1)) exit
- iim(im) = nxin
- iip(im) = 1
- wgtm(im) = (xin(1) - xout(im)) /dxinwrap
- wgtp(im) = (xout(im)+360. - xin(nxin))/dxinwrap
- end do
- do ip=nxout,1,-1
- if (xout(ip).le.xin(nxin)) exit
- iim(ip) = nxin
- iip(ip) = 1
- wgtm(ip) = (xin(1)+360. - xout(ip)) /dxinwrap
- wgtp(ip) = (xout(ip) - xin(nxin))/dxinwrap
- end do
- else
-!
-! Non-periodic case: for values which extend beyond boundaries, set weights
-! such that values will just be copied.
-!
- do im=1,nxout
- if (xout(im).gt.xin(1)) exit
- iim(im) = 1
- iip(im) = 1
- wgtm(im) = 1.
- wgtp(im) = 0.
- end do
- do ip=nxout,1,-1
- if (xout(ip).le.xin(nxin)) exit
- iim(ip) = nxin
- iip(ip) = nxin
- wgtm(ip) = 1.
- wgtp(ip) = 0.
- end do
- end if
-!
-! Loop though output indices finding input indices and weights
-!
- iiprev = 1
- do i=im,ip
- do ii=iiprev,nxin-1
- if (xout(i).gt.xin(ii) .and. xout(i).le.xin(ii+1)) then
- iim(i) = ii
- iip(i) = ii + 1
- wgtm(i) = (xin(ii+1)-xout(i))/(xin(ii+1)-xin(ii))
- wgtp(i) = (xout(i)-xin(ii))/(xin(ii+1)-xin(ii))
- goto 30
- end if
- end do
- write(6,*)'LININTERP: Failed to find interp values'
-30 iiprev = ii
- end do
-!
-! Check grid overlap
-!
- extrap = 100.*((im - 1.) + (nxout - ip))/nxout
- if (extrap.gt.30.) then
- write(6,*)'********LININTERP WARNING:',extrap,' % of output', &
- ' grid will have to be extrapolated********'
- end if
-!
-! Check that interp/extrap points have been found for all outputs
-!
- icount = 0
- do i=1,nxout
- if (iim(i).eq.0 .or. iip(i).eq.0) icount = icount + 1
- end do
- if (icount.gt.0) then
- write(6,*)'LININTERP: Point found without interp indices'
- call abort
- end if
-!
-! Do the interpolation
-!
- do i=1,nxout
- arrout(1,i) = arrin(1,iim(i))*wgtm(i) + arrin(1,iip(i))*wgtp(i)
- end do
- return
-end subroutine lininterp
-
diff --git a/tools/definesurf/map2f.f90 b/tools/definesurf/map2f.f90
deleted file mode 100644
index 1fb58b3f8a..0000000000
--- a/tools/definesurf/map2f.f90
+++ /dev/null
@@ -1,1039 +0,0 @@
- subroutine map2f(im, jm, qm, iord, jord, pfilter)
-!
-! This is a stand alone 2-Grid-Wave filter for filtering the terrain for
-! the finite-volume dynamical core
-! Developed and coded by S.-J. Lin
-! Data Assimilation Office, NASA/GSFC
-!
- implicit none
-! Input
- integer, intent(in):: im ! E-W diimension (e.g., 144 for 2.5 deg)
- integer, intent(in):: jm ! N-S dimension (S pole to N pole; 91 for 2 deg)
- integer, intent(in):: iord ! Mapping accuracy for E-W; recommended value=7
- integer, intent(in):: jord ! Mapping accuracy for N-S; recommended value=3
- logical, intent(in):: pfilter ! Polar filter (set to .T. for normal application)
-
-! Input/Output
- real*8, intent(inout):: qm(im,jm) ! array to be filtered
-
-! Local
- integer im2, jm2
- integer ndeg
- real*8, allocatable:: q2(:,:)
- real*8, allocatable:: lon1(:)
- real*8, allocatable:: lon2(:)
- real*8, allocatable:: sin1(:)
- real*8, allocatable:: sin2(:)
- real*8, allocatable:: qt1(:,:), qt2(:,:)
-
- real*8 dx1, dx2
- real*8 dy1, dy2
-
- integer i, j
- real*8 pi
-
- ndeg = 45 ! starting latitude for polar filter
- pi = 4.d0 * datan(1.d0)
-
- im2 = im / 2
- if (im2*2 /= im) then
- write(*,*) 'Stop in map2f; im=', im
- stop
- endif
-
- jm2 = (jm-1) / 2 + 1
-
- allocate ( qt1(im2,jm) )
- allocate ( qt2(im2,jm2) )
-
- allocate ( q2(im2,jm2) )
- allocate ( lon1(im+1) )
- allocate ( lon2(im2+1) )
- allocate ( sin1(jm+1) )
- allocate ( sin2(jm2+1) )
-
- dx1 = 360./im
- dx2 = 360./im2
-
- dy1 = pi/(jm-1)
- dy2 = pi/(jm2-1)
-
- do i=1,im+1
- lon1(i) = dx1 * (-0.5 + (i-1) )
- enddo
-
- do i=1,im2+1
- lon2(i) = dx2 * (-0.5 + (i-1) )
- enddo
-
- sin1(1) = -1.
- sin2(1) = -1.
-
- sin1(jm +1) = 1.
- sin2(jm2+1) = 1.
-
- do j=2,jm
- sin1(j) = dsin( -0.5*pi + dy1*(-0.5+(j-1)) )
- enddo
-
- do j=2,jm2
- sin2(j) = dsin( -0.5*pi + dy2*(-0.5+(j-1)) )
- enddo
-
- call polavg(qm, im, jm, 1, jm)
- if( pfilter ) call plft2d(im, jm, qm, 2, jm-1, ndeg)
-
-!==============================
-! From full --> half resolution
-!==============================
-
- call xmap(iord, im, jm, sin1, lon1, qm, im2, lon2, qt1 )
- call ymap(im2, jm, sin1, qt1, jm2, sin2, qt2, 0, jord)
-
-!==============================
-! From half --> full resolution
-!==============================
-
- call ymap(im2, jm2, sin2, qt2, jm, sin1, qt1, 0, jord)
- call xmap(iord, im2, jm, sin1, lon2, qt1, im, lon1, qm )
-
-! Apply Monotonicity preserving polar filter
- if( pfilter ) call plft2d(im, jm, qm, 2, jm-1, ndeg)
- call polavg(qm, im, jm, 1, jm)
-
- deallocate ( q2 )
- deallocate ( lon1 )
- deallocate ( lon2 )
- deallocate ( sin1 )
- deallocate ( sin2 )
-
- deallocate ( qt1 )
- deallocate ( qt2 )
-
- return
- end
-
- subroutine polavg(p, im, jm, jfirst, jlast)
-
- implicit none
-
- integer im, jm, jfirst, jlast
- real*8 p(im,jfirst:jlast)
- real*8 sum1
- integer i
-
- if ( jfirst == 1 ) then
- sum1 = 0.
- do i=1,im
- sum1 = sum1 + p(i,1)
- enddo
- sum1 = sum1/im
-
- do i=1,im
- p(i,1) = sum1
- enddo
- endif
-
- if ( jlast == jm ) then
- sum1 = 0.
- do i=1,im
- sum1 = sum1 + p(i,jm)
- enddo
- sum1 = sum1/im
-
- do i=1,im
- p(i,jm) = sum1
- enddo
- endif
-
- return
- end
-
- subroutine setrig(im, jm, dp, dl, cosp, cose, sinp, sine)
-
- implicit none
-
- integer im, jm
- integer j, jm1
- real*8 sine(jm),cosp(jm),sinp(jm),cose(jm)
- real*8 dp, dl
- real*8 pi, ph5
-
- jm1 = jm - 1
- pi = 4.d0 * datan(1.d0)
- dl = (pi+pi)/dble(im)
- dp = pi/dble(jm1)
-
- do 10 j=2,jm
- ph5 = -0.5d0*pi + (dble(j-1)-0.5d0)*(pi/dble(jm1))
-10 sine(j) = dsin(ph5)
-
- cosp( 1) = 0.
- cosp(jm) = 0.
-
- do 80 j=2,jm1
-80 cosp(j) = (sine(j+1)-sine(j)) / dp
-
-! Define cosine at edges..
-
- do 90 j=2,jm
-90 cose(j) = 0.5 * (cosp(j-1) + cosp(j))
- cose(1) = cose(2)
-
- sinp( 1) = -1.
- sinp(jm) = 1.
-
- do 100 j=2,jm1
-100 sinp(j) = 0.5 * (sine(j) + sine(j+1))
-
- return
- end
-
- subroutine ymap(im, jm, sin1, q1, jn, sin2, q2, iv, jord)
-
-! Routine to perform area preserving mapping in N-S from an arbitrary
-! resolution to another.
-!
-! sin1 (1) = -1 must be south pole; sin1(jm+1)=1 must be N pole.
-!
-! sin1(1) < sin1(2) < sin1(3) < ... < sin1(jm) < sin1(jm+1)
-! sin2(1) < sin2(2) < sin2(3) < ... < sin2(jn) < sin2(jn+1)
-!
-! Developer: S.-J. Lin
-! First version: piece-wise constant mapping
-! Apr 1, 2000
-! Last modified:
-
- implicit none
-
-! Input
- integer im ! original E-W dimension
- integer jm ! original N-S dimension
- integer jn ! Target N-S dimension
- integer jord
- integer iv ! iv=0 scalar; iv=1: vector
- real*8 sin1(jm+1) ! original southern edge of the cell
- ! sin(lat1)
- real*8 sin2(jn+1) ! Target cell's southern edge
- real*8 q1(im,jm) ! original data at center of the cell
- ! sin(lat2)
-! Output
- real*8 q2(im,jn) ! Mapped data at the target resolution
-
-! Local
- integer i, j0, m, mm
- integer j
-
-! PPM related arrays
- real*8 al(im,jm)
- real*8 ar(im,jm)
- real*8 a6(im,jm)
- real*8 dy1(jm)
-
- real*8 r3, r23
- parameter ( r3 = 1./3., r23 = 2./3. )
- real*8 pl, pr, qsum, esl
- real*8 dy, sum
-
- do j=1,jm
- dy1(j) = sin1(j+1) - sin1(j)
- enddo
-
-! ***********************
-! Area preserving mapping
-! ***********************
-
-! Construct subgrid PP distribution
- if ( jord == 1 ) then
-
- do j=1,jm
- do i=1,im
- a6(i,j) = 0.
- ar(i,j) = q1(i,j)
- al(i,j) = q1(i,j)
- enddo
- enddo
-
- else
-
- call ppm_lat(im, jm, q1, al, ar, a6, jord, iv)
- do i=1,im
-! SP
- a6(i, 1) = 0.
- ar(i, 1) = q1(i,1)
- al(i, 1) = q1(i,1)
-! NP
- a6(i,jm) = 0.
- ar(i,jm) = q1(i,jm)
- al(i,jm) = q1(i,jm)
- enddo
- endif
-
- do 1000 i=1,im
- j0 = 1
- do 555 j=1,jn
- do 100 m=j0,jm
-!
-! locate the southern edge: sin2(i)
-!
- if(sin2(j) .ge. sin1(m) .and. sin2(j) .le. sin1(m+1)) then
- pl = (sin2(j)-sin1(m)) / dy1(m)
- if(sin2(j+1) .le. sin1(m+1)) then
-! entire new cell is within the original cell
- pr = (sin2(j+1)-sin1(m)) / dy1(m)
- q2(i,j) = al(i,m) + 0.5*(a6(i,m)+ar(i,m)-al(i,m)) &
- *(pr+pl)-a6(i,m)*r3*(pr*(pr+pl)+pl**2)
- j0 = m
- goto 555
- else
-! South most fractional area
- qsum = (sin1(m+1)-sin2(j))*(al(i,m)+0.5*(a6(i,m)+ &
- ar(i,m)-al(i,m))*(1.+pl)-a6(i,m)* &
- (r3*(1.+pl*(1.+pl))))
- do mm=m+1,jm
-! locate the eastern edge: sin2(j+1)
- if(sin2(j+1) .gt. sin1(mm+1) ) then
-! Whole layer
- qsum = qsum + dy1(mm)*q1(i,mm)
- else
-! North most fractional area
- dy = sin2(j+1)-sin1(mm)
- esl = dy / dy1(mm)
- qsum = qsum + dy*(al(i,mm)+0.5*esl* &
- (ar(i,mm)-al(i,mm)+a6(i,mm)*(1.-r23*esl)))
- j0 = mm
- goto 123
- endif
- enddo
- goto 123
- endif
- endif
-100 continue
-123 q2(i,j) = qsum / ( sin2(j+1) - sin2(j) )
-555 continue
-1000 continue
-
-! Final processing for poles
-
- if ( iv == 0 ) then
-
-! South pole
- sum = 0.
- do i=1,im
- sum = sum + q2(i,1)
- enddo
-
- sum = sum / im
- do i=1,im
- q2(i,1) = sum
- enddo
-
-! North pole:
- sum = 0.
- do i=1,im
- sum = sum + q2(i,jn)
- enddo
-
- sum = sum / im
- do i=1,im
- q2(i,jn) = sum
- enddo
-
- endif
-
- return
- end
-
- subroutine ppm_lat(im, jm, q, al, ar, a6, jord, iv)
- implicit none
-
-!INPUT
- integer im, jm ! Dimensions
- real*8 q(im,jm)
- real*8 al(im,jm)
- real*8 ar(im,jm)
- real*8 a6(im,jm)
- integer jord
- integer iv ! iv=0 scalar
- ! iv=1 vector
-! Local
- real*8 dm(im,jm)
- real*8 r3
- parameter ( r3 = 1./3. )
- integer i, j, im2, iop, jm1
- real*8 tmp, qmax, qmin
- real*8 qop
-
-! Compute dm: linear slope
-
- do j=2,jm-1
- do i=1,im
- dm(i,j) = 0.25*(q(i,j+1) - q(i,j-1))
- qmax = max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j)
- qmin = q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1))
- dm(i,j) = sign(min(abs(dm(i,j)),qmin,qmax),dm(i,j))
- enddo
- enddo
-
- im2 = im/2
- jm1 = jm - 1
-
-!Poles:
- if (iv == 1 ) then
-! SP
- do i=1,im
- if( i .le. im2) then
- qop = -q(i+im2,2)
- else
- qop = -q(i-im2,2)
- endif
- tmp = 0.25*(q(i,2) - qop)
- qmax = max(q(i,2),q(i,1), qop) - q(i,1)
- qmin = q(i,1) - min(q(i,2),q(i,1), qop)
- dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp)
- enddo
-! NP
- do i=1,im
- if( i .le. im2) then
- qop = -q(i+im2,jm1)
- else
- qop = -q(i-im2,jm1)
- endif
- tmp = 0.25*(qop - q(i,jm1))
- qmax = max(qop,q(i,jm), q(i,jm1)) - q(i,jm)
- qmin = q(i,jm) - min(qop,q(i,jm), q(i,jm1))
- dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp)
- enddo
- else
-!
-!*********
-! Scalar:
-!*********
-! SP
- do i=1,im2
- tmp = 0.25*(q(i,2)-q(i+im2,2))
- qmax = max(q(i,2),q(i,1), q(i+im2,2)) - q(i,1)
- qmin = q(i,1) - min(q(i,2),q(i,1), q(i+im2,2))
- dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp)
- enddo
-
- do i=im2+1,im
- dm(i, 1) = - dm(i-im2, 1)
- enddo
-! NP
- do i=1,im2
- tmp = 0.25*(q(i+im2,jm1)-q(i,jm1))
- qmax = max(q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm)
- qmin = q(i,jm) - min(q(i+im2,jm1),q(i,jm), q(i,jm1))
- dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp)
- enddo
-
- do i=im2+1,im
- dm(i,jm) = - dm(i-im2,jm)
- enddo
- endif
-
- do j=2,jm
- do i=1,im
- al(i,j) = 0.5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j))
- enddo
- enddo
-
- do j=1,jm-1
- do i=1,im
- ar(i,j) = al(i,j+1)
- enddo
- enddo
-
- do j=2,jm-1
- do i=1,im
- a6(i,j) = 3.*(q(i,j)+q(i,j) - (al(i,j)+ar(i,j)))
- enddo
-
- call lmppm(dm(1,j), a6(1,j), ar(1,j), &
- al(1,j), q(1,j), im, jord-3)
- enddo
-
- return
- end
-
- subroutine xmap(iord, im, jm, sin1, lon1, q1, in, lon2, q2)
-
-! Routine to perform area preserving mapping in E-W from an arbitrary
-! resolution to another.
-! Periodic domain will be assumed, i.e., the eastern wall bounding cell
-! im is lon1(im+1) = lon1(1); Note the equal sign is true geographysically.
-!
-! lon1(1) < lon1(2) < lon1(3) < ... < lon1(im) < lon1(im+1)
-! lon2(1) < lon2(2) < lon2(3) < ... < lon2(in) < lon2(in+1)
-!
-! Developer: S.-J. Lin
-! First version: piece-wise constant mapping
-! Apr 1, 2000
-! Last modified:
-
- implicit none
-
-! Input
- integer iord
- integer im ! original E-W dimension
- integer in ! Target E-W dimension
- integer jm ! original N-S dimension
- real*8 lon1(im+1) ! original western edge of the cell
- real*8 sin1(jm+1)
- real*8 q1(im,jm) ! original data at center of the cell
- real*8 lon2(in+1) ! Target cell's western edge
-
-! Output
- real*8 q2(in,jm) ! Mapped data at the target resolution
-
-! Local
- integer i1, i2
- integer i, i0, m, mm
- integer j
- integer ird
-
-! PPM related arrays
- real*8 qtmp(-im:im+im)
- real*8 al(-im:im+im)
- real*8 ar(-im:im+im)
- real*8 a6(-im:im+im)
- real*8 x1(-im:im+im+1)
- real*8 dx1(-im:im+im)
- real*8 r3, r23
- parameter ( r3 = 1./3., r23 = 2./3. )
- real*8 pl, pr, qsum, esl
- real*8 dx
- logical found
-
- do i=1,im+1
- x1(i) = lon1(i)
- enddo
-
- do i=1,im
- dx1(i) = x1(i+1) - x1(i)
- enddo
-
-! check to see if ghosting is necessary
-
-!**************
-! Western edge:
-!**************
- found = .false.
- i1 = 1
- do while ( .not. found )
- if( lon2(1) .ge. x1(i1) ) then
- found = .true.
- else
- i1 = i1 - 1
- if (i1 .lt. -im) then
- write(6,*) 'failed in xmap'
- stop
- else
- x1(i1) = x1(i1+1) - dx1(im+i1)
- dx1(i1) = dx1(im+i1)
- endif
- endif
- enddo
-
-!**************
-! Eastern edge:
-!**************
- found = .false.
- i2 = im+1
- do while ( .not. found )
- if( lon2(in+1) .le. x1(i2) ) then
- found = .true.
- else
- i2 = i2 + 1
- if (i2 .gt. 2*im) then
- write(6,*) 'failed in xmap'
- stop
- else
- dx1(i2-1) = dx1(i2-1-im)
- x1(i2) = x1(i2-1) + dx1(i2-1)
- endif
- endif
- enddo
-
- do 1000 j=1,jm
-
-! ***********************
-! Area preserving mapping
-! ***********************
-
-! Construct subgrid PP distribution
- if ( abs(sin1(j)+sin1(j+1)) > 1.5 ) then
- ird = 3
- elseif ( abs(sin1(j)+sin1(j+1)) < 1.0 ) then
- ird = 8
- else
- ird = iord
- endif
-
- if ( iord == 1 ) then
- do i=1,im
- qtmp(i) = q1(i,j)
- al(i) = q1(i,j)
- ar(i) = q1(i,j)
- a6(i) = 0.
- enddo
- qtmp(0 ) = q1(im,j)
- qtmp(im+1) = q1(1, j)
- else
- call ppm_cycle(im, q1(1,j), al(1), ar(1), a6(1), qtmp, ird)
- endif
-
-! check to see if ghosting is necessary
-
-! Western edge
- if ( i1 .le. 0 ) then
- do i=i1,0
- qtmp(i) = qtmp(im+i)
- al(i) = al(im+i)
- ar(i) = ar(im+i)
- a6(i) = a6(im+i)
- enddo
- endif
-
-! Eastern edge:
- if ( i2 .gt. im+1 ) then
- do i=im+1,i2-1
- qtmp(i) = qtmp(i-im)
- al(i) = al(i-im)
- ar(i) = ar(i-im)
- a6(i) = a6(i-im)
- enddo
- endif
-
- i0 = i1
-
- do 555 i=1,in
- do 100 m=i0,i2-1
-!
-! locate the western edge: lon2(i)
-!
- if(lon2(i) .ge. x1(m) .and. lon2(i) .le. x1(m+1)) then
- pl = (lon2(i)-x1(m)) / dx1(m)
- if(lon2(i+1) .le. x1(m+1)) then
-! entire new grid is within the original grid
- pr = (lon2(i+1)-x1(m)) / dx1(m)
- q2(i,j) = al(m) + 0.5*(a6(m)+ar(m)-al(m)) &
- *(pr+pl)-a6(m)*r3*(pr*(pr+pl)+pl**2)
- i0 = m
- goto 555
- else
-! Left most fractional area
- qsum = (x1(m+1)-lon2(i))*(al(m)+0.5*(a6(m)+ &
- ar(m)-al(m))*(1.+pl)-a6(m)* &
- (r3*(1.+pl*(1.+pl))))
- do mm=m+1,i2-1
-! locate the eastern edge: lon2(i+1)
- if(lon2(i+1) .gt. x1(mm+1) ) then
-! Whole layer
- qsum = qsum + dx1(mm)*qtmp(mm)
- else
-! Right most fractional area
- dx = lon2(i+1)-x1(mm)
- esl = dx / dx1(mm)
- qsum = qsum + dx*(al(mm)+0.5*esl* &
- (ar(mm)-al(mm)+a6(mm)*(1.-r23*esl)))
- i0 = mm
- goto 123
- endif
- enddo
- goto 123
- endif
- endif
-100 continue
-123 q2(i,j) = qsum / ( lon2(i+1) - lon2(i) )
-555 continue
-1000 continue
-
- return
- end
-
- subroutine ppm_cycle(im, q, al, ar, a6, p, iord)
- implicit none
-
- real*8 r3
- parameter ( r3 = 1./3. )
-
-! Input
- integer im, iord
- real*8 q(1)
-! Output
- real*8 al(1)
- real*8 ar(1)
- real*8 a6(1)
- real*8 p(-im:im+im)
-
-! local
- real*8 dm(0:im)
- integer i, lmt
- real*8 tmp, qmax, qmin
-
- p(0) = q(im)
- do i=1,im
- p(i) = q(i)
- enddo
- p(im+1) = q(1)
-
-! 2nd order slope
- do i=1,im
- tmp = 0.25*(p(i+1) - p(i-1))
- qmax = max(p(i-1), p(i), p(i+1)) - p(i)
- qmin = p(i) - min(p(i-1), p(i), p(i+1))
- dm(i) = sign(min(abs(tmp),qmax,qmin), tmp)
- enddo
- dm(0) = dm(im)
-
- do i=1,im
- al(i) = 0.5*(p(i-1)+p(i)) + (dm(i-1) - dm(i))*r3
- enddo
-
- do i=1,im-1
- ar(i) = al(i+1)
- enddo
- ar(im) = al(1)
-
- do i=1,im
- a6(i) = 3.*(p(i)+p(i) - (al(i)+ar(i)))
- enddo
-
- if(iord <= 6) then
- lmt = iord - 3
- if(lmt <= 2) call lmppm(dm(1),a6(1),ar(1),al(1),p(1),im,lmt)
- else
- call huynh(im, ar(1), al(1), p(1), a6(1), dm(1))
- call lmppm(dm(1),a6(1),ar(1),al(1),p(1),im,2)
- endif
-
- return
- end
-
- subroutine lmppm(dm, a6, ar, al, p, im, lmt)
- implicit none
- real*8 r12
- parameter ( r12 = 1./12. )
-
- integer im, lmt
- integer i
- real*8 a6(im),ar(im),al(im),p(im),dm(im)
- real*8 da1, da2, fmin, a6da
-
-! LMT = 0: full monotonicity
-! LMT = 1: semi-monotonic constraint (no undershoot)
-! LMT = 2: positive-definite constraint
-
- if(lmt.eq.0) then
-
-! Full constraint
- do 100 i=1,im
- if(dm(i) .eq. 0.) then
- ar(i) = p(i)
- al(i) = p(i)
- a6(i) = 0.
- else
- da1 = ar(i) - al(i)
- da2 = da1**2
- a6da = a6(i)*da1
- if(a6da .lt. -da2) then
- a6(i) = 3.*(al(i)-p(i))
- ar(i) = al(i) - a6(i)
- elseif(a6da .gt. da2) then
- a6(i) = 3.*(ar(i)-p(i))
- al(i) = ar(i) - a6(i)
- endif
- endif
-100 continue
-
- elseif(lmt == 1) then
-! Semi-monotonic constraint
- do 150 i=1,im
- if(abs(ar(i)-al(i)) .ge. -a6(i)) go to 150
- if(p(i).lt.ar(i) .and. p(i).lt.al(i)) then
- ar(i) = p(i)
- al(i) = p(i)
- a6(i) = 0.
- elseif(ar(i) .gt. al(i)) then
- a6(i) = 3.*(al(i)-p(i))
- ar(i) = al(i) - a6(i)
- else
- a6(i) = 3.*(ar(i)-p(i))
- al(i) = ar(i) - a6(i)
- endif
-150 continue
- elseif(lmt == 2) then
-! Positive definite constraint
- do 250 i=1,im
- if(abs(ar(i)-al(i)) >= -a6(i)) go to 250
- fmin = p(i) + 0.25*(ar(i)-al(i))**2/a6(i) + a6(i)*r12
- if(fmin >= 0.) go to 250
- if(p(i).lt.ar(i) .and. p(i).lt.al(i)) then
- ar(i) = p(i)
- al(i) = p(i)
- a6(i) = 0.
- elseif(ar(i) .gt. al(i)) then
- a6(i) = 3.*(al(i)-p(i))
- ar(i) = al(i) - a6(i)
- else
- a6(i) = 3.*(ar(i)-p(i))
- al(i) = ar(i) - a6(i)
- endif
-250 continue
- endif
- return
- end
-
- subroutine huynh(im, ar, al, p, d2, d1)
-
-! Enforce Huynh's 2nd constraint in 1D periodic domain
-
- implicit none
- integer im, i
- real*8 ar(im)
- real*8 al(im)
- real*8 p(im)
- real*8 d2(im)
- real*8 d1(im)
-
-! Local scalars:
- real*8 pmp
- real*8 lac
- real*8 pmin
- real*8 pmax
-
-! Compute d1 and d2
- d1(1) = p(1) - p(im)
- do i=2,im
- d1(i) = p(i) - p(i-1)
- enddo
-
- do i=1,im-1
- d2(i) = d1(i+1) - d1(i)
- enddo
- d2(im) = d1(1) - d1(im)
-
-! Constraint for AR
-! i = 1
- pmp = p(1) + 2.0 * d1(1)
- lac = p(1) + 0.5 * (d1(1)+d2(im)) + d2(im)
- pmin = min(p(1), pmp, lac)
- pmax = max(p(1), pmp, lac)
- ar(1) = min(pmax, max(ar(1), pmin))
-
- do i=2, im
- pmp = p(i) + 2.0*d1(i)
- lac = p(i) + 0.5*(d1(i)+d2(i-1)) + d2(i-1)
- pmin = min(p(i), pmp, lac)
- pmax = max(p(i), pmp, lac)
- ar(i) = min(pmax, max(ar(i), pmin))
- enddo
-
-! Constraint for AL
- do i=1, im-1
- pmp = p(i) - 2.0*d1(i+1)
- lac = p(i) + 0.5*(d2(i+1)-d1(i+1)) + d2(i+1)
- pmin = min(p(i), pmp, lac)
- pmax = max(p(i), pmp, lac)
- al(i) = min(pmax, max(al(i), pmin))
- enddo
-
-! i=im
- i = im
- pmp = p(im) - 2.0*d1(1)
- lac = p(im) + 0.5*(d2(1)-d1(1)) + d2(1)
- pmin = min(p(im), pmp, lac)
- pmax = max(p(im), pmp, lac)
- al(im) = min(pmax, max(al(im), pmin))
-
-! compute A6 (d2)
- do i=1, im
- d2(i) = 3.*(p(i)+p(i) - (al(i)+ar(i)))
- enddo
- return
- end
-
- subroutine plft2d(im, jm, p, JS, JN, ndeg)
-!
-! This is a weak LOCAL polar filter.
-! Developer: Shian-Jiann Lin
-
- implicit none
-
- integer im
- integer jm
- integer js, jn, ndeg
- real*8 p(im,jm)
-
- integer i, j, n, ideg, jj, jc
- real*8 cosp(jm),cose(jm)
- real*8 a(0:im/2+1)
-
- real*8 sine(jm),sinp(jm)
- real*8, allocatable, save :: se(:), sc(:)
-
- real*8 pi, dp, dl, e0, ycrit, coszc, smax, rn, rn2, esl, tmp
-
- data IDEG /0/
-
- if(IDEG .ne. ndeg) then
- IDEG = ndeg
-! (e0 = 2.6)
- e0 = 0.5 * sqrt(27.)
- PI = 4. * ATAN(1.)
-
- allocate( sc(jm), se(jm))
-
- call setrig(im, jm, dp, dl, cosp, cose, sinp, sine)
-
- ycrit = IDEG*PI/180.
- coszc = cos(ycrit)
-
- smax = (jm-1)/2
- write(6,*) 'Critical latitude in local pft = ',ndeg
-
- a(0) = 1.
- do n=1,im/2+1
- rn = n
- rn2 = 2*n
- a(n) = sqrt(rn2+1.) * ((rn2+1.)/rn2)**rn
- enddo
-
- do j=2,jm-1
- sc(j) = coszc / cosp(j)
-
- IF(sc(j) > 1. .and. sc(j) <= 1.5 ) THEN
- esl = 1./ sc(j)
- sc(j) = 1. + (1.-esl) / (1.+esl)
- ELSEIF(sc(j) > 1.5 .and. sc(j) <= e0 ) THEN
- esl = 1./ sc(j)
- sc(j) = 1. + 2./ (27.*esl**2 - 2.)
- ELSEIF(sc(j) > e0) THEN
-! Search
- do jj=1,im/2
- if(sc(j) <= a(jj)) then
- jc = jj
-! write(*,*) 'jc=', jc
- goto 111
- endif
- enddo
- jc = im/2 + 1
-111 continue
-
- tmp = ((sc(j) - a(jc-1))/(a(jc) - a(jc-1)))**0.25
- sc(j) = jc + min(1.d0, tmp)
-! sc(j) = min(smax,sc(j))
- ENDIF
- enddo
-! ====================================================
- do j=2,jm
- se(j) = coszc / cose(j)
- IF(se(j) > 1. .and. se(j) <= 1.5 ) THEN
- esl = 1./ se(j)
- se(j) = 1. + (1.-esl) / (1.+esl)
- ELSEIF(se(j) > 1.5 .and. se(j) <= e0 ) THEN
- esl = 1./ se(j)
- se(j) = 1. + 2./ (27.*esl**2 - 2.)
- ELSEIF(se(j) > e0) THEN
-! Search
- do jj=1,im/2
- if(se(j) <= a(jj)) then
- jc = jj
- goto 222
- endif
- enddo
-
- jc = im/2 + 1
-222 continue
- tmp = ((se(j) - a(jc-1))/(a(jc) - a(jc-1)))**0.25
- se(j) = jc + min(1.d0, tmp)
-! se(j) = min(smax,se(j))
- ENDIF
- enddo
-
- do i=1,im
- se( 2) = sc(2)
- se(jm) = sc(jm-1)
- enddo
-
- do j=2,jm-1
-! write(*,*) j,sc(j)
- enddo
- ENDIF
-
- if( JN == (jm-1) ) then
-! Cell-centered variables
- call lpft(im, jm, p, 2, jm-1, Sc)
- else
-! Cell-edge variables
- call lpft(im, jm, p, 2, jm, Se)
- endif
- return
- end
-
-
- subroutine lpft(im, jm, p, j1, j2, s)
- implicit none
-
- integer im, jm, j1, j2
- real*8 p(im,jm)
- real*8 s(jm)
-
-! Local
- integer i, j, n, nt
-
- real*8 ptmp(0:im+1)
- real*8 q(0:im+1)
- real*8 frac, rsc, bt
-
- do 2500 j=j1,j2
- if(s(j) > 1.02) then
-
- NT = INT(S(j))
- frac = S(j) - NT
- NT = NT-1
-
- rsc = 1. / (1.+frac)
- bt = 0.5 * frac
-
- do i=1,im
- ptmp(i) = p(i,j)
- enddo
-
- ptmp(0) = p(im,j)
- ptmp(im+1) = p(1 ,j)
-
- if( NT < 1 ) then
- do i=1,im
- p(i,j) = rsc * (ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1)))
- enddo
- else
- do i=1,im
- q(i) = rsc * (ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1)))
- enddo
-
- do 500 N=1,NT
- q(0) = q(im)
- do i=1,im
- ptmp(i) = q(i) + q(i-1)
- enddo
- ptmp(im+1) = ptmp(1)
-
- if ( n == nt ) then
- do i=1,im
- p(i,j) = 0.25*(ptmp(i) + ptmp(i+1))
- enddo
- else
- do i=1,im
- q(i) = 0.25*(ptmp(i) + ptmp(i+1))
- enddo
- endif
-500 continue
- endif
- endif
-2500 continue
-
- return
- end
diff --git a/tools/definesurf/map_i.f90 b/tools/definesurf/map_i.f90
deleted file mode 100644
index d73e02e7db..0000000000
--- a/tools/definesurf/map_i.f90
+++ /dev/null
@@ -1,136 +0,0 @@
-subroutine map_i (nlon_i , nlat_i , numlon_i, lon_i , lat_i, &
- nlon_o , nlat_o , numlon_o, lon_o , lat_o, &
- mxovr_i2o, iovr_i2o, jovr_i2o, wovr_i2o)
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-! ------------------------ code history ---------------------------
-! source file: map_i.F
-! purpose: driver for area averaging initialization
-! date last revised: July 2000
-! author: Mariana Vertenstein
-! -----------------------------------------------------------------
-
-! ------------------------ notes ----------------------------------
-! o get indices and weights for area-averaging:
-!
-! from input surface grid to output model grid
-!
-! o input surface and output model grids can be any resolution BUT:
-!
-! both grids must be oriented south to north, i.e., cell(lat+1)
-! must be north of cell(lat). the southern edge of the first row
-! must be -90 (south pole) and the northern edge of the last row
-! must be +90 (north pole)
-!
-! both grids must be oriented eastwards, i.e., cell(lon+1) must be
-! east of cell(lon). but the two grids do not have to start at the
-! same longitude, i.e., one grid can start at dateline and go east;
-! the other grid can start at greenwich and go east. longitudes for
-! the western edge of the cells must increase continuously and span
-! 360 degrees. examples
-! dateline : -180 to 180 (- longitudes west of greenwich)
-! greenwich : 0 to 360
-! greenwich (centered): -dx/2 to -dx/2 + 360 (- longitudes west of greenwich)
-!
-! o field values fld_i on an input grid with dimensions nlon_i and nlat_i =>
-! field values fld_o on an output grid with dimensions nlon_o and nlat_o as
-!
-! fld_o(io,jo) =
-! fld_i(i_ovr(io,jo, 1 ),j_ovr(io,jo, 1 )) * w_ovr(io,jo, 1 ) +
-! fld_i(i_ovr(io,jo,mxovr_i),j_ovr(io,jo,mxovr_i)) * w_ovr(io,jo,mxovr_i)
-!
-! o error checks:
-! overlap weights of input cells sum to 1 for each output cell
-! global sums of dummy fields are conserved for input => model area-averaging
-! -----------------------------------------------------------------
-
-! ------------------- arguments -----------------------------------
- integer , intent(in) :: nlon_i !input grid max number of longitude points
- integer , intent(in) :: nlat_i !input grid number of latitude points
- integer , intent(in) :: numlon_i(nlat_i) !input grid number of longitude points at each lat
- real(r8), intent(in) :: lon_i(nlon_i+1,nlat_i) !input grid cell longitude, west edge (degrees)
- real(r8), intent(in) :: lat_i(nlat_i+1) !input grid cell latitude, south edge (degrees)
- integer , intent(in) :: nlon_o !model grid max number of longitude points
- integer , intent(in) :: nlat_o !model grid number of latitude points
- integer , intent(in) :: numlon_o(nlat_o) !model grid number of longitude points at each lat
- real(r8), intent(in) :: lon_o(nlon_o+1,nlat_o) !model grid cell longitude, west edge (degrees)
- real(r8), intent(in) :: lat_o(nlat_o+1) !model grid cell latitude, south edge (degrees)
- integer , intent(in) :: mxovr_i2o !max number of input cells that overlap model cell
- integer , intent(out):: iovr_i2o(nlon_o,nlat_o,mxovr_i2o) !lon index of overlap input cell
- integer , intent(out):: jovr_i2o(nlon_o,nlat_o,mxovr_i2o) !lat index of overlap input cell
- real(r8), intent(out):: wovr_i2o(nlon_o,nlat_o,mxovr_i2o) !weight of overlap input cell
-! -----------------------------------------------------------------
-!
-! ------------------- local variables -----------------------------
-!
- real(r8) fld_i(nlon_i,nlat_i) !dummy input grid field
- real(r8) fld_o(nlon_o,nlat_o) !dummy model grid field
- real(r8) area_i(nlon_i,nlat_i) !input grid cell area
- real(r8) area_o(nlon_o,nlat_o) !model grid cell area
- real(r8) re !radius of earth
- real(r8) sum_fldo !global sum of dummy model field
- real(r8) sum_fldi !global sum of dummy input field
- integer io,ii !model and input longitude loop indices
- integer jo,ji !model and input latitude loop indices
- real(r8), parameter :: relerr = 0.000001 !relative error for error checks
-! -----------------------------------------------------------------
-
-! -----------------------------------------------------------------
-! get cell areas
-! -----------------------------------------------------------------
-
- call cell_area (nlat_i, nlon_i, numlon_i, lon_i, lat_i, re, area_i)
-
- call cell_area (nlat_o, nlon_o, numlon_o, lon_o, lat_o, re, area_o)
-
-! -----------------------------------------------------------------
-! get indices and weights for mapping from input grid to model grid
-! -----------------------------------------------------------------
-
- call ao_i (nlon_i , nlat_i , numlon_i, lon_i , lat_i , &
- nlon_o , nlat_o , numlon_o, lon_o , lat_o , &
- mxovr_i2o, iovr_i2o , jovr_i2o, wovr_i2o , re , &
- area_o , relerr )
-
-! -----------------------------------------------------------------
-! error check: global sum fld_o = global sum fld_i
-! -----------------------------------------------------------------
-!
-! make dummy input field and sum globally
-!
- sum_fldi = 0.
- do ji = 1, nlat_i
- do ii = 1, numlon_i(ji)
- fld_i(ii,ji) = (ji-1)*nlon_i + ii
- sum_fldi = sum_fldi + area_i(ii,ji)*fld_i(ii,ji)
- end do
- end do
-!
-! area-average model field from input field
-!
- call area_ave (nlat_i , nlon_i , numlon_i ,fld_i , &
- nlat_o , nlon_o , numlon_o ,fld_o , &
- iovr_i2o , jovr_i2o , wovr_i2o , mxovr_i2o)
-!
-! global sum of model field
-!
- sum_fldo = 0.
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
- sum_fldo = sum_fldo + area_o(io,jo)*fld_o(io,jo)
- end do
- end do
-!
-! check for conservation
-!
- if ( abs(sum_fldo/sum_fldi-1.) > relerr ) then
- write (6,*) 'map_i error srf => model: srf field not conserved'
- write (6,'(a23,e20.10)') 'global sum model field = ',sum_fldo
- write (6,'(a23,e20.10)') 'global sum srf field = ',sum_fldi
- call endrun
- end if
-
- return
-end subroutine map_i
diff --git a/tools/definesurf/max_ovr.f90 b/tools/definesurf/max_ovr.f90
deleted file mode 100644
index 46b01fdc38..0000000000
--- a/tools/definesurf/max_ovr.f90
+++ /dev/null
@@ -1,93 +0,0 @@
-subroutine max_ovr (nlon_i, nlat_i, numlon_i, nlon_o, nlat_o, numlon_o, &
- lon_i , lat_i , lon_o , lat_o , novr_max)
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-! -----------------------------------------------------------------
- implicit none
-! ------------------------ code history ---------------------------
-! source file: max_ovr
-! purpose: determine maximum number of overlapping cells
-! input and output grids
-! date last revised: March 1997
-! author: Mariana Vertenstein
-! standardized:
-! reviewed:
-! -----------------------------------------------------------------
-
-! ------------------- input variables -----------------------------
- integer, intent(in) :: nlon_i !number of input longitude points
- integer, intent(in) :: nlat_i !number of input latitude points
- integer, intent(in) :: numlon_i(nlat_i) !number of longitude points for each input grid cell latitude
- integer, intent(in) :: nlon_o !number of output longitude points
- integer, intent(in) :: nlat_o !number of output latitude points
- integer, intent(in) :: numlon_o(nlat_o) !number of longitude points for each output grid cell latitude
- real(r8), intent(in) :: lon_i(nlon_i+1,nlat_i) !input grid cell longitude, western edge
- real(r8), intent(in) :: lat_i(nlat_i+1) !input grid cell latitude, southern edge
- real(r8), intent(in) :: lon_o(nlon_o+1,nlat_o) !output grid cell longitude, western edge
- real(r8), intent(in) :: lat_o(nlat_o+1) !output grid cell latitude , southern edge
- integer , intent(out):: novr_max !maximum number of overlapping input cells
-! -----------------------------------------------------------------
-
-! ------------------- local variables -----------------------------
- integer novr !number of overlapping input cells
- integer io,ii !output and input grids longitude loop index
- integer jo,ji !output and input grids latitude loop index
-! -----------------------------------------------------------------
-
-
-! -----------------------------------------------------------------
-! for each output grid cell: find overlapping input grid cell and area of
-! input grid cell that overlaps with output grid cell. cells overlap if:
-!
-! southern edge of input grid < northern edge of output grid AND
-! northern edge of input grid > southern edge of output grid
-!
-! western edge of input grid < eastern edge of output grid AND
-! eastern edge of input grid > western edge of output grid
-!
-! lon_o(io,jo) lon_o(io+1,jo)
-!
-! | |
-! --------------------- lat_o(jo+1)
-! | |
-! | |
-! xxxxxxxxxxxxxxx lat_i(ji+1) |
-! x | x |
-! x input | x output |
-! x cell | x cell |
-! x ii,ji | x io,jo |
-! x | x |
-! x ----x---------------- lat_o(jo )
-! x x
-! xxxxxxxxxxxxxxx lat_i(ji )
-! x x
-! lon_i(ii,ji) lon_i(ii+1,ji)
-! -----------------------------------------------------------------
-
-!
-! determine maximum number of overlapping cells
-! loop through all input grid cells to find overlap with output grid.
-! code does not vectorize but is only called during initialization.
-!
- novr_max = 0
- do jo = 1, nlat_o
- do io = 1, numlon_o(jo)
- novr = 0
- do ji = 1, nlat_i
- if (lat_i(ji ).lt.lat_o(jo+1) .and. &
- lat_i(ji+1).gt.lat_o(jo )) then !lat ok
- do ii = 1, numlon_i(ji)
- if (lon_i(ii ,ji).lt.lon_o(io+1,jo) .and. &
- lon_i(ii+1,ji).gt.lon_o(io ,jo)) then !lon okay
- novr = novr + 1 ! increment number of ovrlap cells for io,jo
- end if
- end do
- end if
- end do
- if (novr .gt. novr_max) novr_max = novr
- end do
- end do
-
- return
-end subroutine max_ovr
diff --git a/tools/definesurf/sghphis.f90 b/tools/definesurf/sghphis.f90
deleted file mode 100644
index 39a694aa84..0000000000
--- a/tools/definesurf/sghphis.f90
+++ /dev/null
@@ -1,340 +0,0 @@
-subroutine sghphis (plon, plat, numlons, mlatcnts, mloncnts, &
- topofile, verbose, sgh, sgh30, have_sgh30, phis, fland )
-
-!-----------------------------------------------------------------------
-!
-! Read high resolution topo dataset and calculate values of phis and sgh
-! for the model resolution this model
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
- implicit none
- include 'netcdf.inc'
-!
-!-----------------------------------------------------------------------
-!
-! parameters
-!
- integer , parameter :: ntopolon = 2160
- integer , parameter :: ntopolat = 1080
- integer , parameter :: n2x2lon = 180
- integer , parameter :: n2x2lat = 90
- integer , parameter :: n3x3lon = 120
- integer , parameter :: n3x3lat = 60
- real(r8), parameter :: r8_360 = 360. ! For argument compatibility to mod
-!
-! arguments
-!
- integer , intent(in) :: plon ! maximum number of model longitudes
- integer , intent(in) :: plat ! number of model latitudes
- integer , intent(in) :: numlons(plat) ! number of model longitudes per latitude
- real(r8), intent(in) :: mlatcnts(plat) ! model cell center latitudes
- real(r8), intent(in) :: mloncnts(plon,plat) ! model cell ceneter longitudes
- logical , intent(in) :: verbose ! true => verbose output
- character(len=*), intent(in) :: topofile ! high resolution topo file
- real(r8), intent(out):: phis(plon,plat) ! model geopotention height
- real(r8), intent(out):: sgh(plon,plat) ! model standard dev of geopotential height above 10min
- real(r8), intent(out):: sgh30(plon,plat) ! model standard dev of geopotential height from 30s to 10m
- logical , intent(out):: have_sgh30 ! true => variance is on topofile, sgh30 will be output
- real(r8), intent(out):: fland(plon,plat) ! model fractional land
-!
-! Local workspace : note that anything with plon or plat in its dimension is dynamic
-!
- real(r8) wt ! weight for area averaging
- real(r8) dx,dy ! increments for definition of intermed grid
-
-! high resolution topo grid
-
- integer lonid_topo, latid_topo ! input topo file vars
- integer htopoid,ftopoid,ret,varianceid ! input topo file vars
- real(r8) tloncnts(ntopolon) ! topo cell center lon boundaries
- real(r8) tlatcnts(ntopolat) ! topo cell center lat boundaries
- real(r8) tlons(ntopolon+1,ntopolat) ! topo cell W lon boundaries
- real(r8) tlats(ntopolat+1) ! topo cell N lat boundaries
- real(r8) ftopo(ntopolon,ntopolat) ! Land fraction array
- real(r8) htopo(ntopolon,ntopolat) ! Topographic heights
- real(r8) variance(ntopolon,ntopolat) ! Variance of elev at 30sec
-
-! intermediate grid
-
- real(r8) lons3x3(n3x3lon+1,n3x3lat) ! list of topo cell W lon boundaries
- real(r8) lats3x3(n3x3lat+1) ! list of topo cell N lat boundaries
- integer num3x3lons(n3x3lat) ! number if longitudes per latitude
- real(r8) mnhgt3x3(n3x3lon,n3x3lat) ! intermediate topo height
- real(r8) varhgt3x3(n3x3lon,n3x3lat) ! intermediate topovariance
-
-! model grid
-
- real(r8) mlons(plon+1,plat) ! model cell W lon boundaries
- real(r8) mlats(plat+1) ! model cell N lat boundaries
- real(r8) mnhgt(plon,plat) ! model topographic height
- real(r8) varhgt(plon,plat) ! model topographic variance
- real(r8) summn, sumvar ! use only for pole point calculations
-
-! other vars
-
- real(r8) xmax ! temporary variable
- real(r8), parameter :: eps = 1.e-6 ! eps criterion for pole point
- integer imax, jmax ! indices
- integer i,j,ii,ji,io,jo,n ! indices
- integer ncid_topo ! topographic netcdf id
- integer ioe
- integer mxovr ! max number of fine grid points used in area calculation of model grid point
-!
-! Space needed in 3 dimensions to store the initial data. This space is
-! required because the input data file does not have a predetermined
-! ordering of the latitude records. A specific order is imposed in the
-! transforms so that the results will be reproducible.
-!
-! Dynamic
-!
- integer , allocatable :: iovr(:,:,:) ! lon index of overlap input cell
- integer , allocatable :: jovr(:,:,:) ! lat index of overlap input cell
- real(r8), allocatable :: wovr(:,:,:) ! weight of overlap input cell
-!
-!-----------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-! Read in navy topo cell locations and determine cell edges (Uniform grid)
-!----------------------------------------------------------------------------
-!
- ret = nf_open (topofile, nf_nowrite, ncid_topo)
- if (ret == nf_noerr) then
- if (verbose) write(6,*)'Successfully opened netcdf topofile ',trim(topofile)
- ret = nf_inq_varid (ncid_topo, 'variance', varianceid)
- if (ret == NF_NOERR) then
- if (verbose) write(6,*)'Found a new style topofile.'
- call wrap_get_var8 (ncid_topo, varianceid, variance )
- call wrap_inq_varid (ncid_topo, 'landfract', ftopoid )
- have_sgh30 = .true.
- else
- if (verbose) write(6,*)'Found an old style topofile.'
- call wrap_inq_varid (ncid_topo, 'ftopo', ftopoid )
- have_sgh30 = .false.
- end if
- call wrap_get_var8 (ncid_topo, ftopoid, ftopo)
- call wrap_inq_varid (ncid_topo, 'htopo', htopoid )
- call wrap_get_var8 (ncid_topo, htopoid, htopo)
- else
- write(6,*)'cannot open topo file successfully'
- call endrun
- endif
-
- call wrap_inq_varid (ncid_topo, 'lon', lonid_topo)
- call wrap_inq_varid (ncid_topo, 'lat', latid_topo)
-
- call wrap_get_var8 (ncid_topo, latid_topo, tlatcnts)
- call wrap_get_var8 (ncid_topo, lonid_topo, tloncnts)
- ret = nf_close (ncid_topo)
-
- tloncnts(:) = mod(tloncnts(:)+r8_360,r8_360)
-
- tlats(:) = 1.e36
- tlats(1) = -90. ! south pole
- do j = 2, ntopolat
- tlats(j) = (tlatcnts(j-1) + tlatcnts(j)) / 2. ! southern edges
- end do
- tlats(ntopolat+1) = 90. ! north pole
-
- tlons(:,:) = 1.e36
- do j = 1,ntopolat
- dx = 360./ntopolon
- tlons(1,j) = tloncnts(1) - dx/2.
- do i = 2, ntopolon
- tlons(i,j) = tloncnts(i) - dx/2.
- end do
- tlons(ntopolon+1,j) = tloncnts(ntopolon) + dx/2.
- end do
-!
-!----------------------------------------------------------------------------
-! Determine model cell edges
-!----------------------------------------------------------------------------
-!
- mlats(:) = 1.e36
- mlats(1) = -90. ! south pole
- do j = 2,plat
- mlats(j) = (mlatcnts(j-1) + mlatcnts(j)) / 2. ! southern edges
- end do
- mlats(plat+1) = 90. ! north pole
-
- do j = 1,plat
- dx = 360./(numlons(j))
- do i = 1,plon+1
- mlons(i,j) = -dx/2. + (i-1)*dx
- end do
- end do
-
-!
-!----------------------------------------------------------------------------
-! Calculate fractional land
-!----------------------------------------------------------------------------
-!
- call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,ftopo, &
- mlons ,mlats ,plon ,plat ,fland)
-!
-!----------------------------------------------------------------------------
-! Calculate standard deviation of elevation from 30sec to 10min
-!----------------------------------------------------------------------------
-
- if (have_sgh30) then
- call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,variance, &
- mlons ,mlats ,plon ,plat ,sgh30)
- else
- sgh30 = -1
- endif
-!-------------------------------------------------------------------------
-! Calculate determine mean and variance of topographic height, plon >=128
-!-------------------------------------------------------------------------
-!
- if (plon >= 128) then
- call binf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,htopo, &
- mlons ,mlats ,plon ,plat ,mnhgt)
-
- call varf2c(tloncnts ,tlatcnts ,ntopolon ,ntopolat ,htopo , &
- mlons ,mlats ,plon ,plat ,mnhgt , &
- varhgt )
- end if
-
-!-------------------------------------------------------------------------
-! Calculate determine mean and variance of topographic height, plon < 128
-!-------------------------------------------------------------------------
-
- if (plon < 128) then
-!
-! bin to uniform 3x3 deg grid then area avg to output grid
-! get 3x3 cell boundaries for binning routine
-!
- dy = 180./n3x3lat
- do j = 1, n3x3lat+1
- lats3x3(j) = -90.0 + (j-1)*dy
- end do
-
- num3x3lons(:) = n3x3lon
- do j = 1,n3x3lat
- dx = 360./(num3x3lons(j))
- do i = 1, num3x3lons(j)+1
- lons3x3(i,j) = 0. + (i-1)*dx
- end do
- end do
-!
-! bin mean height to intermed grid
-!
- call binf2c (tloncnts, tlatcnts, ntopolon, ntopolat, htopo, &
- lons3x3 , lats3x3 , n3x3lon , n3x3lat , mnhgt3x3)
-!
-! get variation of topography mean height over the intermed grid
-!
- call varf2c (tloncnts, tlatcnts, ntopolon, ntopolat, htopo , &
- lons3x3 , lats3x3 , n3x3lon , n3x3lat , mnhgt3x3, &
- varhgt3x3 )
-!
-! get maximum number of 3x3 cells which will to be used in area average
-! for each model cell
-!
- call max_ovr (n3x3lon, n3x3lat, num3x3lons, plon , plat, numlons, &
- lons3x3, lats3x3, mlons , mlats , mxovr )
-!
-! do area average from intermediate regular grid to gauss grid
-! get memory for pointer based arrays
-!
- allocate(iovr(plon,plat,mxovr))
- allocate(jovr(plon,plat,mxovr))
- allocate(wovr(plon,plat,mxovr))
-
- call map_i (n3x3lon, n3x3lat, num3x3lons, lons3x3, lats3x3, &
- plon , plat , numlons , mlons , mlats , &
- mxovr , iovr , jovr , wovr )
-
- do jo = 1, plat
- do io = 1, numlons(jo)
- mnhgt(io,jo) = 0.
- varhgt(io,jo) = 0.
- do n = 1, mxovr ! overlap cell index
- ii = iovr(io,jo,n) ! lon index (input grid) of overlap cell
- ji = jovr(io,jo,n) ! lat index (input grid) of overlap cell
- wt = wovr(io,jo,n) ! overlap weight
- mnhgt(io,jo) = mnhgt(io,jo) + mnhgt3x3(ii,ji) * wt
- varhgt(io,jo) = varhgt(io,jo) + varhgt3x3(ii,ji) * wt
- end do
- end do
- end do
-
-! If model grid contains pole points, then overwrite above values of phis and sgh at the
-! poles with average of values of nearest 2x2 band - this is a fair approximation and
-! is done so that above mapping routines do not have to be rewritten to correctly evaulte
-! the area average of the pole points
-
- if (mlatcnts(1)-eps < -90.0 .and. mlatcnts(plat)+eps > 90.0) then
- write(6,*)' determining sgh and phis at poles'
- summn = 0
- sumvar = 0
- do io = 1,numlons(2)
- summn = summn + mnhgt(io,2)
- sumvar = sumvar + varhgt(io,2)
- end do
- do io = 1,numlons(1)
- mnhgt(io,1) = summn/numlons(2)
- varhgt(io,1) = sumvar/numlons(2)
- end do
- summn = 0
- sumvar = 0
- do io = 1,numlons(plat-1)
- summn = summn + mnhgt(io,plat-1)
- sumvar = sumvar + varhgt(io,plat-1)
- end do
- do io = 1,numlons(plat)
- mnhgt(io,plat) = summn/numlons(plat-1)
- varhgt(io,plat) = sumvar/numlons(plat-1)
- end do
- endif
-
- deallocate(iovr)
- deallocate(jovr)
- deallocate(wovr)
-
- end if
-
-! 1-2-1 smoothing for variation height
-
- call sm121(varhgt,plon,plat,numlons)
- call sm121(varhgt,plon,plat,numlons)
- if (have_sgh30) then
- call sm121(sgh30,plon,plat,numlons)
- call sm121(sgh30,plon,plat,numlons)
- end if
-!
-! get standard deviation for smoothed height field
-!
-! determine geopotential height field. The multiplication by 9.80616
-! causes phis to be only accurate to 32-bit roundoff on some machines
-!
- xmax = -1.d99
- do jo=1,plat
- do io=1,numlons(jo)
- if (varhgt(io,jo) < 0.5) then
- sgh(io,jo) = 0.
- else
- sgh(io,jo) = sqrt(varhgt(io,jo))
- end if
- if (have_sgh30) then
- if (sgh30(io,jo) < 0.5) then
- sgh30(io,jo) = 0.
- else
- sgh30(io,jo) = sqrt(sgh30(io,jo))
- end if
- end if
- if (sgh(io,jo) > xmax) then
- xmax = sgh(io,jo)
- imax = io
- jmax = jo
- end if
- phis(io,jo) = mnhgt(io,jo) * 9.80616
- end do
- end do
-
- if (verbose) write(6,*)'Max SGH =',xmax,' at i,j=', imax, jmax
-
- return
-end subroutine sghphis
diff --git a/tools/definesurf/shr_kind_mod.f90 b/tools/definesurf/shr_kind_mod.f90
deleted file mode 100644
index fc1ed8e94a..0000000000
--- a/tools/definesurf/shr_kind_mod.f90
+++ /dev/null
@@ -1,20 +0,0 @@
-!===============================================================================
-! CVS: $Id$
-! CVS: $Source$
-! CVS: $Name$
-!===============================================================================
-
-MODULE shr_kind_mod
-
- !----------------------------------------------------------------------------
- ! precision/kind constants add data public
- !----------------------------------------------------------------------------
- public
- integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
- integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
- integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
- integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
- integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
- integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
-
-END MODULE shr_kind_mod
diff --git a/tools/definesurf/sm121.f90 b/tools/definesurf/sm121.f90
deleted file mode 100644
index c4b491616a..0000000000
--- a/tools/definesurf/sm121.f90
+++ /dev/null
@@ -1,86 +0,0 @@
-subroutine sm121 (a, plon, nlat, nlon)
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-!
-! perform 1-2-1 smoothing using data array a. On reduced grid, linearly
-! interpolate to a rectangular grid (nlon(j),3) before interpolating
-!
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------Arguments---------------------------------
-
- integer plon ! Input: Lon dim
- integer nlat ! Input: Lat dim
- integer nlon(nlat) ! Number of longitudes per latitude
- real(r8) a(plon,nlat) ! I/O: Array to be smoothed
-
-!--------------------------Local variables------------------------------
-
- integer i,j ! Indices
- integer imin,imax ! Indices
- integer jmax,jmin ! Indices
-!
-! Dynamic
-!
- real(r8) xin(plon,nlat)
- real(r8) xout(plon)
- real(r8) temp(plon,nlat) ! Temp array
- real(r8) tempjmin(plon) ! Temp array
- real(r8) tempjmax(plon) ! Temp array
-!
-!-----------------------------------------------------------------------
-!
- temp(:,:) = a(:,:)
-!
-! first do the S and N boundaries.
-!
- do i=1,nlon(1)
- imin = i - 1
- imax = i + 1
- if( imin .lt. 1 ) imin = imin + nlon(1)
- if( imax .gt. nlon(1)) imax = imax - nlon(1)
- a(i,1) = (temp(imin,1) + 3.*temp(i,1) +temp(imax,1))/5.
- end do
-
- do i=1,nlon(nlat)
- imin = i - 1
- imax = i + 1
- if( imin .lt. 1 ) imin = imin + nlon(nlat)
- if( imax .gt. nlon(nlat)) imax = imax - nlon(nlat)
- a(i,nlat) = (temp(imin,nlat)+3.*temp(i,nlat)+temp(imax,nlat))/5.
- end do
-!
-! Define xin array for each latitude
-!
- do j=1,nlat
- do i=1,nlon(j)
- xin(i,j) = (i-1)*360./nlon(j)
- end do
- end do
-!
-! Linearly interpolate data N and S of each target latitude to the longitudes
-! of each target latitude before applying 1-2-1 filter
-!
- do j=2,nlat-1
- jmin = j - 1
- jmax = j + 1
- xout(:) = xin(:,j)
- call lininterp (temp(1,jmin), nlon(jmin), 1, xin(1,jmin), &
- tempjmin, nlon(j), 1, xout, .true.)
- call lininterp (temp(1,jmax), nlon(jmax), 1, xin(1,jmax), &
- tempjmax, nlon(j), 1, xout, .true.)
-
- do i=1,nlon(j)
- imin = i - 1
- imax = i + 1
- if( imin .lt. 1 ) imin = imin + nlon(j)
- if( imax .gt. nlon(j)) imax = imax - nlon(j)
- a(i,j) = (tempjmin(i) + &
- temp(imin,j) + 4.*temp(i,j) + temp(imax,j) + &
- tempjmax(i) ) / 8.
- enddo
- enddo
-!
- return
-end subroutine sm121
diff --git a/tools/definesurf/terrain_filter.f90 b/tools/definesurf/terrain_filter.f90
deleted file mode 100644
index fb80d9c492..0000000000
--- a/tools/definesurf/terrain_filter.f90
+++ /dev/null
@@ -1,320 +0,0 @@
-! Terrain Filter
-!
-! Contributed by S.J. Lin.
-!
-! Added to the definesurf program by G. Grant, 30 June 2000.
-! Updated with latest version from S.J. by B. Eaton, 23 August 2001
-!
-! Notes from S.J.:
-!
-! "I compute the unsmoothed mean height and the variance
-! exactly the same as the standard CCM utility. The only difference
-! is the grid being uniformly spaced from North pole to South pole.
-! The filter is applied to the mean height and the sqaure root of
-! the variance (the standard deviation).
-!
-! For the 2x2.5 deg resolution
-!
-! mlon = 144
-! mlat = 91
-!
-! Assuming the mean height is Z(mlon,mlat), and the standard deviation
-! (the sqaure root of the variance) is SD(moln,mlat), the filter
-! algorithm goes like this:
-!
-! call sm2(mlon, mlat, Z, itmax_Z, 0.25D0)
-! call sm2(mlon, mlat, SD, itmax_SD, 0.25D0)
-!
-! where 0.25D0 is the dimensionless filter coefficient, and
-!
-! itmax_Z = 2*mlat
-! itmax_SD = mlon
-!
-! [As discussed elsewhere] the above filtering is a bit too strong.
-! But it is the filter I used up to now.
-! I am currently testing the following setting
-!
-! itmax_Z = mlat/2
-! itmax_SD = mlon/4
-! "
-
-
- subroutine sm2(im, jm, ht, itmax, c)
-!
-! Del-2 diffusion on the sphere
-!
- implicit none
-
-! Input:
- integer im ! e-w dimension (eg, 144 for 2.5 deg resolution)
- integer jm ! n-s doemsnion (eg, 91 for 2 deg resolution)
- integer itmax ! iteration count
- real*8 c ! filter coefficient
-
-! Input/Output
- real*8 ht(im,jm) ! array to be filtered
-
-! Local
- real*8 dg(im,jm) ! del2 of h
- real*8 cose(jm), cosp(jm), sinp(jm), sine(jm)
- real*8 dl
- real*8 dp
- real*8 fmin, fmax
- integer jm1
- integer mnk, mxk
- integer ndeg
- integer it, i, j
- real*8 s1, s2
-
- jm1 = jm-1
-
- call setrig(im, jm, dp, DL, cosp, cose, sinp, sine)
-
- call pmnx(ht, im, jm, fmin, fmax, mnk, mxk)
- write(6,*) 'hmax=', fmax,' at j= ',mxk
- write(6,*) 'hmin=', fmin,' at j= ',mnk
-
- ndeg = 60 ! starting latitude for the monotonicity
- ! preserving polar filter
-
- call pmnx(ht,im,jm,fmin,fmax,mnk,mxk)
- write(6,*) 'hmax=', fmax,' at j= ',mxk
- write(6,*) 'hmin=', fmin,' at j= ',mnk
-
-! Apply Monotonicity preserving polar filter
- call plft2d(im, jm, ht, 2, jm1, ndeg)
- call avgp2(ht, sine, im, jm)
-
- do it=1,itmax
- call del2(ht, im, jm, dg, cosp, cose, sine, DL, dp, ndeg)
- call plft2d(im, jm, dg, 2, jm1, ndeg)
-
- do j=1,jm
- do i=1,im
- ht(i,j) = ht(i,j) + c*dg(i,j)
- enddo
- enddo
- enddo
-
-! Final polar filter
- call plft2d(im, jm, ht, 2, jm1, ndeg)
-
- return
- end
-
- subroutine del2(h, im, jm, dg, cosp, cose, sine, dL, dp, ndeg)
- implicit none
-
-! AE = 1 (unit radius)
-! Input:
- integer im
- integer jm
- integer ndeg
-! Input-output
-
- real*8 h(im,jm)
- real*8 dg(im,jm) ! del2 of h
- real*8 cose(jm),cosp(jm)
- real*8 sine(jm)
- real*8 PI, ycrit, coszc, CD
- real*8 DL, dp
-
-! Local
- real*8 fx(im,jm) ! e-w fluxes
- real*8 fy(im,jm) ! n-s fluxes
- integer i, j
-
- call grad(h, im, jm, fx, fy, cosp, dl, dp)
-
- PI = 4. * ATAN(1.)
- ycrit = float(ndeg)*PI/180.
- coszc = cos(ycrit)
-
- CD = 0.25*DL*DP*coszc**2
-! CD = 0.25*DL*DP*cosp(2)**2
-
- do j=2,jm-1
- do i=1,im
- fx(i,j) = fx(i,j) * CD
- enddo
- enddo
-
- do j=2,jm
- do i=1,im
- fy(i,j) = fy(i,j) * CD
- enddo
- enddo
-
- call divg(im,jm,fx,fy,DG,cosp,cose,sine, dl, dp)
-
- return
- end
-
- subroutine divg(im, jm, fx, fy, dg, cosp, cose, sine, dl, dp)
- implicit none
-
- integer im
- integer jm
- real*8 fx(im,jm) ! e-w fluxes
- real*8 fy(im,jm) ! n-s fluxes
- real*8 DG(im,jm) ! del2 of h
- real*8 wk(im,jm)
- real*8 cosp(jm), cose(jm), sine(jm)
- real*8 rdx
- real*8 dl, dp, CDP, sum1, sum2
- integer i,j
-
- do j=2,jm-1
-
- rdx = 1./ (cosp(j)*DL)
-
- do i=1,im-1
- DG(i,j) = (fx(i+1,j) - fx(i,j)) * rdx
- enddo
- DG(im,j) = (fx(1,j) - fx(im,j)) * rdx
- enddo
-
- do j=2,jm
- do i=1,im
- wk(i,j) = fy(i,j) * cose(j)
- enddo
- enddo
-
- do j=2,jm-1
- CDP = 1./ (DP*cosp(j))
- do i=1,im
- DG(i,j) = DG(i,j) + (wk(i,j+1) - wk(i,j)) * CDP
- enddo
- enddo
-
-! Poles;
-
- sum1 = wk(im, 2)
- sum2 = wk(im,jm)
-
- do i=1,im-1
- sum1 = sum1 + wk(i, 2)
- sum2 = sum2 + wk(i,jm)
- enddo
-
- sum1 = sum1 / ( float(im)*(1.+sine(2)) )
- sum2 = -sum2 / ( float(im)*(1.+sine(2)) )
-
- do i=1,im
- DG(i, 1) = sum1
- DG(i,jm) = sum2
- enddo
-
- return
- end
-
- subroutine grad(h, im, jm, fx, fy, cosp, DL, DP)
- implicit none
- integer im
- integer jm
- real*8 h(im,jm)
- real*8 fx(im,jm) ! e-w fluxes
- real*8 fy(im,jm) ! n-s fluxes
- real*8 cosp(jm)
- real*8 RDP, DL, DP, rdx
- integer i, j
-
- RDP = 1./ DP
-
- do j=2,jm
- do i=1,im
- fy(i,j) = (h(i,j) - h(i,j-1)) * RDP
- enddo
- enddo
-
- do j=2,jm-1
-
- rdx = 1./ (cosp(j)*DL)
- fx(1,j) = (h(1,j) - h(im,j)) * rdx
- do i=2,im
- fx(i,j) = (h(i,j) - h(i-1,j)) * rdx
- enddo
- enddo
-
- return
- end
-
- subroutine avgp2(p, sine, im, jm)
- implicit none
- integer im, jm
- real*8 p(im,jm)
- real*8 sine(jm)
- real*8 sum1, sum2
- real*8 sum3, sum4
- real*8 rim
- integer i
- integer j
- integer jm1
-
- jm1 = jm-1
- rim = 1./ float(im)
-
- call sump2(p(1,1),p(1,jm),IM,sum1,sum2)
- sum1 = sum1*(1.+sine(2))
- sum2 = sum2*(1.+sine(2))
-
- call sump2(p(1,2),p(1,jm1),IM,sum3,sum4)
- sum1 = rim * ( sum1 + sum3*(sine(3)-sine(2)) ) / (1.+sine(3))
- sum2 = rim * ( sum2 + sum4*(sine(3)-sine(2)) ) / (1.+sine(3))
-
- do i=1,im
- P(i, 1) = sum1
- P(i, 2) = sum1
- P(i,jm1) = sum2
- P(i, jm) = sum2
- enddo
- return
- end
-
- subroutine sump2(p1,p2,im,s1,s2)
- implicit none
- integer im,i
- real*8 s1,s2
- real*8 p1(*),p2(*)
-
- s1 = p1(im)
- s2 = p2(im)
-
- do i=1,im-1
- s1 = s1 + p1(i)
- s2 = s2 + p2(i)
- enddo
- return
- end
-
- subroutine pmnx(a,nx,ny,fmin,fmax,mnk,mxk)
- implicit none
- integer nx
- integer ny
- integer mnk
- integer mxk
- real*8 a(nx,*)
- real*8 fmax, fmin, temp
- integer i,j
-
- fmax = a(1,1)
- fmin = a(1,1)
- mnk = 1
- mxk = 1
-
- do j=1,ny
- do i=1,nx
- temp = a(i,j)
- if(temp.gt.fmax) then
- fmax = temp
- mxk = j
- elseif(temp .lt. fmin) then
- fmin = temp
- mnk = j
- endif
- enddo
- enddo
-
- return
- end
-
diff --git a/tools/definesurf/varf2c.f90 b/tools/definesurf/varf2c.f90
deleted file mode 100644
index c7f638ff41..0000000000
--- a/tools/definesurf/varf2c.f90
+++ /dev/null
@@ -1,219 +0,0 @@
-subroutine varf2c(flon ,flat ,nflon ,nflat ,fine , &
- clon ,clat ,nclon ,nclat ,cmean , &
- cvar )
-
- use shr_kind_mod, only: r8 => shr_kind_r8
-
-!-----------------------------------------------------------------------------
-! Bin going from a fine grid to a coarse grid.
-! A schematic for the coarse and fine grid systems is shown in
-! Figure 1. This code assumes that each data point is represent
-! it's surrounding area, called a cell. The first grid data point
-! for both grids is assumed to be located at 0E (GM). This
-! implies that the 1st cell for both the fine and the coarse grids
-! strattles the Greenwich Meridian (GM). This code also assumes
-! that there is no data wraparound (last data value is located at
-! 360-dx).
-!
-! FIGURE 1: Overview of the coarse (X) and fine (@) grids
-! longitudinal structure where:
-! X = location of each coarse grid data point
-! @ = location of each fine grid data point
-!
-! Greenwich Greenwich
-! 0 Coarse cells 360
-! : v :
-! clon(1): clon(2) v clon(3) clon(nclon):
-! v : v v v v :
-! xxxxxxxxxxxxxxxxxxxxxxxxxxxx..xxxxxxxxxxxxxxxx :
-! x x x x x :
-! x x x x x :
-! x c(1) x c(2) x x c(nclon)x :
-! x X x X x x X x :
-! x ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ :
-! x | | | | | | | | | | | | | :
-! x | @ | @ | @ | @ | @ | @ |..| @ | @ | @ | @ | @ | :
-! xxx|___|___|___|___|___|___| |___|___|___|___|___| :
-! v v v v v :
-! flon(1) flon(3) v flon(nflon-1) flon(nflon)
-! : v :
-! : Fine cells :
-! 0 360
-!
-! The Longitude/Latitude search:
-! ------------------------------
-!
-! Given a coarse grid cell with west and east boundaries of cWest
-! and cEast and south and north boundaries of cSouth and cNorth
-! (outlined by "x" in figure 2), find the indices of the fine grid
-! points which are contained within the coarse grid cell. imin and
-! imax are the indices fine grid points which overlap the western
-! and eastern boundary of the coarse cell. jmin and jmax are the
-! corresponding indices in the S-N direction. Bin these overlapping
-! values to generate coarse(n), the coarse grid data values.
-!
-! FIGURE 2: Detail of Coarse and Fine cell overlap.
-! @ = fine grid data point
-! X = coarse grid data point
-!
-! cWest cEast
-! | | x | | x |
-! -@-------@---x---@-------@-----x-@-
-! | | x*xxxxxxxxxxxxxxxxx*x|xx cNorth
-! | | x | | x |
-! | | x | | x |
-! @-------@---x---@-------@-----x-@- jmax
-! | | x | c(n) | x |
-! | @ | x | | x |
-! | | x | | x |
-! @-------@---x---@-------@-----x-@- jmin
-! | | x | | x |
-! | @ | x*xxxxxxx@xxxxxxxxx*x|xx cSouth
-! | | x | | x |
-! -@-------@---x---@-------@-----x-@-
-! | imin imax |
-!
-!
-! When a cell coarse cell strattles the Greenwich Meridian
-! ---------------------------------------------------------
-!
-! The first coarse grid cell strattles the GM, so when the western
-! boundary of the coarse cell is < 0, an additional search is carried out.
-! It ASSUMES that the easternmost fine grid point overlaps and searches
-! westward from nflon, looking for a grid point west of clon(1)
-! This generates a second set of longitudinal indices, imin1 and imax1.
-! See Figure 3.
-!
-! Figure 3: Detail of Coarse cell strattling GM:
-! -----------------------------------------------
-!
-! Greenwich Greenwich
-! 0 360
-! cWest : cEast cWest :
-! clon(1): clon(2) clon(nclon+1)=clon(1)
-! v : v v :
-! xxxxxxxxxxxxxxxxxxxxxxx ... xxxxxxxxxxxxxxxx :
-! x x x x x :
-! x x x x x :
-! x c(1) x x x c(nclon)x :
-! x X x x x X x :
-! x ___ ___ ___ _ ___ ___ ___ :
-! x | | | | | | | :
-! x | @ | @ | @ | @ | @ | @ | :
-! xxx|___|___|___|_ ___|___|___| :
-! ^ : ^ ^ ^ ^ :
-! flon(1): ^ flon(3) flon(nflon-1) ^ :
-! ^ : ^ ^ ^ :
-! ^ :flon(2) ^ flon(nflon)
-! ^ : ^ ^ ^ :
-! imin : imax imin1 imax1 :
-! : :
-!
-!
-! In this case, imin=1, imax=2, imin1=nflon-1 and imax1=nflon.
-! because the last two cells of the fine grid will have some
-! contribution the the 1st cell of the coarse grid.
-!
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------Arguments---------------------------------
-
- integer nflon ! Input: number of fine longitude points
- integer nflat ! Input: number of fine latitude points
- integer nclon ! Input: number of coarse longitude points
- integer nclat ! Input: number of coarse latitude points
-
- real(r8) flon(nflon) ! Input: fine grid lons, centers (deg)
- real(r8) flat(nflat) ! Input: fine grid lats, centers (deg)
- real(r8) fine(nflon,nflat) ! Input: Fine grid data array
- real(r8) clon(nclon+1,nclat) ! Input: coarse grid cell lons, west edge (deg)
- real(r8) clat(nclat+1) ! Input: coarse grid cell lat, south edge (deg)
- real(r8) cmean(nclon,nclat) ! Input: mean of fine points over coarse grid cell
- real(r8) cvar (nclon,nclat) ! Output:variance of fine points over coarse cell
-
-!--------------------------Local variables------------------------------
-
- real(r8) cWest ! Coarse cell longitude, west edge (deg)
- real(r8) cEast ! Coarse cell longitude, east edge (deg)
- real(r8) cSouth ! Coarse cell latitude, south edge (deg)
- real(r8) cNorth ! Coarse cell latitude, notrh edge (deg)
- real(r8) sum ! coarse tmp value
-
- integer i,j ! Indices
- integer imin ,imax ! Max/Min E-W indices of intersecting fine cell.
- integer imin1,imax1 ! fine E-W indices when coarse cell strattles GM
- integer jmin ,jmax ! Max/Min N-S indices of intersecting fine cell.
- integer iclon,jclat ! coarse grid indices
- integer num ! increment
-
-!-----------------------------------------------------------------------------
-
- do jclat= 1,nclat ! loop over coarse latitudes
- cSouth = clat(jclat)
- cNorth = clat(jclat+1)
-
- do iclon=1,nclon ! loop over coarse longitudes
- cWest = clon(iclon,jclat)
- cEAST = clon(iclon+1,jclat)
-
-! 1. Normal longitude search: Find imin and imax
-
- imin = 0
- imax = 0
- do i=1,nflon-1 ! loop over fine lons, W -> E
- if (flon(i) .gt. cEast) goto 10 ! fine grid point is E of coarse box
- if (flon(i) .ge. cWest .and. imin.eq.0) imin=i
- imax=i
- enddo
-
-! 2. If cWest < 0, then coarse cell strattles GM. Hunt westward
-! from the end to find indices of any overlapping fine grid cells:
-! imin1 and imax1.
-
-10 imin1 = 0 ! borders for cWest, cEast
- imax1 = -1 ! borders for cWest, cEast
- if (cWest .lt. 0) then
- cWest = cWest + 360.
- imax1 = nflon
- do i=nflon,1,-1 ! loop over fine lons, E -> W
- imin1=i
- if (flon(i) .le. cWest) goto 20 ! fine grid point is W of coarse box
- enddo
- endif
-
-! 3. Do the latitude search S -> N for jmin and jmax
-
-20 jmin = 0
- jmax = 0
- do j=1,nflat ! loop over fine lats, S -> N
- if (flat(j) .gt. cNorth) goto 30 ! fine grid point is N of coarse box
- if (flat(j) .ge. cSouth .and. jmin.eq.0) jmin=j
- jmax=j
- enddo
-30 continue
-
-! 4. Sdv
-
- sum = 0. ! Initialize coarse data value
- num = 0
-
- do j=jmin,jmax ! loop over fine lats, S -> N
- do i=imin,imax ! loop over fine lons, W -> E
- sum = sum + (fine(i,j) - cmean(iclon,jclat))**2
- num = num + 1
- enddo
- do i=imin1,imax1 ! If coarse cell strattles GM
- sum = sum + (fine(i,j) - cmean(iclon,jclat))**2
- num = num + 1
- enddo
- enddo
-
- if (num .gt. 0) then
- cvar(iclon,jclat) = sum/num
- else
- cvar(iclon,jclat) = 1.e30
- endif
- end do
- end do
- return
-end subroutine varf2c
diff --git a/tools/definesurf/wrap_nf.f90 b/tools/definesurf/wrap_nf.f90
deleted file mode 100644
index c340b3817b..0000000000
--- a/tools/definesurf/wrap_nf.f90
+++ /dev/null
@@ -1,146 +0,0 @@
-subroutine wrap_inq_varid (nfid, varname, varid)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid
- character*(*) varname
-
- integer ret
-
- ret = nf_inq_varid (nfid, varname, varid)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_inq_varid
-
-subroutine wrap_inq_dimlen (nfid, dimid, dimlen)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, dimid, dimlen
-
- integer ret
-
- ret = nf_inq_dimlen (nfid, dimid, dimlen)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_inq_dimlen
-
-subroutine wrap_inq_dimid (nfid, dimname, dimid)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, dimid
- character*(*) dimname
-
- integer ret
-
- ret = nf_inq_dimid (nfid, dimname, dimid)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_inq_dimid
-
-subroutine wrap_inq_var (nfid, varid, varname, xtype, ndims, dimids, natts)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid, xtype, ndims, dimids(nf_max_dims), natts
- character*(*) varname
-
- integer ret
-
- ret = nf_inq_var (nfid, varid, varname, xtype, ndims, dimids, natts)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_inq_var
-
-subroutine wrap_def_dim (nfid, dimname, len, dimid)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, len, dimid
- character*(*) dimname
-
- integer ret
-
- ret = nf_def_dim (nfid, dimname, len, dimid)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_def_dim
-
-subroutine wrap_get_var8 (nfid, varid, arr)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid
- real*8 arr(*)
-
- integer ret
-
- ret = nf_get_var_double (nfid, varid, arr)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_get_var8
-
-subroutine wrap_put_var8 (nfid, varid, arr)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid
- real*8 arr(*)
-
- integer ret
- ret = nf_put_var_double (nfid, varid, arr)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_put_var8
-
-subroutine wrap_get_vara8 (nfid, varid, start, count, arr)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid, start(*), count(*)
- real*8 arr(*)
-
- integer ret
-
- ret = nf_get_vara_double (nfid, varid, start, count, arr)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_get_vara8
-
-subroutine wrap_put_vara8 (nfid, varid, start, count, arr)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid
- integer start(*), count(*)
- real*8 arr(*)
-
- integer ret
- ret = nf_put_vara_double (nfid, varid, start, count, arr)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_put_vara8
-
-subroutine wrap_put_att_text (nfid, varid, attname, atttext)
- implicit none
- include 'netcdf.inc'
-
- integer, intent(in):: nfid
- integer, intent(in):: varid
- character*(*), intent(in):: attname
- character*(*), intent(in):: atttext
-
- integer ret ! NetCDF return code
- integer siz
-
- siz = len_trim(atttext)
- ret = nf_put_att_text (nfid, varid, attname, siz, atttext)
- if (ret/=NF_NOERR) call handle_error (ret)
-end subroutine wrap_put_att_text
-
-subroutine wrap_put_att_double (nfid, varid, name, xtype, len, dvals)
- implicit none
- include 'netcdf.inc'
-
- integer nfid, varid, xtype, len
- character*(*) name
- real*8 dvals
-
- integer ret
-
- ret = nf_put_att_double (nfid, varid, name, xtype, len, dvals)
- if (ret.ne.NF_NOERR) call handle_error (ret)
-end subroutine wrap_put_att_double
-
diff --git a/tools/topo_tool/bin_to_cube/Makefile b/tools/topo_tool/bin_to_cube/Makefile
deleted file mode 100644
index 84d1b39138..0000000000
--- a/tools/topo_tool/bin_to_cube/Makefile
+++ /dev/null
@@ -1,82 +0,0 @@
-EXEDIR = .
-EXENAME = bin_to_cube
-RM = rm
-
-.SUFFIXES:
-.SUFFIXES: .F90 .o
-
-
-#
-# setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib
-#
-
-FC = lf95
-#DEBUG=TRUE
-
-# Check for the NetCDF library and include directories
-ifeq ($(LIB_NETCDF),$(null))
-LIB_NETCDF := /usr/local/lib
-endif
-
-ifeq ($(INC_NETCDF),$(null))
-INC_NETCDF := /usr/local/include
-endif
-
-# Determine platform
-UNAMES := $(shell uname -s)
-UNAMEM := $(findstring CRAY,$(shell uname -m))
-
-
-#------------------------------------------------------------------------
-# LF95
-#------------------------------------------------------------------------
-
-ifeq ($(FC),lf95)
-#
-# Tramhill
-#
- INC_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/include
- LIB_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib
-
- LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -lcurl -lhdf5 -lhdf5_hl -mcmodel=medium
- FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF)
- ifeq ($(DEBUG),TRUE)
- #TBH: this works FFLAGS += -g --chk --pca
- #TBH: this FAILS FFLAGS += -g --chk a,e,s,u,x --pca
- FFLAGS += -g --chk a,e,s,u --pca
- else
- FFLAGS += -O
- endif
-
-endif
-
-
-#------------------------------------------------------------------------
-# AIX
-#------------------------------------------------------------------------
-
-ifeq ($(UNAMES),AIX)
-FC = xlf90
-FFLAGS = -c -I$(INC_NETCDF)
-LDFLAGS = -L$(LIB_NETCDF) -lnetcdf
-.F90.o:
- $(FC) $(FFLAGS) -qsuffix=f=F90 $<
-endif
-
-
-.F90.o:
- $(FC) $(FFLAGS) $<
-
-#------------------------------------------------------------------------
-# Default rules and macros
-#------------------------------------------------------------------------
-
-OBJS := bin_to_cube.o shr_kind_mod.o
-
-$(EXEDIR)/$(EXENAME): $(OBJS)
- $(FC) -o $@ $(OBJS) $(LDFLAGS)
-
-clean:
- $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME)
-
-bin_to_cube.o: shr_kind_mod.o
diff --git a/tools/topo_tool/bin_to_cube/README b/tools/topo_tool/bin_to_cube/README
deleted file mode 100644
index aa65664798..0000000000
--- a/tools/topo_tool/bin_to_cube/README
+++ /dev/null
@@ -1,23 +0,0 @@
-This program reads USGS 30-sec terrain dataset from NetCDF file and bins it to an approximately
-3km cubed-sphere grid and outputs the data in netCDF format.
-
-The LANDM_COSLAT field is read in from a separate netCDF file and linearly interpolated to the 3km cubed-sphere grid.
-
-Input files needed:
-
-1. USGS raw data in netCDF format: usgs-rawdata.nc (must be placed in same dirctory as the executables)
- Generated with software in gen_netCDF_from_USGS/ directory
-
- File may be found at:
-
- $CESMDATA/inputdata/atm/cam/gtopo30data/usgs-rawdata.nc
-
-2. landm_coslat dataset (must be placed in same dirctory as the executables). E.g.:
-
- ln -s /fs/cgd/csm/inputdata/atm/cam2/hrtopo/landm_coslat.nc .
-
- The landm_coslat field is not used in CAM5!
-
-Output file:
-
-USGS-topo-cube.nc
diff --git a/tools/topo_tool/bin_to_cube/bin_to_cube.F90 b/tools/topo_tool/bin_to_cube/bin_to_cube.F90
deleted file mode 100644
index 89ea086a37..0000000000
--- a/tools/topo_tool/bin_to_cube/bin_to_cube.F90
+++ /dev/null
@@ -1,931 +0,0 @@
-!
-! DATE CODED: Nov 7, 2011
-!
-! DESCRIPTION: This program reads USGS 30-sec terrain dataset from NetCDF file and
-! bins it to an approximately 3km cubed-sphere grid and outputs the
-! data in netCDF format.
-!
-! The LANDM_COSLAT field is read in from a separate netCDF file and linearly
-! interpolated to the 3km cubed-sphere grid.
-!
-! Author: Peter Hjort Lauritzen (pel@ucar.edu)
-!
-! ROUTINES CALLED:
-! netcdf routines
-!
-! COMPILING:
-!
-program convterr
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-# include
- !
- integer :: im, jm
-
- integer, parameter :: ncube = 3000 !dimension of cubed-sphere grid
-! integer, parameter :: ncube = 540 !dimension of cubed-sphere grid
- ! integer, parameter :: ncube = 361 ! for debugging
-
- integer*2, allocatable, dimension(:,:) :: terr ! global 30-sec terrain data
- integer*1, allocatable, dimension(:,:) :: landfrac ! global 30-sec land fraction
-
- integer :: alloc_error,dealloc_error
- integer :: i,j,n,k,index ! index
- integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile
- integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file
- integer :: srcid,dstid ! for netCDF weight file
-
- real(r8), allocatable, dimension(:) :: lon , lat
- real(r8), allocatable, dimension(:) :: lon_landm , lat_landm
- real(r8), allocatable, dimension(:,:) :: landm_coslat
- integer :: im_landm, jm_landm
- integer :: lonid, latid
- integer :: lon_vid, lat_vid
-
- REAL (r8), PARAMETER :: tiny = 1.0E-10
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: rad2deg = 180.0/pi
- REAL (r8), PARAMETER :: deg2rad = pi/180.0
-
- real(r8) :: alpha, beta,da,wt,dlat
- integer :: ipanel,icube,jcube
- real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube
- real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube
- integer , allocatable, dimension(:,:) :: idx,idy,idp
- !
- real(r8) :: dx,dy
- !
- ! for "bi-linear" interpolation
- !
- real(r8) :: lambda,theta,wx,wy
- integer :: ilon,ilat,ip1,jp1
- !
- ! variable for regridding
- !
- integer :: src_grid_dim ! for netCDF weight file
- !
- ! this is only used if target grid is a lat-lon grid
- !
- integer , parameter :: im_target = 360 , jm_target = 180
- logical , parameter :: ltarget_rll = .TRUE.
- !
- ! this is only used if target grid is not a lat-lon grid
- !
- real(r8), allocatable, dimension(:) :: lon_target, lat_target
- !
- ! compute volume of surface topography
- !
- real(r8) :: vol,dx_rad,vol_cube,area_latlon,darea_latlon ! latitude array
- real(r8), allocatable, dimension(:,:) :: darea_cube
-
- !
- ! read in USGS data from netCDF file
- !
- ! status = nf_open('topo-lowres.nc', 0, ncid) !for debugging
- status = nf_open('usgs-rawdata.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
-
- status = NF_INQ_DIMID(ncid, 'lat', dimlatid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimlatid, jm)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_INQ_DIMID(ncid, 'lon', dimlonid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimlonid, im)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "lon-lat dimensions: ",im,jm
-
- allocate ( landfrac(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- allocate ( terr(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr'
- stop
- end if
-
- allocate ( lon(im),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- allocate ( lat(jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- terr = -999999
- landfrac = -99.0
-
- status = NF_INQ_VARID(ncid, 'landfract', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_INT1(ncid, landid,landfrac)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of 30sec land fraction",MINVAL(landfrac),MAXVAL(landfrac)
-
-
- status = NF_INQ_VARID(ncid, 'htopo', topoid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "read terrain data"
- status = NF_GET_VAR_INT2(ncid, topoid,terr)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_INQ_VARID(ncid, 'lon', lonid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "read lon"
- status = NF_GET_VAR_DOUBLE(ncid, lonid,lon)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_INQ_VARID(ncid, 'lat', latid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "read lat"
- status = NF_GET_VAR_DOUBLE(ncid, latid,lat)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- print *,"close file topo.nc"
- status = nf_close (ncid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- WRITE(*,*) 'done reading in USGS data from netCDF file'
-
- WRITE(*,*) "Adjustments to land fraction: Extend land fraction for Ross Ice shelf by"
- WRITE(*,*) "setting all landfractions south of 79S to 1"
- DO j=1,jm
- IF (lat(j)<-79.0) THEN
- DO i=1,im
- landfrac(i,j) = 1
- END DO
- END IF
- END DO
-
- WRITE(*,*) "compute volume for USGS raw data"
- vol = 0.0
- dx = (lon(2)-lon(1))
- dx_rad = dx*deg2rad
- do j=1,jm
- do i=1,im
- darea_latlon = dx_rad*(SIN(deg2rad*(-90.0+dx*j))-SIN(deg2rad*(-90.0+dx*(j-1))))
- vol = vol+DBLE(terr(i,j))*darea_latlon
- area_latlon = area_latlon + darea_latlon
- end do
- end do
- vol = vol/area_latlon
- WRITE(*,*) "consistency of lat-lon area",area_latlon-4.0*pi
- WRITE(*,*) "volume of topography about sea-level (raw usgs data)",vol
-
-
- !
- !****************************************************
- !
- ! read LANDM_COSLAT
- !
- !****************************************************
- !
- WRITE(*,*) "read LANDM_COSLAT from file"
- status = nf_open('landm_coslat.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
-
- status = NF_INQ_DIMID(ncid, 'lat', dimlatid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimlatid, jm_landm)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_INQ_DIMID(ncid, 'lon', dimlonid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimlonid, im_landm)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "lon-lat dimensions: ",im_landm,jm_landm
-
- allocate ( landm_coslat(im_landm,jm_landm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- allocate ( lon_landm(im_landm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- allocate ( lat_landm(jm_landm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- do j = 1, jm_landm
- do i = 1, im_landm
- landm_coslat(i,j) = -999999.99
- end do
- end do
-
- status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat)
-
- status = NF_INQ_VARID(ncid, 'lon', lonid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "read lon"
- status = NF_GET_VAR_DOUBLE(ncid, lonid,lon_landm)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_INQ_VARID(ncid, 'lat', latid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- WRITE(*,*) "read lat"
- status = NF_GET_VAR_DOUBLE(ncid, latid,lat_landm)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- print *,"close file"
- status = nf_close (ncid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file'
-
- !
- ! bin data on cubed-sphere grid
- !
- da = pi / DBLE(2*ncube)!equal-angle cubed-sphere grid spacing
- lon = deg2rad*lon
- lat = deg2rad*lat
- dlat = pi/DBLE(jm)
- allocate ( weight(ncube,ncube,6),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for weight'
- stop
- end if
- weight = 0.0
- allocate ( terr_cube(ncube,ncube,6),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr_cube'
- stop
- end if
- terr_cube = 0.0
- allocate ( landfrac_cube(ncube,ncube,6),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr_cube'
- stop
- end if
- landfrac_cube = 0.0
- allocate ( landm_coslat_cube(ncube,ncube,6),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr_cube'
- stop
- end if
- landm_coslat_cube = 0.0
-
-
- allocate ( idx(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for idx'
- stop
- end if
- allocate ( idy(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for idy'
- stop
- end if
- allocate ( idp(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for idp'
- stop
- end if
-
- WRITE(*,*) "bin lat-lon data on cubed-sphere"
-
- !
- ! for debugging ONLY
- !
-! DO j=1,jm
-! DO i=1,im
-!! terr(i,j) = 10000.0*(2.0+cos(lat(j))*cos(lat(j))*cos(2.0*lon(i)))!Y22
-!! terr(i,j) = 10000.0*(2.0+(sin(2.0*lat(j))**16)*cos(16.0*lon(i))) !Y16_32
-! terr(i,j) = 10000.0*(2.0+cos(16.0*lon(i))) !Y16_32
-! END DO
-! END DO
-
- DO j=1,jm
- DO i=1,im
-! WRITE(*,*) "bin to cube ",100.0*FLOAT(i+(j-1)*im)/FLOAT(im*jm),"% done"
- call CubedSphereABPFromRLL(lon(i), lat(j), alpha, beta, ipanel)
- icube = CEILING((alpha + piq) / da)
- jcube = CEILING((beta + piq) / da)
- IF (icube<1.OR.icube>ncube.OR.jcube<1.OR.jcube>ncube) THEN
- WRITE(*,*) "fatal error in search algorithm"
- WRITE(*,*) "icube or jcube out of range: ",icube,jcube
- STOP
- END IF
- wt = SIN( lat(j)+0.5*dlat ) - SIN( lat(j)-0.5*dlat )
- weight(icube,jcube,ipanel) = weight(icube,jcube,ipanel)+wt
- !
- terr_cube (icube,jcube,ipanel) = terr_cube (icube,jcube,ipanel)+wt*DBLE(terr(i,j))
- landfrac_cube(icube,jcube,ipanel) = landfrac_cube(icube,jcube,ipanel)+wt*DBLE(landfrac(i,j))
- !
- ! save "index-association" for variance computation
- !
- idx(i,j) = icube
- idy(i,j) = jcube
- idp(i,j) = ipanel
- END DO
- END DO
-
- dx = deg2rad*(lon_landm(2)-lon_landm(1))
- !
- ! lat_landm is not exactly equally spaced so a search is needed in the loop below
- !
- dy = deg2rad*(lat_landm(2)-lat_landm(1))
- DO k=1,6
- DO j=1,ncube
- DO i=1,ncube
- IF (ABS(weight(i,j,k))<1.0E-9) THEN
- WRITE(*,*) "there is no lat-lon grid point in cubed sphere cell ",i,j,k
- WRITE(*,*) "fatal error"
- STOP
- ELSE
- terr_cube (i,j,k) = terr_cube (i,j,k)/weight(i,j,k)
- landfrac_cube (i,j,k) = landfrac_cube (i,j,k)/weight(i,j,k)
- END IF
- !
- ! linearly interpolate landm_coslat
- !
- alpha = -piq+(i-0.5)*da
- beta = -piq+(j-0.5)*da
- CALL CubedSphereRLLFromABP(alpha, beta, k, lambda, theta)
- IF (theta>lat_landm(jm_landm)*deg2rad-tiny) THEN
- landm_coslat_cube(i,j,k) = 0.0
- ELSE IF (theta1.0.OR.wy<0.0)
- jp1 = ilat+1
- wy = (theta -lat_landm(ilat)*deg2rad)/((lat_landm(jp1)-lat_landm(ilat))*deg2rad)
- IF (wy>1.0) THEN
- ilat=ilat+1
- ELSE IF (wy<0.0) THEN
- ilat=ilat-1
- END IF
- END DO
-
- IF (wx>1.0+tiny.OR.wx<0.0-tiny) THEN
- WRITE(*,*) "wx out of range",wx
- stop
- END IF
- IF (wy>1.0+tiny.OR.wy<0.0-tiny) THEN
- WRITE(*,*) "wy out of range",wy
- stop
- END IF
- !
- ! "crude" bi-linear interpolation
- !
- landm_coslat_cube(i,j,k) =&
- (1.0-wx)*(1.0-wy)*landm_coslat(ilon,ilat)+ wx *(1-wy)*landm_coslat(ip1,ilat)+&
- (1.0-wx)* wy *landm_coslat(ilon,jp1 )+ wx * wy *landm_coslat(ip1,jp1)
- END IF
- END DO
- END DO
- END DO
- WRITE(*,*) "min/max value of terr_cube:", MINVAL(terr_cube), MAXVAL(terr_cube)
- WRITE(*,*) "min/max value of landm_coslat_cube:", MINVAL(landm_coslat_cube), MAXVAL(landm_coslat_cube)
- !
- ! compute volume of topography on cubed-sphere
- !
- WRITE(*,*) "compute volume for cubed-sphere binned data"
- allocate (darea_cube(ncube,ncube),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for idp'
- stop
- end if
- CALL EquiangularAllAreas(ncube, darea_cube)
- vol_cube = 0.0
- do ipanel=1,6
- do j=1,ncube
- do i=1,ncube
- vol_cube = vol_cube+terr_cube(i,j,ipanel)*darea_cube(i,j)
- end do
- end do
- end do
- vol_cube=vol_cube/(4.0*pi)
- deallocate(darea_cube)
- WRITE(*,*) "mean height (globally) of topography about sea-level (3km cube data)",vol_cube,(vol_cube-vol)/vol
- !*********************************************************
- !
- ! compute variance
- !
- !*********************************************************
- !
- allocate ( sgh30_cube(ncube,ncube,6),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for sgh30_cube'
- stop
- end if
- sgh30_cube = 0.0
- DO j=1,jm
- DO i=1,im
- icube = idx(i,j)
- jcube = idy(i,j)
- ipanel = idp(i,j)
- wt = SIN( lat(j)+0.5*dlat ) - SIN( lat(j)-0.5*dlat )
- sgh30_cube(icube,jcube,ipanel) = sgh30_cube(icube,jcube,ipanel) + &
- (wt*(terr_cube(icube,jcube,ipanel)-terr(i,j))**2)/weight(icube,jcube,ipanel)
- END DO
- END DO
- ! sgh30_cube=sgh30_cube/weight
- WRITE(*,*) "min/max value of sgh30_cube:", MINVAL(sgh30_cube), MAXVAL(sgh30_cube)
- !
- ! write data to NetCDF file
- !
- CALL wrt_cube(ncube,terr_cube,landfrac_cube,landm_coslat_cube,sgh30_cube)
- DEALLOCATE(weight,terr,landfrac,idx,idy,idp,lat,lon)
- WRITE(*,*) "done writing cubed sphere data"
-end program convterr
-
-
-!************************************************************************
-!!handle_err
-!************************************************************************
-!
-!!ROUTINE: handle_err
-!!DESCRIPTION: error handler
-!--------------------------------------------------------------------------
-
-subroutine handle_err(status)
-
- implicit none
-
-# include
-
- integer status
-
- if (status .ne. nf_noerr) then
- print *, nf_strerror(status)
- stop 'Stopped'
- endif
-
-end subroutine handle_err
-
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereABPFromRLL
-!
-! Description:
-! Determine the (alpha,beta,panel) coordinate of a point on the sphere from
-! a given regular lat lon coordinate.
-!
-! Parameters:
-! lon - Coordinate longitude
-! lat - Coordinate latitude
-! alpha (OUT) - Alpha coordinate
-! beta (OUT) - Beta coordinate
-! ipanel (OUT) - Face panel
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- REAL (R8), INTENT(IN) :: lon, lat
- REAL (R8), INTENT(OUT) :: alpha, beta
- INTEGER, INTENT(OUT) :: ipanel
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: rotate_cube = 0.0
-
- ! Local variables
- REAL (R8) :: xx, yy, zz, pm
- REAL (R8) :: sx, sy, sz
- INTEGER :: ix, iy, iz
-
- ! Translate to (x,y,z) space
- xx = COS(lon-rotate_cube) * COS(lat)
- yy = SIN(lon-rotate_cube) * COS(lat)
- zz = SIN(lat)
-
- pm = MAX(ABS(xx), ABS(yy), ABS(zz))
-
- ! Check maximality of the x coordinate
- IF (pm == ABS(xx)) THEN
- IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF
- ELSE
- ix = 0
- ENDIF
-
- ! Check maximality of the y coordinate
- IF (pm == ABS(yy)) THEN
- IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF
- ELSE
- iy = 0
- ENDIF
-
- ! Check maximality of the z coordinate
- IF (pm == ABS(zz)) THEN
- IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF
- ELSE
- iz = 0
- ENDIF
-
- ! Panel assignments
- IF (iz == 1) THEN
- ipanel = 6; sx = yy; sy = -xx; sz = zz
-
- ELSEIF (iz == -1) THEN
- ipanel = 5; sx = yy; sy = xx; sz = -zz
-
- ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN
- ipanel = 1; sx = yy; sy = zz; sz = xx
-
- ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN
- ipanel = 3; sx = -yy; sy = zz; sz = -xx
-
- ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN
- ipanel = 2; sx = -xx; sy = zz; sz = yy
-
- ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN
- ipanel = 4; sx = xx; sy = zz; sz = -yy
-
- ELSE
- WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed'
- WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')'
- WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')'
- STOP
- ENDIF
-
- ! Use panel information to calculate (alpha, beta) coords
- alpha = ATAN(sx / sz)
- beta = ATAN(sy / sz)
-
-END SUBROUTINE CubedSphereABPFromRLL
-
-
-
-!
-! write netCDF file
-!
-subroutine wrt_cube(ncube,terr_cube,landfrac_cube,landm_coslat_cube,sgh30_cube)
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-# include
-
- !
- ! Dummy arguments
- !
- integer, intent(in) :: ncube
- real (r8), dimension(6*ncube*ncube), intent(in) :: terr_cube,landfrac_cube,sgh30_cube,landm_coslat_cube
- !
- ! Local variables
- !
- !-----------------------------------------------------------------------
- !
- ! grid coordinates and masks
- !
- !-----------------------------------------------------------------------
-
- real (r8), dimension(6*ncube*ncube) :: grid_center_lat ! lat/lon coordinates for
- real (r8), dimension(6*ncube*ncube) :: grid_center_lon ! each grid center in degrees
-
- integer :: ncstat ! general netCDF status variable
- integer :: nc_grid_id ! netCDF grid dataset id
- integer :: nc_gridsize_id ! netCDF grid size dim id
- integer :: nc_gridrank_id ! netCDF grid rank dim id
- integer :: nc_griddims_id ! netCDF grid dimension size id
- integer :: nc_grdcntrlat_id ! netCDF grid center lat id
- integer :: nc_grdcntrlon_id ! netCDF grid center lon id
- integer :: nc_terr_id
- integer :: nc_landfrac_id
- integer :: nc_landm_coslat_id
- integer :: nc_var_id
-
-
- integer, dimension(2) :: nc_dims2_id ! netCDF dim id array for 2-d arrays
- integer :: grid_dims
-
- character(18), parameter :: grid_file_out = 'USGS-topo-cube.nc'
- character(90), parameter :: grid_name = 'equi-angular gnomonic cubed sphere grid'
-
- character (len=32) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j,k
- character (len=8) :: datestring
-
- integer :: atm_add,n
- real(r8) :: xgno_ce,lon,ygno_ce,lat
-
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: rad2deg = 180.0/pi
-
- real(r8) :: da, a1,a2,a3,a4,dbg_area,max_size
- real(r8), dimension(2,2) :: ang
- real(r8) :: tmp_lon,min_lon,max_lon!,sum,lflag_value
- logical :: lflag
-
- grid_dims = 6*ncube*ncube
-
- dbg_area = 0.0
-
- da = pi / DBLE(2*ncube)
- atm_add = 1
- do k=1,6
- do j=1,ncube
- ygno_ce = -piq + da * (DBLE(j-1)+0.5) !center of cell
- do i=1,ncube
- xgno_ce = -piq + da * (DBLE(i-1)+0.5)
- call CubedSphereRLLFromABP(xgno_ce, ygno_ce, k, lon, lat)
- grid_center_lon(atm_add ) = lon*rad2deg
- grid_center_lat(atm_add ) = lat*rad2deg
- atm_add = atm_add+1
- end do
- end do
- end do
-
- WRITE(*,*) "Create NetCDF file for output"
- ncstat = nf_create (grid_file_out, NF_64BIT_OFFSET,nc_grid_id)
- call handle_err(ncstat)
-
- ncstat = nf_put_att_text (nc_grid_id, NF_GLOBAL, 'title',len_trim(grid_name), grid_name)
- call handle_err(ncstat)
-
- WRITE(*,*) "define grid size dimension"
- ncstat = nf_def_dim (nc_grid_id, 'grid_size', 6*ncube*ncube, nc_gridsize_id)
- call handle_err(ncstat)
-
- WRITE(*,*) "define grid rank dimension"
- ncstat = nf_def_dim (nc_grid_id, 'grid_rank', 1, nc_gridrank_id)
- call handle_err(ncstat)
-
- WRITE(*,*) "define grid dimension size array"
- ncstat = nf_def_var (nc_grid_id, 'grid_dims', NF_INT,1, nc_gridrank_id, nc_griddims_id)
- call handle_err(ncstat)
-
- WRITE(*,*) "define grid center latitude array"
- ncstat = nf_def_var (nc_grid_id, 'lat', NF_DOUBLE,1, nc_gridsize_id, nc_grdcntrlat_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlat_id, 'units',13, 'degrees_north')
- call handle_err(ncstat)
-
- WRITE(*,*) "define grid center longitude array"
- ncstat = nf_def_var (nc_grid_id, 'lon', NF_DOUBLE,1, nc_gridsize_id, nc_grdcntrlon_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_grdcntrlon_id, 'units',12, 'degrees_east')
- call handle_err(ncstat)
-
- WRITE(*,*) "define terr_cube array"
- ncstat = nf_def_var (nc_grid_id, 'terr', NF_DOUBLE,1, nc_gridsize_id, nc_terr_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_terr_id, 'units',1, 'm')
- call handle_err(ncstat)
-
- WRITE(*,*) "define landfrac_cube array"
- ncstat = nf_def_var (nc_grid_id, 'LANDFRAC', NF_DOUBLE,1, nc_gridsize_id, nc_landfrac_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_landfrac_id, 'long_name',70,&
- 'land ocean transition mask: ocean (0), continent (1), transition (0-1)')
- call handle_err(ncstat)
-
- WRITE(*,*) "define landm_coslat_cube array"
- ncstat = nf_def_var (nc_grid_id, 'LANDM_COSLAT', NF_DOUBLE,1, nc_gridsize_id, nc_landm_coslat_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_landm_coslat_id, 'long_name',35,'smoothed land ocean transition mask')
- call handle_err(ncstat)
-
- WRITE(*,*) "define sgh30_cube array"
- ncstat = nf_def_var (nc_grid_id, 'SGH30', NF_DOUBLE,1, nc_gridsize_id, nc_var_id)
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_var_id, 'units',12, 'm')
- call handle_err(ncstat)
- ncstat = nf_put_att_text (nc_grid_id, nc_var_id, 'long_name',58,&
- 'variance of elevation from 30s lat-lon to 3km cubed-sphere')
-
- WRITE(*,*) "end definition stage"
- ncstat = nf_enddef(nc_grid_id)
- call handle_err(ncstat)
-
- !-----------------------------------------------------------------------
- !
- ! write grid data
- !
- !-----------------------------------------------------------------------
-
-
- WRITE(*,*) "write grid data"
- ncstat = nf_put_var_int(nc_grid_id, nc_griddims_id, grid_dims)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlat_id, grid_center_lat)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_grdcntrlon_id, grid_center_lon)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_terr_id, terr_cube)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_landfrac_id, landfrac_cube)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_landm_coslat_id, landm_coslat_cube)
- call handle_err(ncstat)
-
- ncstat = nf_put_var_double(nc_grid_id, nc_var_id, sgh30_cube)
- call handle_err(ncstat)
-
- WRITE(*,*) "Close output file"
- ncstat = nf_close(nc_grid_id)
- call handle_err(ncstat)
-end subroutine wrt_cube
-
-
-!------------------------------------------------------------------------------
-! SUBROUTINE EquiangularAllAreas
-!
-! Description:
-! Compute the area of all cubed sphere grid cells, storing the results in
-! a two dimensional array.
-!
-! Parameters:
-! icube - Resolution of the cubed sphere
-! dA (OUT) - Output array containing the area of all cubed sphere grid cells
-!------------------------------------------------------------------------------
-SUBROUTINE EquiangularAllAreas(icube, dA)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- INTEGER, INTENT(IN) :: icube
- REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA
-
- ! Local variables
- INTEGER :: k, k1, k2
- REAL (r8) :: a1, a2, a3, a4
- REAL (r8), DIMENSION(icube+1,icube+1) :: ang
- REAL (r8), DIMENSION(icube+1) :: gp
-
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
-
-
- !#ifdef DBG
- REAL (r8) :: dbg1 !DBG
- !#endif
-
- ! Recall that we are using equi-angular spherical gridding
- ! Compute the angle between equiangular cubed sphere projection grid lines.
- DO k = 1, icube+1
- gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1)
- ENDDO
-
- DO k2=1,icube+1
- DO k1=1,icube+1
- ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2)))
- ENDDO
- ENDDO
-
- DO k2=1,icube
- DO k1=1,icube
- a1 = ang(k1 , k2 )
- a2 = pi - ang(k1+1, k2 )
- a3 = pi - ang(k1 , k2+1)
- a4 = ang(k1+1, k2+1)
-
- ! area = r*r*(-2*pi+sum(interior angles))
- DA(k1,k2) = -2.0*pi+a1+a2+a3+a4
- ENDDO
- ENDDO
-
- !#ifdef DBG
- ! Only for debugging - test consistency
- dbg1 = 0.0 !DBG
- DO k2=1,icube
- DO k1=1,icube
- dbg1 = dbg1 + DA(k1,k2) !DBG
- ENDDO
- ENDDO
- write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG
- !#endif
-END SUBROUTINE EquiangularAllAreas
-
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereRLLFromABP
-!
-! Description:
-! Determine the lat lon coordinate of a point on a sphere given its
-! (alpha,beta,panel) coordinate.
-!
-! Parameters:
-! alpha - Alpha coordinate
-! beta - Beta coordinate
-! panel - Cubed sphere panel id
-! lon (OUT) - Calculated longitude
-! lat (OUT) - Calculated latitude
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
- REAL (r8), INTENT(IN) :: alpha, beta
- INTEGER , INTENT(IN) :: ipanel
- REAL (r8), INTENT(OUT) :: lon, lat
- ! Local variables
- REAL (r8) :: xx, yy, zz, rotate_cube
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
-
- rotate_cube = 0.0
- ! Convert to cartesian coordinates
- CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz)
- ! Convert back to lat lon
- lat = ASIN(zz)
- if (xx==0.0.and.yy==0.0) THEN
- lon = 0.0
- else
- lon = ATAN2(yy, xx) +rotate_cube
- IF (lon<0.0) lon=lon+2.0*pi
- IF (lon>2.0*pi) lon=lon-2.0*pi
- end if
-END SUBROUTINE CubedSphereRLLFromABP
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereXYZFromABP
-!
-! Description:
-! Determine the Cartesian coordinate of a point on a sphere given its
-! (alpha,beta,panel) coordinate.
-!
-! Parameters:
-! alpha - Alpha coordinate
-! beta - Beta coordinate
-! panel - Cubed sphere panel id
-! xx (OUT) - Calculated x coordinate
-! yy (OUT) - Calculated y coordinate
-! zz (OUT) - Calculated z coordinate
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- REAL (r8), INTENT(IN) :: alpha, beta
- INTEGER , INTENT(IN) :: ipanel
- REAL (r8), INTENT(OUT) :: xx, yy, zz
- ! Local variables
- REAL (r8) :: a1, b1, pm
- REAL (r8) :: sx, sy, sz
-
- ! Convert to Cartesian coordinates
- a1 = TAN(alpha)
- b1 = TAN(beta)
-
- sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5)
- sx = sz * a1
- sy = sz * b1
- ! Panel assignments
- IF (ipanel == 6) THEN
- yy = sx; xx = -sy; zz = sz
- ELSEIF (ipanel == 5) THEN
- yy = sx; xx = sy; zz = -sz
- ELSEIF (ipanel == 1) THEN
- yy = sx; zz = sy; xx = sz
- ELSEIF (ipanel == 3) THEN
- yy = -sx; zz = sy; xx = -sz
- ELSEIF (ipanel == 2) THEN
- xx = -sx; zz = sy; yy = sz
- ELSEIF (ipanel == 4) THEN
- xx = sx; zz = sy; yy = -sz
- ELSE
- WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP'
- WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')'
- STOP
- ENDIF
-END SUBROUTINE CubedSphereXYZFromABP
-
-
diff --git a/tools/topo_tool/bin_to_cube/shr_kind_mod.F90 b/tools/topo_tool/bin_to_cube/shr_kind_mod.F90
deleted file mode 100644
index fc1ed8e94a..0000000000
--- a/tools/topo_tool/bin_to_cube/shr_kind_mod.F90
+++ /dev/null
@@ -1,20 +0,0 @@
-!===============================================================================
-! CVS: $Id$
-! CVS: $Source$
-! CVS: $Name$
-!===============================================================================
-
-MODULE shr_kind_mod
-
- !----------------------------------------------------------------------------
- ! precision/kind constants add data public
- !----------------------------------------------------------------------------
- public
- integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
- integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
- integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
- integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
- integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
- integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
-
-END MODULE shr_kind_mod
diff --git a/tools/topo_tool/cube_to_target/Makefile b/tools/topo_tool/cube_to_target/Makefile
deleted file mode 100644
index 23d518cf03..0000000000
--- a/tools/topo_tool/cube_to_target/Makefile
+++ /dev/null
@@ -1,69 +0,0 @@
-EXEDIR = .
-EXENAME = cube_to_target
-RM = rm
-
-.SUFFIXES:
-.SUFFIXES: .F90 .o
-
-FC = lf95
-DEBUG = FALSE
-
-
-# Check for the NetCDF library and include directories
-ifeq ($(LIB_NETCDF),$(null))
-LIB_NETCDF := /usr/local/lib
-endif
-
-ifeq ($(INC_NETCDF),$(null))
-INC_NETCDF := /usr/local/include
-endif
-
-# Determine platform
-UNAMES := $(shell uname -s)
-UNAMEM := $(findstring CRAY,$(shell uname -m))
-
-#------------------------------------------------------------------------
-# LF95
-#------------------------------------------------------------------------
-#
-# setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib
-#
-ifeq ($(FC),lf95)
-#
-# Tramhill
-#
- INC_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/include
- LIB_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib
-
- LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -lcurl -lhdf5 -lhdf5_hl -mcmodel=medium
- FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF)
- ifeq ($(DEBUG),TRUE)
-# FFLAGS += --chk aesu -Cpp --trace
- FFLAGS += -g --chk a,e,s,u --pca
- else
- FFLAGS += -O
- endif
-
-endif
-
-
-
-.F90.o:
- $(FC) $(FFLAGS) $<
-
-#------------------------------------------------------------------------
-# Default rules and macros
-#------------------------------------------------------------------------
-
-OBJS := reconstruct.o remap.o cube_to_target.o shr_kind_mod.o
-
-$(EXEDIR)/$(EXENAME): $(OBJS)
- $(FC) -o $@ $(OBJS) $(LDFLAGS)
-
-clean:
- $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME)
-
-cube_to_target.o: shr_kind_mod.o remap.o reconstruct.o
-remap.o:
-reconstruct.o: remap.o
-#reconstruct.o : shr_kind_mod.o
diff --git a/tools/topo_tool/cube_to_target/README b/tools/topo_tool/cube_to_target/README
deleted file mode 100644
index 134b6de4f9..0000000000
--- a/tools/topo_tool/cube_to_target/README
+++ /dev/null
@@ -1,20 +0,0 @@
-cube_to_target performs rigourous remapping of topo variables from cubed-sphere grid to
-any target grid. In the process SGH is computed.
-
-Input files:
-
-1. USGS-topo-cube.nc (may be found here $CESMDATA/inputdata/atm/cam/hrtopo/USGS-topo-cube3000.nc)
-
- This is the topo data on a cubed-sphere (default is 3km cubed-sphere grid)
-
-2. target.nc (e.g., $CESMDATA/inputdata/atm/cam/grid-description/se/ne30np4_091226_pentagons.nc)
-
- This is a SCRIP/ESMF grid descriptor file for the target grid
-
-3. phis-smooth.nc
-
- (optional) The user may provide a smoothed PHIS field. The software then recomputes SGH to
- account for the smoothing in the sub-grid-scale.
-
-
-
diff --git a/tools/topo_tool/cube_to_target/cube_to_target.F90 b/tools/topo_tool/cube_to_target/cube_to_target.F90
deleted file mode 100644
index 3f73f6a47b..0000000000
--- a/tools/topo_tool/cube_to_target/cube_to_target.F90
+++ /dev/null
@@ -1,2008 +0,0 @@
-!
-! DATE CODED: Nov 7, 2011 to Oct 15, 2012
-! DESCRIPTION: Remap topo data from cubed-sphere grid to target grid using rigorous remapping
-! (Lauritzen, Nair and Ullrich, 2010, J. Comput. Phys.)
-!
-! Author: Peter Hjort Lauritzen (pel@ucar.edu), AMP/CGD/NESL/NCAR
-!
-program convterr
- use shr_kind_mod, only: r8 => shr_kind_r8
- use reconstruct
- implicit none
-# include
-
- !**************************************
- !
- ! USER SETTINGS BELOW
- !
- !**************************************
- !
- !
- ! if smoothed PHIS is available SGH needs to be recomputed to account for the sub-grid-scale
- ! variability introduced by the smoothing
- !
- logical :: lsmooth_terr = .FALSE.
- !
- ! PHIS is smoothed by other software/dynamical core
- !
- logical :: lexternal_smooth_terr = .FALSE. ! lexternal_smooth_terr = .FALSE. is NOT supported currently
- !
- ! set PHIS=0.0 if LANDFRAC<0.01
- !
- logical :: lzero_out_ocean_point_phis = .FALSE.
- !
- ! For internal smoothing (experimental at this point)
- ! ===================================================
- !
- ! if smoothing is internal (lexternal_smooth_terr=.FALSE.) choose coarsening factor
- !
- ! recommendation: 2*(target resolution)/(0.03 degree)
- !
- ! factor must be an even integer
- !
- integer, parameter :: factor = 60 !coarse grid = 2.25 degrees
- integer, parameter :: norder = 2
- integer, parameter :: nmono = 0
- integer, parameter :: npd = 1
- !
- !**********************************************************************
- !
- ! END OF USER SETTINS BELOW
- ! (do not edit beyond this point unless you know what you are doing!)
- !
- !**********************************************************************
- !
- integer :: im, jm, ncoarse
- integer :: ncube !dimension of cubed-sphere grid
-
- real(r8), allocatable, dimension(:) :: landm_coslat, landfrac, terr, sgh30
- real(r8), allocatable, dimension(:) :: terr_coarse !for internal smoothing
-
- integer :: alloc_error,dealloc_error
- integer :: i,j,n,k,index
- integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile
- integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file
- integer :: srcid,dstid, jm_dbg ! for netCDF weight file
- integer, dimension(2) :: src_grid_dims ! for netCDF weight file
-
- integer :: dimid
-
- logical :: ldbg
- real(r8), allocatable, dimension(:) :: lon , lat
- real(r8), allocatable, dimension(:) :: lon_landm , lat_landm
- real(r8), allocatable, dimension(:) :: area
- integer :: im_landm, jm_landm
- integer :: lonid, latid, phisid
- !
- ! constants
- !
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: pih = 0.50*pi
- REAL (r8), PARAMETER :: deg2rad = pi/180.0
-
- real(r8) :: wt,dlat
- integer :: ipanel,icube,jcube
- real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube
- real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube
- integer, allocatable, dimension(:,:) :: idx,idy,idp
- integer :: npatch, isub,jsub, itmp, iplm1,jmin,jmax
- real(r8) :: sum,dx,scale,dmax,arad,jof,term,s1,c1,clon,iof,dy,s2,c2,dist
- !
- ! for linear interpolation
- !
- real(r8) :: lambda,theta,wx,wy,offset
- integer :: ilon,ilat,ip1,jp1
- !
- ! variable for regridding
- !
- integer :: src_grid_dim ! for netCDF weight file
- integer :: n_a,n_b,n_s,n_aid,n_bid,n_sid
- integer :: count
- real(r8), allocatable, dimension(:) :: landfrac_target, terr_target, sgh30_target, sgh_target
- real(r8), allocatable, dimension(:) :: landm_coslat_target, area_target
- !
- ! this is only used if target grid is a lat-lon grid
- !
- integer , parameter :: im_target = 360 , jm_target = 180
- !
- ! this is only used if target grid is not a lat-lon grid
- !
- real(r8), allocatable, dimension(:) :: lon_target, lat_target
- !
- ! new
- !
- integer :: ntarget, ntarget_id, ncorner, ncorner_id, nrank, nrank_id
- integer :: ntarget_smooth
- real(r8), allocatable, dimension(:,:):: target_corner_lon, target_corner_lat
- real(r8), allocatable, dimension(:) :: target_center_lon, target_center_lat, target_area
- integer :: ii,ip,jx,jy,jp
- real(r8), dimension(:), allocatable :: xcell, ycell, xgno, ygno
- real(r8), dimension(:), allocatable :: gauss_weights,abscissae
- integer, parameter :: ngauss = 3
- integer :: jmax_segments,jall
- real(r8) :: tmp
-
- real(r8), allocatable, dimension(:,:) :: weights_all
- integer , allocatable, dimension(:,:) :: weights_eul_index_all
- integer , allocatable, dimension(:) :: weights_lgr_index_all
- integer :: ix,iy
- !
- ! volume of topography
- !
- real(r8) :: vol_target, vol_target_un, area_target_total,vol_source,vol_tmp
- integer :: nlon,nlon_smooth,nlat,nlat_smooth
- logical :: ltarget_latlon,lpole
- real(r8), allocatable, dimension(:,:) :: terr_smooth
- !
- ! for internal filtering
- !
- real(r8), allocatable, dimension(:,:) :: weights_all_coarse
- integer , allocatable, dimension(:,:) :: weights_eul_index_all_coarse
- integer , allocatable, dimension(:) :: weights_lgr_index_all_coarse
- real(r8), allocatable, dimension(:) :: area_target_coarse
- real(r8), allocatable, dimension(:,:) :: da_coarse,da
- real(r8), allocatable, dimension(:,:) :: recons,centroids
- integer :: nreconstruction
-
- integer :: jmax_segments_coarse,jall_coarse,ncube_coarse
- real(r8) :: all_weights
-
- !
- ! turn extra debugging on/off
- !
- ldbg = .FALSE.
-
- nreconstruction = 1
- !
- !*********************************************************
- !
- ! read in target grid
- !
- !*********************************************************
- !
- status = nf_open('target.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
-
- status = NF_INQ_DIMID(ncid, 'grid_size', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, ntarget)
- WRITE(*,*) "dimension of target grid: ntarget=",ntarget
-
- status = NF_INQ_DIMID(ncid, 'grid_corners', ncorner_id)
- status = NF_INQ_DIMLEN(ncid, ncorner_id, ncorner)
- WRITE(*,*) "maximum number of corners: ncorner=",ncorner
-
- status = NF_INQ_DIMID(ncid, 'grid_rank', nrank_id);status = NF_INQ_DIMLEN(ncid, nrank_id, nrank)
- WRITE(*,*) "grid rank: nrank=",nrank
- IF (nrank==2) THEN
- WRITE(*,*) "target grid is a lat-lon grid"
- ltarget_latlon = .TRUE.
- status = NF_INQ_DIMID(ncid, 'nlon', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon)
- status = NF_INQ_DIMID(ncid, 'nlat', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat)
- status = NF_INQ_DIMID(ncid, 'lpole', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, lpole)
- WRITE(*,*) "nlon=",nlon,"nlat=",nlat
- IF (lpole) THEN
- WRITE(*,*) "center of most Northern grid cell is lat=90; similarly for South pole"
- ELSE
- WRITE(*,*) "center of most Northern grid cell is NOT lat=90; similarly for South pole"
- END IF
- ELSE IF (nrank==1) THEN
- ltarget_latlon = .FALSE.
- ELSE
- WRITE(*,*) "nrank out of range",nrank
- STOP
- ENDIF
-
- allocate ( target_corner_lon(ncorner,ntarget),stat=alloc_error)
- allocate ( target_corner_lat(ncorner,ntarget),stat=alloc_error)
-
- status = NF_INQ_VARID(ncid, 'grid_corner_lon', lonid)
- status = NF_GET_VAR_DOUBLE(ncid, lonid,target_corner_lon)
- IF (maxval(target_corner_lon)>10.0) target_corner_lon = deg2rad*target_corner_lon
-
- status = NF_INQ_VARID(ncid, 'grid_corner_lat', latid)
- status = NF_GET_VAR_DOUBLE(ncid, latid,target_corner_lat)
- IF (maxval(target_corner_lat)>10.0) target_corner_lat = deg2rad*target_corner_lat
- !
- ! for writing remapped data on file at the end of the program
- !
- allocate ( target_center_lon(ntarget),stat=alloc_error)
- allocate ( target_center_lat(ntarget),stat=alloc_error)
- allocate ( target_area (ntarget),stat=alloc_error)!dbg
-
- status = NF_INQ_VARID(ncid, 'grid_center_lon', lonid)
- status = NF_GET_VAR_DOUBLE(ncid, lonid,target_center_lon)
-
- status = NF_INQ_VARID(ncid, 'grid_center_lat', latid)
- status = NF_GET_VAR_DOUBLE(ncid, latid,target_center_lat)
-
- status = NF_INQ_VARID(ncid, 'grid_area', latid)
- status = NF_GET_VAR_DOUBLE(ncid, latid,target_area)
-
- status = nf_close (ncid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- !****************************************************
- !
- ! get dimension of cubed-sphere grid
- !
- !****************************************************
- !
- WRITE(*,*) "get dimension of cubed-sphere data from file"
- status = nf_open('USGS-topo-cube.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
-
- status = NF_INQ_DIMID(ncid, 'grid_size', dimid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimid, n)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- ncube = INT(SQRT(DBLE(n/6)))
- WRITE(*,*) "cubed-sphere dimension: ncube = ",ncube
- WRITE(*,*) "average grid-spacing at the Equator (degrees):" ,90.0/ncube
-
- status = nf_close (ncid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- !****************************************************
- !
- ! compute weights for remapping
- !
- !****************************************************
- !
- jall = ncube*ncube*12*10 !anticipated number of weights (cab be tweaked)
- jmax_segments = 100000 !can be tweaked
-
- allocate (weights_all(jall,nreconstruction),stat=alloc_error )
- allocate (weights_eul_index_all(jall,3),stat=alloc_error )
- allocate (weights_lgr_index_all(jall),stat=alloc_error )
-
- CALL overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,&
- jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction)
- !
- !****************************************************
- !
- ! read cubed-sphere 3km data
- !
- !****************************************************
- !
- WRITE(*,*) "read cubed-sphere 3km data from file"
- status = nf_open('USGS-topo-cube.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
-
- status = NF_INQ_DIMID(ncid, 'grid_size', dimid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- status = NF_INQ_DIMLEN(ncid, dimid, n)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- ncube = INT(SQRT(DBLE(n/6)))
- WRITE(*,*) "cubed-sphere dimension, ncube: ",ncube
-
- allocate ( landm_coslat(n),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat)
- !
- ! read LANDFRAC
- !
- allocate ( landfrac(n),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- status = NF_INQ_VARID(ncid, 'LANDFRAC', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_DOUBLE(ncid, landid,landfrac)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of landfrac",MINVAL(landfrac),MAXVAL(landfrac)
- !
- ! read terr
- !
- allocate ( terr(n),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- status = NF_INQ_VARID(ncid, 'terr', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_DOUBLE(ncid, landid,terr)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of terr",MINVAL(terr),MAXVAL(terr)
- !
- !
- !
- allocate ( sgh30(n),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
-
- status = NF_INQ_VARID(ncid, 'SGH30', landid)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
-
- status = NF_GET_VAR_DOUBLE(ncid, landid,sgh30)
- IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status)
- WRITE(*,*) "min/max of sgh30",MINVAL(sgh30),MAXVAL(sgh30)
- print *,"close file"
- status = nf_close (ncid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file'
- !
- !*********************************************************
- !
- ! do actual remapping
- !
- !*********************************************************
- !
- allocate (terr_target(ntarget),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr_target'
- stop
- end if
- allocate (landfrac_target(ntarget),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac_target'
- stop
- end if
- allocate (landm_coslat_target(ntarget),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac_target'
- stop
- end if
- allocate (sgh30_target(ntarget),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for sgh30_target'
- stop
- end if
- allocate (area_target(ntarget),stat=alloc_error )
- terr_target = 0.0
- landfrac_target = 0.0
- sgh30_target = 0.0
- landm_coslat_target = 0.0
- area_target = 0.0
-
- tmp = 0.0
- do count=1,jall
- i = weights_lgr_index_all(count)
- wt = weights_all(count,1)
- area_target (i) = area_target(i) + wt
- end do
-
- do count=1,jall
- i = weights_lgr_index_all(count)
-
- ix = weights_eul_index_all(count,1)
- iy = weights_eul_index_all(count,2)
- ip = weights_eul_index_all(count,3)
- !
- ! convert to 1D indexing of cubed-sphere
- !
- ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix
-
- wt = weights_all(count,1)
-
- terr_target (i) = terr_target (i) + wt*terr (ii)/area_target(i)
- landfrac_target (i) = landfrac_target (i) + wt*landfrac (ii)/area_target(i)
- landm_coslat_target(i) = landm_coslat_target(i) + wt*landm_coslat(ii)/area_target(i)
- sgh30_target (i) = sgh30_target (i) + wt*sgh30 (ii)/area_target(i)
-
- tmp = tmp+wt*terr(ii)
- end do
-
-
- write(*,*) "tmp", tmp
- WRITE(*,*) "max difference between target grid area and remapping software area",&
- MAXVAL(target_area-area_target)
-
- do count=1,ntarget
- if (terr_target(count)>8848.0) then
- !
- ! max height is higher than Mount Everest
- !
- write(*,*) "FATAL error: max height is higher than Mount Everest!"
- write(*,*) "terr_target",count,terr_target(count)
- write(*,*) "(lon,lat) locations of vertices of cell with excessive max height::"
- do i=1,ncorner
- write(*,*) target_corner_lon(i,count),target_corner_lat(i,count)
- end do
- STOP
- else if (terr_target(count)<-423.0) then
- !
- ! min height is lower than Dead Sea
- !
- write(*,*) "FATAL error: min height is lower than Dead Sea!"
- write(*,*) "terr_target",count,terr_target(count)
- write(*,*) "(lon,lat) locations of vertices of cell with excessive min height::"
- do i=1,ncorner
- write(*,*) target_corner_lon(i,count),target_corner_lat(i,count)
- end do
- STOP
- else
-
- end if
- end do
- WRITE(*,*) "Elevation data passed min/max consistency check!"
- WRITE(*,*)
-
- WRITE(*,*) "min/max of unsmoothed terr_target : ",MINVAL(terr_target ),MAXVAL(terr_target )
- WRITE(*,*) "min/max of landfrac_target : ",MINVAL(landfrac_target),MAXVAL(landfrac_target)
- WRITE(*,*) "min/max of landm_coslat_target : ",&
- MINVAL(landm_coslat_target),MAXVAL(landm_coslat_target)
- WRITE(*,*) "min/max of var30_target : ",MINVAL(sgh30_target ),MAXVAL(sgh30_target )
- !
- ! compute mean height (globally) of topography about sea-level for target grid unfiltered elevation
- !
- vol_target_un = 0.0
- area_target_total = 0.0
- DO i=1,ntarget
- area_target_total = area_target_total+area_target(i)
- vol_target_un = vol_target_un+terr_target(i)*area_target(i)
- END DO
- WRITE(*,*) "mean height (globally) of topography about sea-level for target grid unfiltered elevation",&
- vol_target_un/area_target_total
-
- !
- ! diagnostics
- !
- vol_source = 0.0
- allocate ( dA(ncube,ncube),stat=alloc_error )
- CALL EquiangularAllAreas(ncube, dA)
- DO jp=1,6
- DO jy=1,ncube
- DO jx=1,ncube
- ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx
- vol_source = vol_source+terr(ii)*dA(jx,jy)
- END DO
- END DO
- END DO
- WRITE(*,*) "volume of input cubed-sphere terrain :",vol_source
- WRITE(*,*) "average elevation of input cubed-sphere terrain:",vol_source/(4.0*pi)
-
- DEALLOCATE(dA)
- !
- !
- !
- allocate (sgh_target(ntarget),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for sgh_target'
- stop
- end if
- !
- ! compute variance with respect to cubed-sphere data
- !
- WRITE(*,*) "compute variance with respect to 3km cubed-sphere data: SGH"
-
- IF (lsmooth_terr) THEN
- WRITE(*,*) "smoothing PHIS"
- IF (lexternal_smooth_terr) THEN
- WRITE(*,*) "using externally generated smoothed topography"
-
- status = nf_open('phis-smooth.nc', 0, ncid)
- IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS)
- !
- IF (.NOT.ltarget_latlon) THEN
- !
- !*********************************************************
- !
- ! read in smoothed topography
- !
- !*********************************************************
- !
- status = NF_INQ_DIMID (ncid, 'ncol', ntarget_id )
- status = NF_INQ_DIMLEN(ncid, ntarget_id , ntarget_smooth)
- IF (ntarget.NE.ntarget_smooth) THEN
- WRITE(*,*) "mismatch in smoothed data-set and target grid specification"
- WRITE(*,*) ntarget, ntarget_smooth
- STOP
- END IF
- status = NF_INQ_VARID(ncid, 'PHIS', phisid)
- !
- ! overwrite terr_target with smoothed version
- !
- status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_target)
- terr_target = terr_target/9.80616
- ELSE
- !
- ! read in smoothed lat-lon topography
- !
- status = NF_INQ_DIMID(ncid, 'lon', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon_smooth)
- status = NF_INQ_DIMID(ncid, 'lat', ntarget_id)
- status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat_smooth)
- IF (nlon.NE.nlon_smooth.OR.nlat.NE.nlat_smooth) THEN
- WRITE(*,*) "smoothed topography dimensions do not match target grid dimensions"
- WRITE(*,*) "target grid : nlon ,nlat =",nlon,nlat
- WRITE(*,*) "smoothed topo: nlon_smooth,nlat_smooth =",nlon_smooth,nlat_smooth
- STOP
- END IF
- ALLOCATE(terr_smooth(nlon_smooth,nlat_smooth),stat=alloc_error)
- status = NF_INQ_VARID(ncid, 'PHIS', phisid)
- status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_smooth)
- !
- ! overwrite terr_target with smoothed version
- !
- ii=1
- DO j=1,nlat
- DO i=1,nlon
- terr_target(ii) = terr_smooth(i,j)/9.80616
- ii=ii+1
- END DO
- END DO
- DEALLOCATE(terr_smooth)
- END IF
- ELSE
- WRITE(*,*) "unstested software - uncomment this line of you know what you are doing!"
- STOP
- !
- !*****************************************************
- !
- ! smoothing topography internally
- !
- !*****************************************************
- !
- WRITE(*,*) "internally smoothing orography"
- ! CALL smooth(terr_target,ntarget,target_corner_lon,target_corner_lat)
- !
- ! smooth topography internally
- !
- ncoarse = n/(factor*factor)
- !
- !
- !
- ncube_coarse = ncube/factor
- WRITE(*,*) "resolution of coarse grid", 90.0/ncube_coarse
- allocate ( terr_coarse(ncoarse),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for landfrac'
- stop
- end if
- WRITE(*,*) "coarsening"
- allocate ( dA_coarse(ncube_coarse,ncube_coarse),stat=alloc_error )
- CALL coarsen(terr,terr_coarse,factor,n,dA_coarse)
- !
- !
- !
- vol_tmp = 0.0
- DO jp=1,6
- DO jy=1,ncube_coarse
- DO jx=1,ncube_coarse
- ii = (jp-1)*ncube_coarse*ncube_coarse+(jy-1)*ncube_coarse+jx
- vol_tmp = vol_tmp+terr_coarse(ii)*dA_coarse(jx,jy)
- END DO
- END DO
- END DO
- WRITE(*,*) "volume of coarsened cubed-sphere terrain :",vol_source
- WRITE(*,*) "difference between coarsened cubed-sphere data and input cubed-sphere data",&
- vol_tmp-vol_source
-
-
-
- WRITE(*,*) "done coarsening"
-
- nreconstruction = 1
- IF (norder>1) THEN
- IF (norder == 2) THEN
- nreconstruction = 3
- ELSEIF (norder == 3) THEN
- nreconstruction = 6
- END IF
- ALLOCATE(recons (nreconstruction, ncoarse), STAT=status)
- ALLOCATE(centroids(nreconstruction, ncoarse), STAT=status)
- CALL get_reconstruction(terr_coarse,norder, nmono, recons, npd,da_coarse,&
- ncube_coarse+1,nreconstruction,centroids)
- SELECT CASE (nmono)
- CASE (0)
- WRITE(*,*) "coarse grid reconstructions are not filtered with shape-preesrving filter"
- CASE (1)
- WRITE(*,*) "coarse grid reconstructions are filtered with shape-preserving filter"
- CASE DEFAULT
- WRITE(*,*) "nmono out of range: ",nmono
- STOP
- END SELECT
- SELECT CASE (0)
- CASE (0)
- WRITE(*,*) "coarse grid reconstructions are not filtered with positive definite filter"
- CASE (1)
- WRITE(*,*) "coarse grid reconstructions filtered with positive definite filter"
- CASE DEFAULT
- WRITE(*,*) "npd out of range: ",npd
- STOP
- END SELECT
- END IF
-
- jall_coarse = (ncube*ncube*12) !anticipated number of weights
- jmax_segments_coarse = jmax_segments!/factor !
- WRITE(*,*) "anticipated",jall_coarse
- allocate (weights_all_coarse(jall_coarse,nreconstruction),stat=alloc_error )
- allocate (weights_eul_index_all_coarse(jall_coarse,3),stat=alloc_error )
- allocate (weights_lgr_index_all_coarse(jall_coarse),stat=alloc_error )
- !
- !
- !
- CALL overlap_weights(weights_lgr_index_all_coarse,weights_eul_index_all_coarse,weights_all_coarse,&
- jall_coarse,ncube_coarse,ngauss,ntarget,ncorner,jmax_segments_coarse,target_corner_lon,&
- target_corner_lat,nreconstruction)
- WRITE(*,*) "MIN/MAX of area-weight [0:1]: ",&
- MINVAL(weights_all_coarse(:,1)),MAXVAL(weights_all_coarse(:,1))
- !
- ! compute new weights
- !
-
- !
- ! do mapping
- !
- terr_target = 0.0
- tmp = 0.0
- allocate ( area_target_coarse(ntarget),stat=alloc_error)
- all_weights = 0.0
- area_target_coarse = 0.0
- do count=1,jall_coarse
- i = weights_lgr_index_all_coarse(count)
- wt = weights_all_coarse(count,1)
- area_target_coarse (i) = area_target_coarse(i) + wt
- all_weights = all_weights+wt
- end do
- WRITE(*,*) "sum of all weights (coarse to target) minus area of sphere : ",all_weights-4.0*pi
- WRITE(*,*) "MIN/MAX of area_target_coarse [0:1]:",&
- MINVAL(area_target_coarse),MAXVAL(area_target_coarse)
- IF (norder==1) THEN
- do count=1,jall_coarse
- i = weights_lgr_index_all_coarse(count)
-
- ix = weights_eul_index_all_coarse(count,1)
- iy = weights_eul_index_all_coarse(count,2)
- ip = weights_eul_index_all_coarse(count,3)
- !
- ! convert to 1D indexing of cubed-sphere
- !
- ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix
-
- wt = weights_all_coarse(count,1)
-
- terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i)
- tmp = tmp+wt*terr_coarse(ii)
- end do
- ELSE IF (norder==2) THEN
- do count=1,jall_coarse
- i = weights_lgr_index_all_coarse(count)
- IF (i>jall_coarse.OR.i<1) THEN
- WRITE(*,*) i,jall_coarse
- STOP
- END IF
- ix = weights_eul_index_all_coarse(count,1)
- iy = weights_eul_index_all_coarse(count,2)
- ip = weights_eul_index_all_coarse(count,3)
- !
- ! convert to 1D indexing of cubed-sphere
- !
- ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix
-
- terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(&
- !
- ! all constant terms
- !
- terr_coarse(ii) &
- - recons(1,ii)*centroids(1,ii) &
- - recons(2,ii)*centroids(2,ii) &
- !
- ! + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))&
- ! + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))&
- !
- ! + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))&
- )+&
- !
- ! linear terms
- !
- weights_all_coarse(count,2)*(&
-
- recons(1,ii)&
-
- ! - recons(3,ii)*2.0*centroids(1,ii)&
- ! - recons(5,ii)* centroids(2,ii)&
- )+&
- !
- weights_all_coarse(count,3)*(&
- recons(2,ii)&
- !
- ! - recons(4,ii)*2.0*centroids(2,ii)&
- ! - recons(5,ii)* centroids(1,ii)&
- )&
- !
- ! quadratic terms
- !
- ! weights_all_coarse(count,4)*recons(3,ii)+&
- ! weights_all_coarse(count,5)*recons(4,ii)+&
- ! weights_all_coarse(count,6)*recons(5,ii)
- )/area_target_coarse(i)
- end do
- DEALLOCATE(centroids)
- DEALLOCATE(recons)
- DEALLOCATE(weights_all_coarse)
-
- ELSE IF (norder==3) THEN
- ! recons(4,:) = 0.0
- ! recons(5,:) = 0.0
- do count=1,jall_coarse
- i = weights_lgr_index_all_coarse(count)
- IF (i>jall_coarse.OR.i<1) THEN
- WRITE(*,*) i,jall_coarse
- STOP
- END IF
- ix = weights_eul_index_all_coarse(count,1)
- iy = weights_eul_index_all_coarse(count,2)
- ip = weights_eul_index_all_coarse(count,3)
- !
- ! convert to 1D indexing of cubed-sphere
- !
- ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix
-
- ! terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i)
-
- ! WRITE(*,*) count,area_target_coarse(i)
- ! terr_target(i) = terr_target(i) + area_target_coarse(i)
- !
- terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(&
-
-
- ! centroids(5,ii))/area_target_coarse(i))
- ! centroids(1,ii)/area_target_coarse(i))
- ! /area_target_coarse(i))
-
-
-
-
- !
- ! all constant terms
- !
- terr_coarse(ii) &
- - recons(1,ii)*centroids(1,ii) &
- - recons(2,ii)*centroids(2,ii) &
- !
- + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))&
- + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))&
- !
- + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))&
- )+&
- !
- ! linear terms
- !
- weights_all_coarse(count,2)*(&
-
- recons(1,ii)&
-
- - recons(3,ii)*2.0*centroids(1,ii)&
- - recons(5,ii)* centroids(2,ii)&
- )+&
- !
- weights_all_coarse(count,3)*(&
- recons(2,ii)&
- !
- - recons(4,ii)*2.0*centroids(2,ii)&
- - recons(5,ii)* centroids(1,ii)&
- )+&
- !
- ! quadratic terms
- !
- weights_all_coarse(count,4)*recons(3,ii)+&
- weights_all_coarse(count,5)*recons(4,ii)+&
- weights_all_coarse(count,6)*recons(5,ii))/area_target_coarse(i)
- end do
- DEALLOCATE(centroids)
- DEALLOCATE(recons)
- DEALLOCATE(weights_all_coarse)
- END IF
- DEALLOCATE(area_target_coarse)
- WRITE(*,*) "done smoothing"
- END IF
- !
- ! compute mean height (globally) of topography about sea-level for target grid filtered elevation
- !
- vol_target = 0.0
- DO i=1,ntarget
- vol_target = vol_target+terr_target(i)*area_target(i)
- ! if (ABS(area_target(i)-area_target_coarse(i))>0.000001) THEN
- ! WRITE(*,*) "xxx",area_target(i),area_target_coarse(i),area_target(i)-area_target_coarse(i)
- ! STOP
- ! END IF
- END DO
- WRITE(*,*) "mean height (globally) of topography about sea-level for target grid filtered elevation",&
- vol_target/area_target_total
- WRITE(*,*) "percentage change in mean height between filtered and unfiltered elevations",&
- 100.0*(vol_target-vol_target_un)/vol_target_un
- WRITE(*,*) "percentage change in mean height between input cubed-sphere and unfiltered elevations",&
- 100.0*(vol_source-vol_target_un)/vol_source
-
- END IF
- !
- ! Done internal smoothing
- !
- WRITE(*,*) "min/max of terr_target : ",MINVAL(terr_target),MAXVAL(terr_target)
-
- if (lzero_out_ocean_point_phis) then
- WRITE(*,*) "if ocean mask PHIS=0.0"
- end if
-
-
- sgh_target=0.0
- do count=1,jall
- i = weights_lgr_index_all(count)!!
- !
- ix = weights_eul_index_all(count,1)
- iy = weights_eul_index_all(count,2)
- ip = weights_eul_index_all(count,3)
- !
- ! convert to 1D indexing of cubed-sphere
- !
- ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix!
-
- wt = weights_all(count,1)
-
- if (lzero_out_ocean_point_phis.AND.landfrac_target(i).lt.0.01_r8) then
- terr_target(i) = 0.0_r8 !5*terr_target(i)
- end if
- sgh_target(i) = sgh_target(i)+wt*((terr_target(i)-terr(ii))**2)/area_target(i)
- end do
-
-
-
- !
- ! zero out small values
- !
- DO i=1,ntarget
- IF (landfrac_target(i)<.001_r8) landfrac_target(i) = 0.0
- IF (sgh_target(i)<0.5) sgh_target(i) = 0.0
- IF (sgh30_target(i)<0.5) sgh30_target(i) = 0.0
- END DO
- sgh_target = SQRT(sgh_target)
- sgh30_target = SQRT(sgh30_target)
- WRITE(*,*) "min/max of sgh_target : ",MINVAL(sgh_target),MAXVAL(sgh_target)
- WRITE(*,*) "min/max of sgh30_target : ",MINVAL(sgh30_target),MAXVAL(sgh30_target)
-
- DEALLOCATE(terr,weights_all,weights_eul_index_all,landfrac,landm_coslat)
-
-
- IF (ltarget_latlon) THEN
- CALL wrtncdf_rll(nlon,nlat,lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,&
- landm_coslat_target,target_center_lon,target_center_lat,.true.)
- ELSE
- CALL wrtncdf_unstructured(ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,&
- landm_coslat_target,target_center_lon,target_center_lat)
- END IF
- DEALLOCATE(terr_target,landfrac_target,sgh30_target,sgh_target,landm_coslat_target)
-
-end program convterr
-
-!
-!
-!
-subroutine wrtncdf_unstructured(n,terr,landfrac,sgh,sgh30,landm_coslat,lon,lat)
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-# include
-
- !
- ! Dummy arguments
- !
- integer, intent(in) :: n
- real(r8),dimension(n) , intent(in) :: terr, landfrac,sgh,sgh30,lon, lat, landm_coslat
- !
- ! Local variables
- !
- character (len=64) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: terrid,nid
- integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j
- integer, dimension(2) :: nc_lat_vid,nc_lon_vid
- character (len=8) :: datestring
- integer :: nc_gridcorn_id, lat_vid, lon_vid
-
- real(r8), parameter :: fillvalue = 1.d36
-
- fout='new-topo-file.nc'
- !
- ! Create NetCDF file for output
- !
- print *,"Create NetCDF file for output"
- status = nf_create (fout, NF_64BIT_OFFSET , foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Create dimensions for output
- !
- status = nf_def_dim (foutid, 'ncol', n, nid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Create variable for output
- !
- print *,"Create variable for output"
- status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 1, nid, terrid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 1, nid, landfracid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'SGH', NF_DOUBLE, 1, nid, sghid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 1, nid, sgh30id)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 1, nid, landm_coslatid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, nid, latvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, nid, lonvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- !
- ! Create attributes for output variables
- !
- status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential')
- status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2')
- status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue)
- ! status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from USGS 30-sec data')
-
- status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, sghid, 'long_name' , 48, &
- 'standard deviation of 3km cubed-sphere elevation and target grid elevation')
- status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm')
- ! status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, &
- 'standard deviation of 30s elevation from 3km cubed-sphere cell average height')
- status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm')
- ! status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction')
- status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction')
- ! status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data')
-
-
- status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north')
- if (status .ne. NF_NOERR) call handle_err(status)
- ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations')
- ! if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east')
- if (status .ne. NF_NOERR) call handle_err(status)
- ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations')
- ! if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,NF_GLOBAL,'source', 50, 'USGS 30-sec dataset binned to ncube3000 (cube-sphere) grid')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data')
- if (status .ne. NF_NOERR) call handle_err(status)
- call DATE_AND_TIME(DATE=datestring)
- status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring )
- if (status .ne. NF_NOERR) call handle_err(status)
-
- !
- ! End define mode for output file
- !
- status = nf_enddef (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Write variable for output
- !
- print*,"writing terrain data",MINVAL(terr),MAXVAL(terr)
- status = nf_put_var_double (foutid, terrid, terr*9.80616)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing terrain data"
-
- print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac)
- status = nf_put_var_double (foutid, landfracid, landfrac)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing landfrac data"
-
- print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh)
- status = nf_put_var_double (foutid, sghid, sgh)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh data"
-
- print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30)
- status = nf_put_var_double (foutid, sgh30id, sgh30)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh30 data"
-
- print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat)
- status = nf_put_var_double (foutid, landm_coslatid, landm_coslat)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh30 data"
- !
- print*,"writing lat data"
- status = nf_put_var_double (foutid, latvid, lat)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lat data"
-
- print*,"writing lon data"
- status = nf_put_var_double (foutid, lonvid, lon)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lon data"
- !
- ! Close output file
- !
- print *,"close file"
- status = nf_close (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-end subroutine wrtncdf_unstructured
-!
-!**************************************************************
-!
-! if target grid is lat-lon output structured
-!
-!**************************************************************
-!
-subroutine wrtncdf_rll(nlon,nlat,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine)
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-# include
-
- !
- ! Dummy arguments
- !
- integer, intent(in) :: n,nlon,nlat
- !
- ! lprepare_fv_smoothing_routine is to make a NetCDF file that can be used with the CAM-FV smoothing software
- !
- logical , intent(in) :: lpole,lprepare_fv_smoothing_routine
- real(r8),dimension(n) , intent(in) :: terr_in, landfrac_in,sgh_in,sgh30_in,lon, lat, landm_coslat_in
- !
- ! Local variables
- !
- character (len=32) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: terrid,nid
- integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j
- integer, dimension(2) :: nc_lat_vid,nc_lon_vid
- character (len=8) :: datestring
- integer :: nc_gridcorn_id, lat_vid, lon_vid
- real(r8), parameter :: fillvalue = 1.d36
- real(r8) :: ave
-
- real(r8),dimension(nlon) :: lonar ! longitude array
- real(r8),dimension(nlat) :: latar ! latitude array
-
- integer, dimension(2) :: htopodim,landfdim,sghdim,sgh30dim,landmcoslatdim
- real(r8),dimension(n) :: terr, landfrac,sgh,sgh30,landm_coslat
-
- IF (nlon*nlat.NE.n) THEN
- WRITE(*,*) "inconsistent input for wrtncdf_rll"
- STOP
- END IF
- !
- ! we assume that the unstructured layout of the lat-lon grid is ordered in latitude rows, that is,
- ! unstructured index n is given by
- !
- ! n = (j-1)*nlon+i
- !
- ! where j is latitude index and i longitude index
- !
- do i = 1,nlon
- lonar(i)= lon(i)
- enddo
- do j = 1,nlat
- latar(j)= lat((j-1)*nlon+1)
- enddo
-
- terr = terr_in
- sgh=sgh_in
- sgh30 =sgh30_in
- landfrac = landfrac_in
- landm_coslat = landm_coslat_in
-
- if (lpole) then
- write(*,*) "average pole control volume"
- !
- ! North pole - terr
- !
- ave = 0.0
- do i=1,nlon
- ave = ave + terr_in(i)
- end do
- terr(1:nlon) = ave/DBLE(nlon)
- !
- ! South pole
- !
- ave = 0.0
- do i=n-(nlon+1),n
- ave = ave + terr_in(i)
- end do
- terr(n-(nlon+1):n) = ave/DBLE(nlon)
-
- !
- ! North pole - sgh
- !
- ave = 0.0
- do i=1,nlon
- ave = ave + sgh_in(i)
- end do
- sgh(1:nlon) = ave/DBLE(nlon)
- !
- ! South pole
- !
- ave = 0.0
- do i=n-(nlon+1),n
- ave = ave + sgh_in(i)
- end do
- sgh(n-(nlon+1):n) = ave/DBLE(nlon)
-
- !
- ! North pole - sgh30
- !
- ave = 0.0
- do i=1,nlon
- ave = ave + sgh30_in(i)
- end do
- sgh30(1:nlon) = ave/DBLE(nlon)
- !
- ! South pole
- !
- ave = 0.0
- do i=n-(nlon+1),n
- ave = ave + sgh30_in(i)
- end do
- sgh30(n-(nlon+1):n) = ave/DBLE(nlon)
-
- !
- ! North pole - landfrac
- !
- ave = 0.0
- do i=1,nlon
- ave = ave + landfrac_in(i)
- end do
- landfrac(1:nlon) = ave/DBLE(nlon)
- !
- ! South pole
- !
- ave = 0.0
- do i=n-(nlon+1),n
- ave = ave + landfrac_in(i)
- end do
- landfrac(n-(nlon+1):n) = ave/DBLE(nlon)
-
- !
- ! North pole - landm_coslat
- !
- ave = 0.0
- do i=1,nlon
- ave = ave + landm_coslat_in(i)
- end do
- landm_coslat(1:nlon) = ave/DBLE(nlon)
- !
- ! South pole
- !
- ave = 0.0
- do i=n-(nlon+1),n
- ave = ave + landm_coslat_in(i)
- end do
- landm_coslat(n-(nlon+1):n) = ave/DBLE(nlon)
- end if
-
-
- fout='final.nc'
- !
- ! Create NetCDF file for output
- !
- print *,"Create NetCDF file for output"
- status = nf_create (fout, NF_64BIT_OFFSET , foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Create dimensions for output
- !
- print *,"Create dimensions for output"
- status = nf_def_dim (foutid, 'lon', nlon, lonid)
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_def_dim (foutid, 'lat', nlat, latid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Create variable for output
- !
- print *,"Create variable for output"
-
- htopodim(1)=lonid
- htopodim(2)=latid
-
- if (lprepare_fv_smoothing_routine) then
- status = nf_def_var (foutid,'htopo', NF_DOUBLE, 2, htopodim, terrid)
- else
- status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 2, htopodim, terrid)
- end if
- if (status .ne. NF_NOERR) call handle_err(status)
-
- landfdim(1)=lonid
- landfdim(2)=latid
-
- if (lprepare_fv_smoothing_routine) then
- status = nf_def_var (foutid,'ftopo', NF_DOUBLE, 2, landfdim, landfracid)
- else
- status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 2, landfdim, landfracid)
- end if
-
- if (status .ne. NF_NOERR) call handle_err(status)
-
- sghdim(1)=lonid
- sghdim(2)=latid
-
- status = nf_def_var (foutid,'SGH', NF_DOUBLE, 2, sghdim, sghid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- sgh30dim(1)=lonid
- sgh30dim(2)=latid
-
- status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 2, sgh30dim, sgh30id)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- landmcoslatdim(1)=lonid
- landmcoslatdim(2)=latid
-
- status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, landmcoslatdim, landm_coslatid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- !
- ! Create attributes for output variables
- !
- status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential')
- status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2')
- status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from ncube3000 data')
- status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue)
-
-
- status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, sghid, 'long_name' , 48, &
- 'standard deviation of 3km cubed-sphere elevation and target grid elevation')
- status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm')
- status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, &
- 'standard deviation of 30s elevation from 3km cubed-sphere cell average height')
- status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm')
- status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction')
- status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none')
-
- status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue)
- status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue)
- status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction')
- status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data')
-
-
- status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north')
- if (status .ne. NF_NOERR) call handle_err(status)
- ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations')
- ! if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east')
- if (status .ne. NF_NOERR) call handle_err(status)
- ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations')
- ! if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data')
- if (status .ne. NF_NOERR) call handle_err(status)
- call DATE_AND_TIME(DATE=datestring)
- status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring )
- if (status .ne. NF_NOERR) call handle_err(status)
-
- !
- ! End define mode for output file
- !
- status = nf_enddef (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
- !
- ! Write variable for output
- !
- print*,"writing terrain data",MINVAL(terr),MAXVAL(terr)
- if (lprepare_fv_smoothing_routine) then
- status = nf_put_var_double (foutid, terrid, terr)
- else
- status = nf_put_var_double (foutid, terrid, terr*9.80616)
- end if
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing terrain data"
-
- print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac)
- status = nf_put_var_double (foutid, landfracid, landfrac)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing landfrac data"
-
- print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh)
- status = nf_put_var_double (foutid, sghid, sgh)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh data"
-
- print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30)
- status = nf_put_var_double (foutid, sgh30id, sgh30)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh30 data"
-
- print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat)
- status = nf_put_var_double (foutid, landm_coslatid, landm_coslat)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing sgh30 data"
- !
- print*,"writing lat data"
- status = nf_put_var_double (foutid, latvid, latar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lat data"
-
- print*,"writing lon data"
- status = nf_put_var_double (foutid, lonvid, lonar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lon data"
- !
- ! Close output file
- !
- print *,"close file"
- status = nf_close (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-end subroutine wrtncdf_rll
-!************************************************************************
-!!handle_err
-!************************************************************************
-!
-!!ROUTINE: handle_err
-!!DESCRIPTION: error handler
-!--------------------------------------------------------------------------
-
-subroutine handle_err(status)
-
- implicit none
-
-# include
-
- integer status
-
- if (status .ne. nf_noerr) then
- print *, nf_strerror(status)
- stop 'Stopped'
- endif
-
-end subroutine handle_err
-
-
-SUBROUTINE coarsen(f,fcoarse,nf,n,dA_coarse)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
- REAL (R8), DIMENSION(n) , INTENT(IN) :: f
- REAL (R8), DIMENSION(n/nf), INTENT(OUT) :: fcoarse
- INTEGER, INTENT(in) :: n,nf
- REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf),INTENT(OUT) :: dA_coarse
- !must be an even number
- !
- ! local workspace
- !
- ! ncube = INT(SQRT(DBLE(n/6)))
-
- REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6))),INT(SQRT(DBLE(n/6)))):: dA
- REAL (R8) :: sum, sum_area,tmp
- INTEGER :: jx,jy,jp,ii,ii_coarse,coarse_ncube,ncube
- INTEGER :: jx_coarse,jy_coarse,jx_s,jy_s
-
-
- ! REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf) :: dAtmp
-
- ncube = INT(SQRT(DBLE(n/6)))
- coarse_ncube = ncube/nf
-
- IF (ABS(DBLE(ncube)/DBLE(nf)-coarse_ncube)>0.000001) THEN
- WRITE(*,*) "ncube/nf must be an integer"
- WRITE(*,*) "ncube and nf: ",ncube,nf
- STOP
- END IF
-
- da_coarse = 0.0
-
- WRITE(*,*) "compute all areas"
- CALL EquiangularAllAreas(ncube, dA)
- ! CALL EquiangularAllAreas(coarse_ncube, dAtmp)!dbg
- tmp = 0.0
- DO jp=1,6
- DO jy_coarse=1,coarse_ncube
- DO jx_coarse=1,coarse_ncube
- !
- ! inner loop
- !
- sum = 0.0
- sum_area = 0.0
- DO jy_s=1,nf
- jy = (jy_coarse-1)*nf+jy_s
- DO jx_s=1,nf
- jx = (jx_coarse-1)*nf+jx_s
- ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx
- sum = sum +f(ii)*dA(jx,jy)
- sum_area = sum_area+dA(jx,jy)
- ! WRITE(*,*) "jx,jy",jx,jy
- END DO
- END DO
- tmp = tmp+sum_area
- da_coarse(jx_coarse,jy_coarse) = sum_area
- ! WRITE(*,*) "jx_coarse,jy_coarse",jx_coarse,jy_coarse,&
- ! da_coarse(jx_coarse,jy_coarse)-datmp(jx_coarse,jy_coarse)
- ii_coarse = (jp-1)*coarse_ncube*coarse_ncube+(jy_coarse-1)*coarse_ncube+jx_coarse
- fcoarse(ii_coarse) = sum/sum_area
- END DO
- END DO
- END DO
- WRITE(*,*) "coarsened surface area",tmp-4.0*3.141592654
-END SUBROUTINE COARSEN
-
-SUBROUTINE overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,&
- jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction)
- use shr_kind_mod, only: r8 => shr_kind_r8
- use remap
- IMPLICIT NONE
-
-
- INTEGER, INTENT(INOUT) :: jall !anticipated number of weights
- INTEGER, INTENT(IN) :: ncube, ngauss, ntarget, jmax_segments, ncorner, nreconstruction
-
- INTEGER, DIMENSION(jall,3), INTENT(OUT) :: weights_eul_index_all
- REAL(R8), DIMENSION(jall,nreconstruction) , INTENT(OUT) :: weights_all
- INTEGER, DIMENSION(jall) , INTENT(OUT) :: weights_lgr_index_all
-
- REAL(R8), DIMENSION(ncorner,ntarget), INTENT(IN) :: target_corner_lon, target_corner_lat
-
- INTEGER, DIMENSION(ncorner+1) :: ipanel_array, ipanel_tmp
- REAL(R8), DIMENSION(ncorner) :: lat, lon
- REAL(R8), DIMENSION(0:ncube+2):: xgno, ygno
- REAL(R8), DIMENSION(0:ncorner+1) :: xcell, ycell
-
- REAL(R8), DIMENSION(ngauss) :: gauss_weights, abscissae
-
- REAL(R8) :: da, tmp, alpha, beta
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: pih = 0.50*pi
- INTEGER :: i, j,ncorner_this_cell,k,ip,ipanel,ii,jx,jy,jcollect
- integer :: alloc_error
-
- REAL (r8), PARAMETER :: rad2deg = 180.0/pi
-
- real(r8), allocatable, dimension(:,:) :: weights
- integer , allocatable, dimension(:,:) :: weights_eul_index
-
-
- LOGICAL:: ldbg = .FAlSE.
-
- INTEGER :: jall_anticipated
-
- jall_anticipated = jall
-
- ipanel_array = -99
- !
- da = pih/DBLE(ncube)
- xgno(0) = -bignum
- DO i=1,ncube+1
- xgno(i) = TAN(-piq+(i-1)*da)
- END DO
- xgno(ncube+2) = bignum
- ygno = xgno
-
- CALL glwp(ngauss,gauss_weights,abscissae)
-
-
- allocate (weights(jmax_segments,nreconstruction),stat=alloc_error )
- allocate (weights_eul_index(jmax_segments,2),stat=alloc_error )
-
- tmp = 0.0
- jall = 1
- DO i=1,ntarget
- WRITE(*,*) "cell",i," ",100.0*DBLE(i)/DBLE(ntarget),"% done"
- !
- !---------------------------------------------------
- !
- ! determine how many vertices the cell has
- !
- !---------------------------------------------------
- !
- CALL remove_duplicates_latlon(ncorner,target_corner_lon(:,i),target_corner_lat(:,i),&
- ncorner_this_cell,lon,lat,1.0E-10,ldbg)
-
- IF (ldbg) THEN
- WRITE(*,*) "number of vertices ",ncorner_this_cell
- WRITE(*,*) "vertices locations lon,",lon(1:ncorner_this_cell)*rad2deg
- WRITE(*,*) "vertices locations lat,",lat(1:ncorner_this_cell)*rad2deg
- DO j=1,ncorner_this_cell
- WRITE(*,*) lon(j)*rad2deg, lat(j)*rad2deg
- END DO
- WRITE(*,*) " "
- END IF
- !
- !---------------------------------------------------
- !
- ! determine how many and which panels the cell spans
- !
- !---------------------------------------------------
- !
- DO j=1,ncorner_this_cell
- CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ipanel_tmp(j), .TRUE.)
- IF (ldbg) WRITE(*,*) "ipanel for corner ",j," is ",ipanel_tmp(j)
- END DO
- ipanel_tmp(ncorner_this_cell+1) = ipanel_tmp(1)
- ! make sure to include possible overlap areas not on the face the vertices are located
- IF (MINVAL(lat(1:ncorner_this_cell))<-pi/6.0) THEN
- ! include South-pole panel in search
- ipanel_tmp(ncorner_this_cell+1) = 5
- IF (ldbg) WRITE(*,*) "add panel 5 to search"
- END IF
- IF (MAXVAL(lat(1:ncorner_this_cell))>pi/6.0) THEN
- ! include North-pole panel in search
- ipanel_tmp(ncorner_this_cell+1) = 6
- IF (ldbg) WRITE(*,*) "add panel 6 to search"
- END IF
- !
- ! remove duplicates in ipanel_tmp
- !
- CALL remove_duplicates_integer(ncorner_this_cell+1,ipanel_tmp(1:ncorner_this_cell+1),&
- k,ipanel_array(1:ncorner_this_cell+1))
- !
- !---------------------------------------------------
- !
- ! loop over panels with possible overlap areas
- !
- !---------------------------------------------------
- !
- DO ip = 1,k
- ipanel = ipanel_array(ip)
- DO j=1,ncorner_this_cell
- ii = ipanel
- CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ii,.FALSE.)
- IF (j==1) THEN
- jx = CEILING((alpha + piq) / da)
- jy = CEILING((beta + piq) / da)
- END IF
- xcell(ncorner_this_cell+1-j) = TAN(alpha)
- ycell(ncorner_this_cell+1-j) = TAN(beta)
- END DO
- xcell(0) = xcell(ncorner_this_cell)
- ycell(0) = ycell(ncorner_this_cell)
- xcell(ncorner_this_cell+1) = xcell(1)
- ycell(ncorner_this_cell+1) = ycell(1)
-
- jx = MAX(MIN(jx,ncube+1),0)
- jy = MAX(MIN(jy,ncube+1),0)
-
- CALL compute_weights_cell(xcell(0:ncorner_this_cell+1),ycell(0:ncorner_this_cell+1),&
- jx,jy,nreconstruction,xgno,ygno,&
- 1, ncube+1, 1,ncube+1, tmp,&
- ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,&
- ncube,0,ncorner_this_cell,ldbg)
-
- weights_all(jall:jall+jcollect-1,1:nreconstruction) = weights(1:jcollect,1:nreconstruction)
-
- weights_eul_index_all(jall:jall+jcollect-1,1:2) = weights_eul_index(1:jcollect,:)
- weights_eul_index_all(jall:jall+jcollect-1, 3) = ipanel
- weights_lgr_index_all(jall:jall+jcollect-1 ) = i
-
- jall = jall+jcollect
- IF (jall>jall_anticipated) THEN
- WRITE(*,*) "more weights than anticipated"
- WRITE(*,*) "increase jall"
- STOP
- END IF
- IF (ldbg) WRITE(*,*) "jcollect",jcollect
- END DO
- END DO
- jall = jall-1
- WRITE(*,*) "sum of all weights divided by surface area of sphere =",tmp/(4.0*pi)
- WRITE(*,*) "actual number of weights",jall
- WRITE(*,*) "anticipated number of weights",jall_anticipated
- IF (jall>jall_anticipated) THEN
- WRITE(*,*) "anticipated number of weights < actual number of weights"
- WRITE(*,*) "increase jall!"
- STOP
- END IF
- WRITE(*,*) MINVAL(weights_all(1:jall,1)),MAXVAL(weights_all(1:jall,1))
- IF (ABS(tmp/(4.0*pi))-1.0>0.001) THEN
- WRITE(*,*) "sum of all weights does not match the surface area of the sphere"
- WRITE(*,*) "sum of all weights is : ",tmp
- WRITE(*,*) "surface area of sphere: ",4.0*pi
- STOP
- END IF
-END SUBROUTINE overlap_weights
-
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereABPFromRLL
-!
-! Description:
-! Determine the (alpha,beta,panel) coordinate of a point on the sphere from
-! a given regular lat lon coordinate.
-!
-! Parameters:
-! lon - Coordinate longitude
-! lat - Coordinate latitude
-! alpha (OUT) - Alpha coordinate
-! beta (OUT) - Beta coordinate
-! ipanel (OUT) - Face panel
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- REAL (R8), INTENT(IN) :: lon, lat
- REAL (R8), INTENT(OUT) :: alpha, beta
- INTEGER :: ipanel
- LOGICAL, INTENT(IN) :: ldetermine_panel
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
- REAL (r8), PARAMETER :: rotate_cube = 0.0
-
- ! Local variables
- REAL (R8) :: xx, yy, zz, pm
- REAL (R8) :: sx, sy, sz
- INTEGER :: ix, iy, iz
-
- ! Translate to (x,y,z) space
- xx = COS(lon-rotate_cube) * COS(lat)
- yy = SIN(lon-rotate_cube) * COS(lat)
- zz = SIN(lat)
-
- pm = MAX(ABS(xx), ABS(yy), ABS(zz))
-
- ! Check maximality of the x coordinate
- IF (pm == ABS(xx)) THEN
- IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF
- ELSE
- ix = 0
- ENDIF
-
- ! Check maximality of the y coordinate
- IF (pm == ABS(yy)) THEN
- IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF
- ELSE
- iy = 0
- ENDIF
-
- ! Check maximality of the z coordinate
- IF (pm == ABS(zz)) THEN
- IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF
- ELSE
- iz = 0
- ENDIF
-
- ! Panel assignments
- IF (ldetermine_panel) THEN
- IF (iz == 1) THEN
- ipanel = 6; sx = yy; sy = -xx; sz = zz
-
- ELSEIF (iz == -1) THEN
- ipanel = 5; sx = yy; sy = xx; sz = -zz
-
- ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN
- ipanel = 1; sx = yy; sy = zz; sz = xx
-
- ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN
- ipanel = 3; sx = -yy; sy = zz; sz = -xx
-
- ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN
- ipanel = 2; sx = -xx; sy = zz; sz = yy
-
- ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN
- ipanel = 4; sx = xx; sy = zz; sz = -yy
-
- ELSE
- WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed'
- WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')'
- WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')'
- STOP
- ENDIF
- ELSE
- IF (ipanel == 6) THEN
- sx = yy; sy = -xx; sz = zz
- ELSEIF (ipanel == 5) THEN
- sx = yy; sy = xx; sz = -zz
- ELSEIF (ipanel == 1) THEN
- sx = yy; sy = zz; sz = xx
- ELSEIF (ipanel == 3) THEN
- sx = -yy; sy = zz; sz = -xx
- ELSEIF (ipanel == 2) THEN
- sx = -xx; sy = zz; sz = yy
- ELSEIF (ipanel == 4) THEN
- sx = xx; sy = zz; sz = -yy
- ELSE
- WRITE(*,*) "ipanel out of range",ipanel
- STOP
- END IF
- END IF
-
- ! Use panel information to calculate (alpha, beta) coords
- alpha = ATAN(sx / sz)
- beta = ATAN(sy / sz)
-
-END SUBROUTINE CubedSphereABPFromRLL
-
-!------------------------------------------------------------------------------
-! SUBROUTINE EquiangularAllAreas
-!
-! Description:
-! Compute the area of all cubed sphere grid cells, storing the results in
-! a two dimensional array.
-!
-! Parameters:
-! icube - Resolution of the cubed sphere
-! dA (OUT) - Output array containing the area of all cubed sphere grid cells
-!------------------------------------------------------------------------------
-SUBROUTINE EquiangularAllAreas(icube, dA)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- INTEGER, INTENT(IN) :: icube
- REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA
-
- ! Local variables
- INTEGER :: k, k1, k2
- REAL (r8) :: a1, a2, a3, a4
- REAL (r8), DIMENSION(icube+1,icube+1) :: ang
- REAL (r8), DIMENSION(icube+1) :: gp
-
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
-
-
- !#ifdef DBG
- REAL (r8) :: dbg1 !DBG
- !#endif
-
- ! Recall that we are using equi-angular spherical gridding
- ! Compute the angle between equiangular cubed sphere projection grid lines.
- DO k = 1, icube+1
- gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1)
- ENDDO
-
- DO k2=1,icube+1
- DO k1=1,icube+1
- ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2)))
- ENDDO
- ENDDO
-
- DO k2=1,icube
- DO k1=1,icube
- a1 = ang(k1 , k2 )
- a2 = pi - ang(k1+1, k2 )
- a3 = pi - ang(k1 , k2+1)
- a4 = ang(k1+1, k2+1)
- ! area = r*r*(-2*pi+sum(interior angles))
- DA(k1,k2) = -2.0*pi+a1+a2+a3+a4
- ENDDO
- ENDDO
-
- !#ifdef DBG
- ! Only for debugging - test consistency
- dbg1 = 0.0 !DBG
- DO k2=1,icube
- DO k1=1,icube
- dbg1 = dbg1 + DA(k1,k2) !DBG
- ENDDO
- ENDDO
- write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG
- !#endif
-END SUBROUTINE EquiangularAllAreas
-
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereRLLFromABP
-!
-! Description:
-! Determine the lat lon coordinate of a point on a sphere given its
-! (alpha,beta,panel) coordinate.
-!
-! Parameters:
-! alpha - Alpha coordinate
-! beta - Beta coordinate
-! panel - Cubed sphere panel id
-! lon (OUT) - Calculated longitude
-! lat (OUT) - Calculated latitude
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
- REAL (r8), INTENT(IN) :: alpha, beta
- INTEGER , INTENT(IN) :: ipanel
- REAL (r8), INTENT(OUT) :: lon, lat
- ! Local variables
- REAL (r8) :: xx, yy, zz, rotate_cube
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: piq = 0.25*pi
-
- rotate_cube = 0.0
- ! Convert to cartesian coordinates
- CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz)
- ! Convert back to lat lon
- lat = ASIN(zz)
- if (xx==0.0.and.yy==0.0) THEN
- lon = 0.0
- else
- lon = ATAN2(yy, xx) +rotate_cube
- IF (lon<0.0) lon=lon+2.0*pi
- IF (lon>2.0*pi) lon=lon-2.0*pi
- end if
-END SUBROUTINE CubedSphereRLLFromABP
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereXYZFromABP
-!
-! Description:
-! Determine the Cartesian coordinate of a point on a sphere given its
-! (alpha,beta,panel) coordinate.
-!
-! Parameters:
-! alpha - Alpha coordinate
-! beta - Beta coordinate
-! panel - Cubed sphere panel id
-! xx (OUT) - Calculated x coordinate
-! yy (OUT) - Calculated y coordinate
-! zz (OUT) - Calculated z coordinate
-!------------------------------------------------------------------------------
-SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz)
- use shr_kind_mod, only: r8 => shr_kind_r8
- IMPLICIT NONE
-
- REAL (r8), INTENT(IN) :: alpha, beta
- INTEGER , INTENT(IN) :: ipanel
- REAL (r8), INTENT(OUT) :: xx, yy, zz
- ! Local variables
- REAL (r8) :: a1, b1, pm
- REAL (r8) :: sx, sy, sz
-
- ! Convert to Cartesian coordinates
- a1 = TAN(alpha)
- b1 = TAN(beta)
-
- sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5)
- sx = sz * a1
- sy = sz * b1
- ! Panel assignments
- IF (ipanel == 6) THEN
- yy = sx; xx = -sy; zz = sz
- ELSEIF (ipanel == 5) THEN
- yy = sx; xx = sy; zz = -sz
- ELSEIF (ipanel == 1) THEN
- yy = sx; zz = sy; xx = sz
- ELSEIF (ipanel == 3) THEN
- yy = -sx; zz = sy; xx = -sz
- ELSEIF (ipanel == 2) THEN
- xx = -sx; zz = sy; yy = sz
- ELSEIF (ipanel == 4) THEN
- xx = sx; zz = sy; yy = -sz
- ELSE
- WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP'
- WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')'
- STOP
- ENDIF
-END SUBROUTINE CubedSphereXYZFromABP
-
-
-SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out)
- use shr_kind_mod, only: r8 => shr_kind_r8
- integer, intent(in) :: n_in
- integer,dimension(n_in), intent(in) :: f_in
- integer, intent(out) :: n_out
- integer,dimension(n_in), intent(out) :: f_out
- !
- ! local work space
- !
- integer :: k,i,j
- !
- ! remove duplicates in ipanel_tmp
- !
- k = 1
- f_out(1) = f_in(1)
- outer: do i=2,n_in
- do j=1,k
- ! if (f_out(j) == f_in(i)) then
- if (ABS(f_out(j)-f_in(i))<1.0E-10) then
- ! Found a match so start looking again
- cycle outer
- end if
- end do
- ! No match found so add it to the output
- k = k + 1
- f_out(k) = f_in(i)
- end do outer
- n_out = k
-END SUBROUTINE remove_duplicates_integer
-
-SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg)
- use shr_kind_mod, only: r8 => shr_kind_r8
- integer, intent(in) :: n_in
- real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in
- real, intent(in) :: tiny
- integer, intent(out) :: n_out
- real(r8),dimension(n_in), intent(out) :: lon_out,lat_out
- logical :: ldbg
- !
- ! local work space
- !
- integer :: k,i,j
- REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327
- REAL (r8), PARAMETER :: pih = 0.50*pi
- !
- ! for pole points: make sure the longitudes are identical so that algorithm below works properly
- !
- do i=2,n_in
- if (abs(lat_in(i)-pih) 0) .AND. (j < ncube_reconstruct)) THEN
- beta = gp(j)
- beta_next = gp(j+1)
- ELSEIF (j == -1) THEN
- beta = -piq - (gp(3) + piq)
- beta_next = -piq - (gp(2) + piq)
- ELSEIF (j == 0) THEN
- beta = -piq - (gp(2) + piq)
- beta_next = -piq
- ELSEIF (j == ncube_reconstruct) THEN
- beta = piq
- beta_next = piq + (piq - gp(ncube_reconstruct-1))
- ELSEIF (j == ncube_reconstruct+1) THEN
- beta = piq + (piq - gp(ncube_reconstruct-1))
- beta_next = piq + (piq - gp(ncube_reconstruct-2))
- ENDIF
-
- DO i = -1, ncube_reconstruct+1
- IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN
- alpha = gp(i)
- alpha_next = gp(i+1)
- ELSEIF (i == -1) THEN
- alpha = -piq - (gp(3) + piq)
- alpha_next = -piq - (gp(2) + piq)
- ELSEIF (i == 0) THEN
- alpha = -piq - (gp(2) + piq)
- alpha_next = -piq
- ELSEIF (i == ncube_reconstruct) THEN
- alpha = piq
- alpha_next = piq + (piq - gp(ncube_reconstruct-1))
- ELSEIF (i == ncube_reconstruct+1) THEN
- alpha = piq + (piq - gp(ncube_reconstruct-1))
- alpha_next = piq + (piq - gp(ncube_reconstruct-2))
- ENDIF
- abp_centroid(1,i,j) = &
- I_10_ab(alpha_next,beta_next)-I_10_ab(alpha ,beta_next)+&
- I_10_ab(alpha ,beta )-I_10_ab(alpha_next,beta )
-! - ASINH(COS(alpha_next) * TAN(beta_next)) &
-! + ASINH(COS(alpha_next) * TAN(beta)) &
-! + ASINH(COS(alpha) * TAN(beta_next)) &
-! - ASINH(COS(alpha) * TAN(beta))
-
- abp_centroid(2,i,j) = &
- I_01_ab(alpha_next,beta_next)-I_01_ab(alpha ,beta_next)+&
- I_01_ab(alpha ,beta )-I_01_ab(alpha_next,beta )
-! - ASINH(TAN(alpha_next) * COS(beta_next)) &
-! + ASINH(TAN(alpha_next) * COS(beta)) &
-! + ASINH(TAN(alpha) * COS(beta_next)) &
-! - ASINH(TAN(alpha) * COS(beta))
-
- !ADD PHL START
- IF (order>2) THEN
- ! TAN(alpha)^2 component
- abp_centroid(3,i,j) =&
- I_20_ab(alpha_next,beta_next)-I_20_ab(alpha ,beta_next)+&
- I_20_ab(alpha ,beta )-I_20_ab(alpha_next,beta )
-
- ! TAN(beta)^2 component
- abp_centroid(4,i,j) = &
- I_02_ab(alpha_next,beta_next)-I_02_ab(alpha ,beta_next)+&
- I_02_ab(alpha ,beta )-I_02_ab(alpha_next,beta )
-
- ! TAN(alpha) TAN(beta) component
- abp_centroid(5,i,j) = &
- I_11_ab(alpha_next,beta_next)-I_11_ab(alpha ,beta_next)+&
- I_11_ab(alpha ,beta )-I_11_ab(alpha_next,beta )
- ENDIF
- !ADD PHL END
- ENDDO
- ENDDO
-
-!
-! PHL outcommented below
-!
- ! High order calculations
-! IF (order > 2) THEN
-! DO k = 1, nlon
-! DO i = 1, int_nx(nlat,k)-1
-! IF ((int_itype(i,k) > 4) .AND. (int_np(1,i,k) == 1)) THEN
-! abp_centroid(3, int_a(i,k), int_b(i,k)) = &
-! abp_centroid(3, int_a(i,k), int_b(i,k)) + int_wt_2a(i,k)
-! abp_centroid(4, int_a(i,k), int_b(i,k)) = &
-! abp_centroid(4, int_a(i,k), int_b(i,k)) + int_wt_2b(i,k)
-! abp_centroid(5, int_a(i,k), int_b(i,k)) = &
-! abp_centroid(5, int_a(i,k), int_b(i,k)) + int_wt_2c(i,k)
-! ENDIF
-! ENDDO
-! ENDDO
-! ENDIF
-
- ! Normalize with element areas
- DO j = -1, ncube_reconstruct+1
- IF ((j > 0) .AND. (j < ncube_reconstruct)) THEN
- beta = gp(j)
- beta_next = gp(j+1)
- ELSEIF (j == -1) THEN
- beta = -piq - (gp(3) + piq)
- beta_next = -piq - (gp(2) + piq)
- ELSEIF (j == 0) THEN
- beta = -piq - (gp(2) + piq)
- beta_next = -piq
- ELSEIF (j == ncube_reconstruct) THEN
- beta = piq
- beta_next = piq + (piq - gp(ncube_reconstruct-1))
- ELSEIF (j == ncube_reconstruct+1) THEN
- beta = piq + (piq - gp(ncube_reconstruct-1))
- beta_next = piq + (piq - gp(ncube_reconstruct-2))
- ENDIF
- DO i = -1, ncube_reconstruct+1
- IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN
- alpha = gp(i)
- alpha_next = gp(i+1)
- ELSEIF (i == -1) THEN
- alpha = -piq - (gp(3) + piq)
- alpha_next = -piq - (gp(2) + piq)
- ELSEIF (i == 0) THEN
- alpha = -piq - (gp(2) + piq)
- alpha_next = -piq
- ELSEIF (i == ncube_reconstruct) THEN
- alpha = piq
- alpha_next = piq + (piq - gp(ncube_reconstruct-1))
- ELSEIF (i == ncube_reconstruct+1) THEN
- alpha = piq + (piq - gp(ncube_reconstruct-1))
- alpha_next = piq + (piq - gp(ncube_reconstruct-2))
- ENDIF
-
- IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN
- area = DAcube(i,j)
- ELSE
- area = EquiangularElementArea(alpha, alpha_next - alpha, &
- beta, beta_next - beta)
- ENDIF
-
- abp_centroid(1,i,j) = abp_centroid(1,i,j) / area
- abp_centroid(2,i,j) = abp_centroid(2,i,j) / area
-
- IF (order > 2) THEN
- IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN
- abp_centroid(3,i,j) = abp_centroid(3,i,j) / area
- abp_centroid(4,i,j) = abp_centroid(4,i,j) / area
- abp_centroid(5,i,j) = abp_centroid(5,i,j) / area
- ENDIF
- ENDIF
- ENDDO
- ENDDO
-
- WRITE(*,*) '...Done computing ABP element centroids'
-
- END SUBROUTINE ComputeABPElementCentroids
-
-!------------------------------------------------------------------------------
-! FUNCTION EvaluateABPReconstruction
-!
-! Description:
-! Evaluate the sub-grid scale reconstruction at the given point.
-!
-! Parameters:
-! fcubehalo - Array of element values
-! recons - Array of reconstruction coefficients
-! a - Index of element in alpha direction (1 <= a <= ncube_reconstruct-1)
-! b - Index of element in beta direction (1 <= b <= ncube_reconstruct-1)
-! p - Panel index of element
-! alpha - Alpha coordinate of evaluation point
-! beta - Beta coordinate of evaluation point
-! order - Order of the reconstruction
-! value (OUT) - Result of function evaluation at given point
-!------------------------------------------------------------------------------
- SUBROUTINE EvaluateABPReconstruction( &
- fcubehalo, recons, a, b, p, alpha, beta, order, value)
- IMPLICIT NONE
-
- ! Dummy variables
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(IN) :: recons
- INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha, beta
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- REAL (KIND=dbl_kind), INTENT(OUT) :: value
-
- ! Evaluate constant order terms
- value = fcubehalo(a,b,p)
-
- ! Evaluate linear order terms
- IF (order > 1) THEN
- value = value + recons(1,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b))
- value = value + recons(2,a,b,p) * (TAN(beta) - abp_centroid(2,a,b))
- ENDIF
-
- ! Evaluate second order terms
- IF (order > 2) THEN
- value = value + recons(3,a,b,p) * &
- (abp_centroid(1,a,b)**2 - abp_centroid(3,a,b))
- value = value + recons(4,a,b,p) * &
- (abp_centroid(2,a,b)**2 - abp_centroid(4,a,b))
- value = value + recons(5,a,b,p) * &
- (abp_centroid(1,a,b) * abp_centroid(2,a,b) - &
- abp_centroid(5,a,b))
-
- value = value + recons(3,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b))**2
- value = value + recons(4,a,b,p) * (TAN(beta) - abp_centroid(2,a,b))**2
- value = value + recons(5,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) &
- * (TAN(beta) - abp_centroid(2,a,b))
- ENDIF
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ABPHaloMinMax
-!
-! Description:
-! Calculate the minimum and maximum values of the cell-averaged function
-! around the given element.
-!
-! Parameters:
-! fcubehalo - Cell-averages for the cubed sphere
-! a - Local element alpha index
-! b - Local element beta index
-! p - Local element panel index
-! min_val (OUT) - Minimum value in the halo
-! max_val (OUT) - Maximum value in the halo
-! nomiddle - whether to not include the middle cell (index a,b) in the search.
-!
-! NOTE: Since this routine is not vectorized, it will likely be called MANY times.
-! To speed things up, make sure to pass the first argument as the ENTIRE original
-! array, not as a subset of it, since repeatedly cutting up that array and creating
-! an array temporary (on some compilers) is VERY slow.
-! ex:
-! CALL APBHaloMinMax(zarg, a, ...) !YES
-! CALL ABPHaloMinMax(zarg(-1:ncube_reconstruct+1,-1:ncube_reconstruct+1,:)) !NO -- slow
-!------------------------------------------------------------------------------
- SUBROUTINE ABPHaloMinMax(fcubehalo, a, b, p, min_val, max_val, nomiddle)
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p
- REAL (KIND=dbl_kind), INTENT(OUT) :: min_val, max_val
- LOGICAL, INTENT(IN) :: nomiddle
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, il, jl, inew, jnew
- REAL (KIND=dbl_kind) :: value
-
- min_val = fcubehalo(a,b,p)
- max_val = fcubehalo(a,b,p)
- value = fcubehalo(a,b,p)
-
- DO il = a-1,a+1
- DO jl = b-1,b+1
-
- i = il
- j = jl
-
- inew = i
- jnew = j
-
- IF (nomiddle .AND. i==a .AND. j==b) CYCLE
-
- !Interior
- IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN
- value = fcubehalo(i,j,p)
-
- ELSE
-
-
- !The next 4.0 regions are cases in which a,b themselves lie in the panel's halo, and the cell's "halo" (in this usage the 8.0 cells surrounding it) might wrap around into another part of the halo. This happens for (a,b) = {(1,:0),(ncube_reconstruct-1,:0),(1,ncube_reconstruct:),(ncube_reconstruct-1,ncube_reconstruct:)} and for the transposes thereof ({(:0,1), etc.}). In these cases (i,j) could lie in the "Corners" where nothing should lie. We correct this by moving i,j to its appropriate position on the "facing" halo, and then the remainder of the routine then moves it onto the correct face.
-
-101 FORMAT("ERROR cannot find (i,j) = (", I4, ", ", I4, ") for (a,b,p) = ", I4, ",", I4, ",", I4, ")")
-102 FORMAT("i,j,p = ", 3I4, " moved to " 2I4, " (CASE ", I1, ")")
- !NOTE: we need the general case to be able to properly handle (0,0), (ncube_reconstruct,0), etc. Note that we don't need to bother with (0,0), etc. when a, b lie in the interior, since both sides of the (0,0) cell are already accounted for by this routine.
- !LOWER LEFT
- IF (i < 1 .AND. j < 1) THEN
- IF (a < 1) THEN !(a,b) centered on left halo, cross to lower halo
- inew = 1-j
- jnew = i
- ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to left halo
- jnew = 1-i
- inew = j
- END IF
-! WRITE(*,102) i, j, p, inew, jnew, 1
- !LOWER RIGHT
- ELSE IF (i > ncube_reconstruct-1 .AND. j < 1) THEN
- IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to lower halo
- inew = ncube_reconstruct-1+j
- jnew = ncube_reconstruct-i
- ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to right halo
- jnew = 1+(i-ncube_reconstruct)
- inew = ncube_reconstruct-j
- END IF
-! WRITE(*,102) i, j, p, inew, jnew, 2
- !UPPER LEFT
- ELSE IF (i < 1 .AND. j > ncube_reconstruct-1) THEN
- IF (a < 1) THEN! (a,b) centered on left halo, cross to upper halo
- inew = 1-(j-ncube_reconstruct)
- jnew = ncube_reconstruct-i
- ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to left halo
- inew = ncube_reconstruct-j
- jnew = ncube_reconstruct-1-i
- END IF
-! WRITE(*,102) i, j, p, inew, jnew, 3
- !UPPER RIGHT
- ELSE IF (i > ncube_reconstruct-1 .AND. j > ncube_reconstruct-1) THEN
- IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to upper halo
- inew = ncube_reconstruct-1-(ncube_reconstruct-j)
- jnew = i
- ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to right halo
- inew = j
- jnew = ncube_reconstruct-1-(ncube_reconstruct-i)
- END IF
-! WRITE(*,102) i, j, p, inew, jnew, 4
- END IF
-
- i = inew
- j = jnew
-
-
- !Lower halo ("halo" meaning the panel's halo, not the nine-cell halo
- IF ((i < 1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN
- IF (p == 1) THEN
- value = fcubehalo(ncube_reconstruct-1+i,j,4)
- ELSEIF (p == 2) THEN
- value = fcubehalo(ncube_reconstruct-1+i,j,1)
- ELSEIF (p == 3) THEN
- value = fcubehalo(ncube_reconstruct-1+i,j,2)
- ELSEIF (p == 4) THEN
- value = fcubehalo(ncube_reconstruct-1+i,j,3)
- ELSEIF (p == 5) THEN
- value = fcubehalo(j,1-i,4)
- ELSEIF (p == 6) THEN
- value = fcubehalo(ncube_reconstruct-j,ncube_reconstruct-1+i,4)
- ENDIF
-
- !Upper halo
- ELSEIF ((i > ncube_reconstruct-1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN
- IF (p == 1) THEN
- value = fcubehalo(i-ncube_reconstruct+1,j,2)
- ELSEIF (p == 2) THEN
- value = fcubehalo(i-ncube_reconstruct+1,j,3)
- ELSEIF (p == 3) THEN
- value = fcubehalo(i-ncube_reconstruct+1,j,4)
- ELSEIF (p == 4) THEN
- value = fcubehalo(i-ncube_reconstruct+1,j,1)
- ELSEIF (p == 5) THEN
- value = fcubehalo(ncube_reconstruct-j,i-ncube_reconstruct+1,2)
- ELSEIF (p == 6) THEN
- value = fcubehalo(j,2*ncube_reconstruct-i-1,2)
- ENDIF
-
- !Left halo
- ELSEIF ((j < 1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN
- IF (p == 1) THEN
- value = fcubehalo(i,ncube_reconstruct-1+j,5)
- ELSEIF (p == 2) THEN
- value = fcubehalo(ncube_reconstruct-1+j,ncube_reconstruct-i,5)
- ELSEIF (p == 3) THEN
- value = fcubehalo(ncube_reconstruct-i,1-j,5)
- ELSEIF (p == 4) THEN
- value = fcubehalo(1-j,i,5)
- ELSEIF (p == 5) THEN
- value = fcubehalo(ncube_reconstruct-i,1-j,3)
- ELSEIF (p == 6) THEN
- value = fcubehalo(i,ncube_reconstruct-1+j,1)
- ENDIF
-
- !Right halo
- ELSEIF ((j > ncube_reconstruct-1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN
- IF (p == 1) THEN
- value = fcubehalo(i,j-ncube_reconstruct+1,6)
- ELSEIF (p == 2) THEN
- value = fcubehalo(2*ncube_reconstruct-j-1,i,6)
- ELSEIF (p == 3) THEN
- value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,6)
- ELSEIF (p == 4) THEN
- value = fcubehalo(j-ncube_reconstruct+1,ncube_reconstruct-i,6)
- ELSEIF (p == 5) THEN
- value = fcubehalo(i,j-ncube_reconstruct+1,1)
- ELSEIF (p == 6) THEN
- value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,3)
- ENDIF
-
- ENDIF
-
- END IF
- min_val = MIN(min_val, value)
- max_val = MAX(max_val, value)
- ENDDO
- ENDDO
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE MonotonizeABPGradient
-!
-! Description:
-! Apply a monotonic filter to the calculated ABP gradient.
-!
-! Parameters:
-! fcubehalo - Scalar field on the cubed sphere to use in reconstruction
-! order - Order of the reconstruction
-! recons (INOUT) - Array of reconstructed coefficients
-! selective - whether to apply a simple form of selective limiting,
- !which assumes that if a point is larger/smaller than ALL of its
- !surrounding points, that the extremum is physical, and that
- !filtering should not be applied to it.
-!
-! Remarks:
-! This monotonizing scheme is based on the monotone scheme for unstructured
-! grids of Barth and Jespersen (1989).
-!------------------------------------------------------------------------------
- SUBROUTINE MonotonizeABPGradient(fcubehalo, order, recons, selective)
-
-! USE selective_limiting
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- LOGICAL, INTENT(IN) :: selective
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, k, m, n, skip
-
- REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi
- REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: &
- gamma
-
- ! The first-order piecewise constant scheme is monotone by construction
- IF (order == 1) THEN
- RETURN
- ENDIF
-
-!
-! xxxxx
-!
-! IF (selective) THEN
-! CALL smoothness2D(fcubehalo, gamma, 2)
-! WRITE(*,*) 'gamma range: max ', MAXVAL(gamma), " min ", MINVAL(gamma)
-! DO i=1,ncube_reconstruct-1
-! WRITE(*,*) gamma(i, i, 3)
-! ENDDO
-! skip = 0
-! END IF
-
-
- ! Apply monotone limiting
- DO k = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
-
-
- IF (selective) THEN
-
- CALL ABPHaloMinMax(gamma, i, j, k, gamma_min, gamma_max, .FALSE.)
-
- IF (gamma_max/(gamma_min + tiny) < lammax) THEN
- skip = skip + 1
- CYCLE
- END IF
-
- END IF
-
- CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.)
-
-
- ! Initialize the limiter
- min_phi = one
-
- ! For the second-order calculation, the minima and maxima will occur
- ! at the corner points of the element
- DO m = i, i+1
- DO n = j, j+1
-
- ! Evaluate the function at each corner point
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), gp(n), order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), local_min, local_max, min_phi)
- ENDDO
- ENDDO
-
- ! For the third order method, the minima and maxima may occur along
- ! the line segments given by du/dx = 0 and du/dy = 0. Also check
- ! for the presence of a maxima / minima of the quadratic within
- ! the domain.
- IF (order == 3) THEN
- disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k)
-
- ! Check if the quadratic is minimized within the element
- IF (ABS(disc) > tiny) THEN
- mx = - recons(5,i,j,k) * recons(2,i,j,k) &
- + 2.0 * recons(4,i,j,k) * recons(1,i,j,k)
- my = - recons(5,i,j,k) * recons(1,i,j,k) &
- + 2.0 * recons(3,i,j,k) * recons(2,i,j,k)
-
- mx = mx / disc + abp_centroid(1,i,j)
- my = my / disc + abp_centroid(2,i,j)
-
- IF ((mx - TAN(gp(i)) > -tiny) .AND. &
- (mx - TAN(gp(i+1)) < tiny) .AND. &
- (my - TAN(gp(j)) > -tiny) .AND. &
- (my - TAN(gp(j+1)) < tiny) &
- ) THEN
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDIF
- ENDIF
-
- ! Check all potential minimizer points along element boundaries
- IF (ABS(recons(5,i,j,k)) > tiny) THEN
-
- ! Left/right edge, intercept with du/dx = 0
- DO m = i, i+1
- my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / recons(5,i,j,k) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
-
- ! Top/bottom edge, intercept with du/dy = 0
- DO n = j, j+1
- mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Top/bottom edge, intercept with du/dx = 0
- IF (ABS(recons(3,i,j,k)) > tiny) THEN
- DO n = j, j+1
- mx = - recons(1,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Left/right edge, intercept with du/dy = 0
- IF (ABS(recons(4,i,j,k)) > tiny) THEN
- DO m = i, i+1
- my = - recons(2,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
- ENDIF
-
- IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN
- WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient'
- WRITE (*,*) 'Slope limiter out of range: ', min_phi
- STOP
- ENDIF
-
- ! Apply monotone limiter to all reconstruction coefficients
- recons(1,i,j,k) = min_phi * recons(1,i,j,k)
- recons(2,i,j,k) = min_phi * recons(2,i,j,k)
-
- IF (order > 2) THEN
- recons(3,i,j,k) = min_phi * recons(3,i,j,k)
- recons(4,i,j,k) = min_phi * recons(4,i,j,k)
- recons(5,i,j,k) = min_phi * recons(5,i,j,k)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-
- IF (selective) WRITE(*,*) 'skipped ', skip, ' points out of ', 6*(ncube_reconstruct-1)**2
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE PosDefABPGradient
-!
-! Description:
-! Scale the reconstructions so they are positive definite
-!
-! Parameters:
-! fcubehalo - Scalar field on the cubed sphere to use in reconstruction
-! order - Order of the reconstruction
-! recons (INOUT) - Array of reconstructed coefficients
-!
-! Remarks:
-! This monotonizing scheme is based on the monotone scheme for unstructured
-! grids of Barth and Jespersen (1989), but simpler. This simply finds the
-! minimum and then scales the reconstruction so that it is 0.
-!------------------------------------------------------------------------------
- SUBROUTINE PosDefABPGradient(fcubehalo, order, recons)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, k, m, n
-
- REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi
- REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: &
- gamma
-
- ! The first-order piecewise constant scheme is monotone by construction
- IF (order == 1) THEN
- RETURN
- ENDIF
-
-
- ! Apply monotone limiting
- DO k = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
-
- !If the average value in the cell is 0.0, then we should skip
- !all of the scaling and just set the reconstruction to 0.0
-! IF (ABS(fcubehalo(i,j,k)) < tiny) THEN
-! recons(:,i,j,k) = 0.0
-! CYCLE
-! END IF
- CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.)
-
-
- !This allowance for miniscule negative values appearing around the cell being
- !filtered/limited. Before this, negative values would be caught in adjust_limiter
- !and would stop the model. Doing this only causes minor negative values; no blowing
- !up is observed. The rationale is the same as for the monotone filter, which does
- !allow miniscule negative values due to roundoff error --- of the order E-10 ---
- !in flux-form methods (and E-17 in the s-L method, indicating that roundoff error
- !is more severe in the flux-form method, as we expect since we are often subtracting
- !2.0 values which are very close together.
- local_min = MIN(0.0,local_min)
- local_max = bignum !prevents scaling upward; for positive
- !definite limiting we don't care about the upper bound
-
- ! Initialize the limiter
- min_phi = one
-
- ! For the second-order calculation, the minima and maxima will occur
- ! at the corner points of the element
- DO m = i, i+1
- DO n = j, j+1
-
- ! Evaluate the function at each corner point
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), gp(n), order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), local_min, local_max, min_phi)
- ENDDO
- ENDDO
-
- ! For the third order method, the minima and maxima may occur along
- ! the line segments given by du/dx = 0 and du/dy = 0. Also check
- ! for the presence of a maxima / minima of the quadratic within
- ! the domain.
- IF (order == 3) THEN
- disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k)
-
- ! Check if the quadratic is minimized within the element
- IF (ABS(disc) > tiny) THEN
- mx = - recons(5,i,j,k) * recons(2,i,j,k) &
- + 2.0 * recons(4,i,j,k) * recons(1,i,j,k)
- my = - recons(5,i,j,k) * recons(1,i,j,k) &
- + 2.0 * recons(3,i,j,k) * recons(2,i,j,k)
-
- mx = mx / disc + abp_centroid(1,i,j)
- my = my / disc + abp_centroid(2,i,j)
-
- IF ((mx - TAN(gp(i)) > -tiny) .AND. &
- (mx - TAN(gp(i+1)) < tiny) .AND. &
- (my - TAN(gp(j)) > -tiny) .AND. &
- (my - TAN(gp(j+1)) < tiny) &
- ) THEN
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDIF
- ENDIF
-
- ! Check all potential minimizer points along element boundaries
- IF (ABS(recons(5,i,j,k)) > tiny) THEN
-
- ! Left/right edge, intercept with du/dx = 0
- DO m = i, i+1
- my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / recons(5,i,j,k) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
-
- ! Top/bottom edge, intercept with du/dy = 0
- DO n = j, j+1
- mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Top/bottom edge, intercept with du/dx = 0
- IF (ABS(recons(3,i,j,k)) > tiny) THEN
- DO n = j, j+1
- mx = - recons(1,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Left/right edge, intercept with du/dy = 0
- IF (ABS(recons(4,i,j,k)) > tiny) THEN
- DO m = i, i+1
- my = - recons(2,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), &
- local_min, local_max, min_phi)
- ENDDO
- ENDIF
- ENDIF
-
- IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN
- WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient'
- WRITE (*,*) 'Slope limiter out of range: ', min_phi
- STOP
- ENDIF
-
- ! Apply monotone limiter to all reconstruction coefficients
- recons(1,i,j,k) = min_phi * recons(1,i,j,k)
- recons(2,i,j,k) = min_phi * recons(2,i,j,k)
-
- IF (order > 2) THEN
- recons(3,i,j,k) = min_phi * recons(3,i,j,k)
- recons(4,i,j,k) = min_phi * recons(4,i,j,k)
- recons(5,i,j,k) = min_phi * recons(5,i,j,k)
- ENDIF
-
- ENDDO
- ENDDO
- ENDDO
-
-
- END SUBROUTINE PosDefABPGradient
-
-!------------------------------------------------------------------------------
-! SUBROUTINE MonotonizeABPGradient_New
-!
-! Description:
-! Apply a monotonic filter to the calculated ABP gradient.
-!
-! Parameters:
-! fcubehalo - Scalar field on the cubed sphere to use in reconstruction
-! order - Order of the reconstruction
-! recons (INOUT) - Array of reconstructed coefficients
-!
-! Remarks:
-! This monotonizing scheme is similar to the one in MonotonizeABPGradient,
-! except the second order derivatives are limited after the first order
-! derivatives.
-!------------------------------------------------------------------------------
- SUBROUTINE MonotonizeABPGradient_New(fcubehalo, order, recons)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, k, m, n
-
- REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, linval
- REAL (KIND=dbl_kind) :: disc, mx, my
-
- ! The first-order piecewise constant scheme is monotone by construction
- IF (order == 1) THEN
- RETURN
- ENDIF
-
- ! Apply monotone limiting
- DO k = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max, .FALSE.)
-
- ! Initialize the limiter
- min_phi = one
-
- ! For the second-order calculation, the minima and maxima will occur
- ! at the corner points of the element
- DO m = i, i+1
- DO n = j, j+1
-
- ! Evaluate the function at each corner point, only taking into
- ! account the linear component of the reconstruction.
- value = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j))
-
- CALL AdjustLimiter( &
- value, fcubehalo(i,j,k), local_min, local_max, min_phi)
- ENDDO
- ENDDO
-
- ! Apply monotone limiter to all reconstruction coefficients
- IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN
- WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient'
- WRITE (*,*) 'Slope limiter out of range: ', min_phi
- STOP
- ENDIF
-
- recons(1,i,j,k) = min_phi * recons(1,i,j,k)
- recons(2,i,j,k) = min_phi * recons(2,i,j,k)
-
- ! For the third order method, the minima and maxima may occur along
- ! the line segments given by du/dx = 0 and du/dy = 0. Also check
- ! for the presence of a maxima / minima of the quadratic within
- ! the domain.
- IF (order == 3) THEN
- ! Reset the limiter
- min_phi = one
-
- ! Calculate discriminant, which we use to determine the absolute
- ! minima/maxima of the paraboloid
- disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k)
-
- ! Check if the quadratic is minimized within the element
- IF (ABS(disc) > tiny) THEN
- mx = - recons(5,i,j,k) * recons(2,i,j,k) &
- + 2.0 * recons(4,i,j,k) * recons(1,i,j,k)
- my = - recons(5,i,j,k) * recons(1,i,j,k) &
- + 2.0 * recons(3,i,j,k) * recons(2,i,j,k)
-
- mx = mx / disc + abp_centroid(1,i,j)
- my = my / disc + abp_centroid(2,i,j)
-
- IF ((mx - TAN(gp(i)) > -tiny) .AND. &
- (mx - TAN(gp(i+1)) < tiny) .AND. &
- (my - TAN(gp(j)) > -tiny) .AND. &
- (my - TAN(gp(j+1)) < tiny) &
- ) THEN
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (my - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDIF
- ENDIF
-
- ! Check all potential minimizer points along element boundaries
- IF (ABS(recons(5,i,j,k)) > tiny) THEN
-
- ! Left/right edge, intercept with du/dx = 0
- DO m = i, i+1
- my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / recons(5,i,j,k) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (my - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDDO
-
- ! Top/bottom edge, intercept with du/dy = 0
- DO n = j, j+1
- mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Top/bottom edge, intercept with du/dx = 0
- IF (ABS(recons(3,i,j,k)) > tiny) THEN
- DO n = j, j+1
- mx = - recons(1,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(n)) - abp_centroid(2,i,j))
-
- mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j)
-
- IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, ATAN(mx), gp(n), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! Left/right edge, intercept with du/dy = 0
- IF (ABS(recons(4,i,j,k)) > tiny) THEN
- DO m = i, i+1
- my = - recons(2,i,j,k) - recons(5,i,j,k) * &
- (TAN(gp(m)) - abp_centroid(1,i,j))
-
- my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j)
-
- IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN
- CYCLE
- ENDIF
-
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), ATAN(my), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (my - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDDO
- ENDIF
-
- ! For the second-order calculation, the minima and maxima will occur
- ! at the corner points of the element
- DO m = i, i+1
- DO n = j, j+1
-
- ! Evaluate the function at each corner point
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), gp(n), &
- order, value)
-
- linval = &
- fcubehalo(i,j,k) &
- + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) &
- + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j))
-
- IF (linval < local_min) THEN
- linval = local_min
- ENDIF
- IF (linval > local_max) THEN
- linval = local_max
- ENDIF
-
- CALL AdjustLimiter( &
- value, linval, local_min, local_max, min_phi)
- ENDDO
- ENDDO
-
- IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN
- WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient'
- WRITE (*,*) 'Slope limiter out of range: ', min_phi
- STOP
- ENDIF
-
- WRITE (*,*) '2: ', min_phi
-
- recons(1,i,j,k) = min_phi * recons(1,i,j,k)
- recons(2,i,j,k) = min_phi * recons(2,i,j,k)
- recons(3,i,j,k) = min_phi * recons(3,i,j,k)
- recons(4,i,j,k) = min_phi * recons(4,i,j,k)
- recons(5,i,j,k) = min_phi * recons(5,i,j,k)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ReconstructABPGradient_NEL
-!
-! Description:
-! Construct a non-equidistant linear reconstruction of the gradient
-! within each element on an ABP grid.
-!
-! Parameters:
-! fcubehalo - Scalar field on the ABP grid to use in reconstruction
-! recons (OUT) - Array of reconstructed coefficients for total elements
-! order - Order of the scheme (2 or 3)
-!------------------------------------------------------------------------------
- SUBROUTINE ReconstructABPGradient_NEL(fcubehalo, recons, order)
-
-! USE CubedSphereTrans
-! USE InterpolateCSLL_Utils
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), &
- DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, p
-
- REAL (KIND=dbl_kind) :: alpha1, alpha2, beta1, beta2
- REAL (KIND=dbl_kind) :: dx_left, dx_right, top_value, bot_value
-
- DO p = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j)
- dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j)
-
- recons(1,i,j,p) = &
- (+ fcubehalo(i-1,j,p) * dx_right**2 &
- - fcubehalo(i+1,j,p) * dx_left**2 &
- - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / &
- (dx_right * dx_left * (dx_right - dx_left))
-
- dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j)
- dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j)
-
- recons(2,i,j,p) = &
- (+ fcubehalo(i,j-1,p) * dx_right**2 &
- - fcubehalo(i,j+1,p) * dx_left**2 &
- - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / &
- (dx_right * dx_left * (dx_right - dx_left))
-
- IF (order > 2) THEN
- dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j)
- dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j)
-
- recons(3,i,j,p) = &
- (+ fcubehalo(i-1,j,p) * dx_right &
- - fcubehalo(i+1,j,p) * dx_left &
- - fcubehalo(i,j,p) * (dx_right - dx_left)) / &
- (dx_right * dx_left * (dx_left - dx_right))
-
- dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j)
- dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j)
-
- recons(4,i,j,p) = &
- (+ fcubehalo(i,j-1,p) * dx_right &
- - fcubehalo(i,j+1,p) * dx_left &
- - fcubehalo(i,j,p) * (dx_right - dx_left)) / &
- (dx_right * dx_left * (dx_left - dx_right))
- ENDIF
- ENDDO
- ENDDO
-
- IF (order > 2) THEN
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- dx_left = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1)
- dx_right = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1)
-
- top_value = &
- (+ fcubehalo(i-1,j+1,p) * dx_right**2 &
- - fcubehalo(i+1,j+1,p) * dx_left**2 &
- - fcubehalo(i,j+1,p) * (dx_right**2 - dx_left**2)) / &
- (dx_right * dx_left * (dx_right - dx_left))
-
- dx_left = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1)
- dx_right = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1)
-
- bot_value = &
- (+ fcubehalo(i-1,j-1,p) * dx_right**2 &
- - fcubehalo(i+1,j-1,p) * dx_left**2 &
- - fcubehalo(i,j-1,p) * (dx_right**2 - dx_left**2)) / &
- (dx_right * dx_left * (dx_right - dx_left))
-
- dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j)
- dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j)
-
- recons(5,i,j,p) = &
- (+ bot_value * dx_right**2 &
- - top_value * dx_left**2 &
- - recons(1,i,j,p) * (dx_right**2 - dx_left**2)) / &
- (dx_right * dx_left * (dx_right - dx_left))
-
- ENDDO
- ENDDO
- ENDIF
- ENDDO
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ReconstructABPGradient_NEP
-!
-! Description:
-! Construct a non-equidistant parabolic reconstruction of the gradient
-! within each element on an ABP grid.
-!
-! Parameters:
-! fcubehalo - Scalar field on the ABP grid to use in reconstruction
-! recons (OUT) - Array of reconstructed coefficients for total elements
-! order - Order of the scheme (2 or 3)
-!------------------------------------------------------------------------------
- SUBROUTINE ReconstructABPGradient_NEP(fcubehalo, recons, order)
-
-
-! USE CubedSphereTrans
-! USE InterpolateCSLL_Utils
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), &
- DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, p
-
- REAL (KIND=dbl_kind) :: x1, x2, x4, x5, y1, y2, y3, y4, y5
-
- REAL (KIND=dbl_kind), DIMENSION(5) :: t, pa, denom
-
- DO p = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- ! X-direction reconstruction
- x1 = abp_centroid(1,i-2,j) - abp_centroid(1,i,j)
- x2 = abp_centroid(1,i-1,j) - abp_centroid(1,i,j)
- x4 = abp_centroid(1,i+1,j) - abp_centroid(1,i,j)
- x5 = abp_centroid(1,i+2,j) - abp_centroid(1,i,j)
-
- !IF (i == 1) THEN
- ! x1 = piq
- !ELSEIF (i == ncube_reconstruct-1) THEN
- ! x5 = -piq
- !ENDIF
-
- y1 = fcubehalo(i-2,j,p)
- y2 = fcubehalo(i-1,j,p)
- y3 = fcubehalo(i,j,p)
- y4 = fcubehalo(i+1,j,p)
- y5 = fcubehalo(i+2,j,p)
-
- denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1
- denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2
- denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4
- denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5
-
- t(1) = x5 * x4 * x2
- t(2) = x5 * x4 * x1
- t(4) = x5 * x2 * x1
- t(5) = x4 * x2 * x1
- t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5)
-
- pa(1) = x2 * x4 + x2 * x5 + x4 * x5
- pa(2) = x1 * x4 + x1 * x5 + x4 * x5
- pa(4) = x1 * x2 + x1 * x5 + x2 * x5
- pa(5) = x1 * x2 + x1 * x4 + x2 * x4
- pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5)
-
- recons(1,i,j,p) = &
- + y1 * t(1) / denom(1) &
- + y2 * t(2) / denom(2) &
- - y3 * t(3) &
- + y4 * t(4) / denom(4) &
- + y5 * t(5) / denom(5)
-
- IF (order > 2) THEN
- recons(3,i,j,p) = &
- - y1 * pa(1) / denom(1) &
- - y2 * pa(2) / denom(2) &
- + y3 * pa(3) &
- - y4 * pa(4) / denom(4) &
- - y5 * pa(5) / denom(5)
- ENDIF
-
- ! Y-direction reconstruction
- x1 = abp_centroid(2,i,j-2) - abp_centroid(2,i,j)
- x2 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j)
- x4 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j)
- x5 = abp_centroid(2,i,j+2) - abp_centroid(2,i,j)
-
- !IF (j == 1) THEN
- ! x1 = piq
- !ELSEIF (j == ncube_reconstruct-1) THEN
- ! x5 = -piq
- !ENDIF
-
- y1 = fcubehalo(i,j-2,p)
- y2 = fcubehalo(i,j-1,p)
- y3 = fcubehalo(i,j,p)
- y4 = fcubehalo(i,j+1,p)
- y5 = fcubehalo(i,j+2,p)
-
- denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1
- denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2
- denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4
- denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5
-
- t(1) = x5 * x4 * x2
- t(2) = x5 * x4 * x1
- t(4) = x5 * x2 * x1
- t(5) = x4 * x2 * x1
- t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5)
-
- pa(1) = x2 * x4 + x2 * x5 + x4 * x5
- pa(2) = x1 * x4 + x1 * x5 + x4 * x5
- pa(4) = x1 * x2 + x1 * x5 + x2 * x5
- pa(5) = x1 * x2 + x1 * x4 + x2 * x4
- pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5)
-
- recons(2,i,j,p) = &
- + y1 * t(1) / denom(1) &
- + y2 * t(2) / denom(2) &
- - y3 * t(3) &
- + y4 * t(4) / denom(4) &
- + y5 * t(5) / denom(5)
-
- IF (order > 2) THEN
- recons(4,i,j,p) = &
- - y1 * pa(1) / denom(1) &
- - y2 * pa(2) / denom(2) &
- + y3 * pa(3) &
- - y4 * pa(4) / denom(4) &
- - y5 * pa(5) / denom(5)
- recons(5,i,j,p) = 0.0
- ENDIF
-
- ENDDO
- ENDDO
- IF (order > 2) THEN
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- x1 = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1)
- x2 = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1)
-
- y2 = (+ fcubehalo(i-1,j+1,p) * x2**2 &
- - fcubehalo(i+1,j+1,p) * x1**2 &
- - fcubehalo(i,j+1,p) * (x2**2 - x1**2)) / &
- (x2 * x1 * (x2 - x1))
-
- x1 = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1)
- x2 = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1)
-
- y1 = (+ fcubehalo(i-1,j-1,p) * x2**2 &
- - fcubehalo(i+1,j-1,p) * x1**2 &
- - fcubehalo(i,j-1,p) * (x2**2 - x1**2)) / &
- (x2 * x1 * (x2 - x1))
-
- x1 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j)
- x2 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j)
-
- recons(5,i,j,p) = &
- (+ y1 * x2**2 &
- - y2 * x1**2 &
- - recons(1,i,j,p) * (x2**2 - x1**2)) / &
- (x2 * x1 * (x2 - x1))
-
- ENDDO
- ENDDO
- ENDIF
- ENDDO
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ReconstructABPGradient_PLM
-!
-! Description:
-! Construct a piecewise linear reconstruction of the gradient within
-! each element on an ABP grid.
-!
-! Parameters:
-! fcubehalo - Scalar field on the ABP grid to use in reconstruction
-! recons (OUT) - Array of reconstructed coefficients for total elements
-! order - Order of the scheme (2 or 3)
-!------------------------------------------------------------------------------
- SUBROUTINE ReconstructABPGradient_PLM(fcubehalo, recons, order)
-
-! USE CubedSphereTrans
-! USE InterpolateCSLL_Utils
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), &
- DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, p
-
- REAL (KIND=dbl_kind) :: width
-
- ! ABP width between elements
- width = pih / DBLE(ncube_reconstruct-1)
-
- DO p = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- ! df/dx
- recons(1,i,j,p) = (fcubehalo(i+1,j,p) - fcubehalo(i-1,j,p)) / &
- (2.0 * width)
-
- ! df/dy
- recons(2,i,j,p) = (fcubehalo(i,j+1,p) - fcubehalo(i,j-1,p)) / &
- (2.0 * width)
-
- ! Stretching
- recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2)
- recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2)
-
- ! Third order scheme
- IF (order > 2) THEN
- ! d^2f/dx^2
- recons(3,i,j,p) = &
- (fcubehalo(i+1,j,p) - 2.0 * fcubehalo(i,j,p) &
- + fcubehalo(i-1,j,p)) / (width * width)
-
- ! d^2f/dy^2
- recons(4,i,j,p) = &
- (fcubehalo(i,j+1,p) - 2.0 * fcubehalo(i,j,p) &
- + fcubehalo(i,j-1,p)) / (width * width)
-
- ! d^2f/dxdy
- recons(5,i,j,p) = &
- (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) &
- - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) &
- ) / (4.0 * width * width)
-
- ! Stretching
- recons(3,i,j,p) = &
- (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) &
- + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2
-
- recons(4,i,j,p) = &
- (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) &
- + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2
-
- recons(5,i,j,p) = recons(5,i,j,p) / &
- ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2))
-
- ! Scaling
- recons(3,i,j,p) = 0.5 * recons(3,i,j,p)
- recons(4,i,j,p) = 0.5 * recons(4,i,j,p)
-
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ReconstructABPGradient_PPM
-!
-! Description:
-! Construct a piecewise parabolic reconstruction of the gradient within
-! each element on an ABP grid.
-!
-! Parameters:
-! fcubehalo - Scalar field on the ABP grid to use in reconstruction
-! recons (OUT) - Array of reconstructed coefficients for total elements
-! order - Order of the scheme (2 or 3)
-!------------------------------------------------------------------------------
- SUBROUTINE ReconstructABPGradient_PPM(fcubehalo, recons, order)
-
-
-! USE CubedSphereTrans
-! USE InterpolateCSLL_Utils
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), &
- DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, p
-
- REAL (KIND=dbl_kind) :: width
-
- ! ABP width between elements
- width = pih / DBLE(ncube_reconstruct-1)
-
- DO p = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- ! df/dalfa
- recons(1,i,j,p) = &
- (+ fcubehalo(i+2,j,p) - 8.0 * fcubehalo(i+1,j,p) &
- + 8.0 * fcubehalo(i-1,j,p) - fcubehalo(i-2,j,p)) / &
- (- 12.0 * width)
-
- ! df/dbeta
- recons(2,i,j,p) = &
- (+ fcubehalo(i,j+2,p) - 8.0 * fcubehalo(i,j+1,p) &
- + 8.0 * fcubehalo(i,j-1,p) - fcubehalo(i,j-2,p)) / &
- (- 12.0 * width)
-
- ! Stretching
- recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2)
- recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2)
-
- ! Third order scheme
- IF (order > 2) THEN
- ! d^2f/dx^2
- recons(3,i,j,p) = (- fcubehalo(i+2,j,p) &
- + 16_dbl_kind * fcubehalo(i+1,j,p) &
- - 30_dbl_kind * fcubehalo(i,j,p) &
- + 16_dbl_kind * fcubehalo(i-1,j,p) &
- - fcubehalo(i-2,j,p) &
- ) / (12_dbl_kind * width**2)
-
- ! d^2f/dy^2
- recons(4,i,j,p) = (- fcubehalo(i,j+2,p) &
- + 16_dbl_kind * fcubehalo(i,j+1,p) &
- - 30_dbl_kind * fcubehalo(i,j,p) &
- + 16_dbl_kind * fcubehalo(i,j-1,p) &
- - fcubehalo(i,j-2,p) &
- ) / (12_dbl_kind * width**2)
-
- ! d^2f/dxdy
- recons(5,i,j,p) = &
- (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) &
- - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) &
- ) / (4.0 * width * width)
-
- ! Stretching
- recons(3,i,j,p) = &
- (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) &
- + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2
-
- recons(4,i,j,p) = &
- (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) &
- + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2
-
- recons(5,i,j,p) = recons(5,i,j,p) / &
- ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2))
-
- ! Scaling
- recons(3,i,j,p) = 0.5 * recons(3,i,j,p)
- recons(4,i,j,p) = 0.5 * recons(4,i,j,p)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE ReconstructABPGradient
-!
-! Description:
-! Compute the reconstructed gradient in gnomonic coordinates for each
-! ABP element.
-!
-! Parameters:
-! fcube - Scalar field on the cubed sphere to use in reconstruction
-! halomethod - Method for computing halo elements
-! (0) Piecewise constant
-! (1) Piecewise linear
-! (3) Piecewise cubic
-! recons_method - Method for computing the sub-grid scale gradient
-! (0) Non-equidistant linear reconstruction
-! (1) Non-equidistant parabolic reconstruction
-! (2) Piecewise linear reconstruction with stretching
-! (3) Piecewise parabolic reconstruction with stretching
-! order - Order of the method being applied
-! kmono - Apply monotone limiting (1) or not (0)
-! recons (INOUT) - Array of reconstructed coefficients
-!------------------------------------------------------------------------------
- SUBROUTINE ReconstructABPGradient( &
- fcube, halomethod, recons_method, order, kmono, recons, kpd, kscheme)
-
-! USE InterpolateCSLL_Utils
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1:ncube_reconstruct-1, 1:ncube_reconstruct-1, 6), INTENT(IN) :: fcube
-
- INTEGER (KIND=int_kind), INTENT(IN) :: halomethod, recons_method
- INTEGER (KIND=int_kind), INTENT(IN) :: order, kmono, kpd, kscheme
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, p
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: fcubehalo
-
- ! Report status
- WRITE (*,*) '...Performing sub-grid scale reconstruction on ABP grid'
-
- ! Compute element haloes
- WRITE(*,*) "fill cubed-sphere halo for reconstruction"
- DO p = 1, 6
- IF (halomethod == 0) THEN
- CALL CubedSphereFillHalo(fcube, fcubehalo, p, ncube_reconstruct, 2)
-
- ELSEIF (halomethod == 1) THEN
- CALL CubedSphereFillHalo_Linear(fcube, fcubehalo, p, ncube_reconstruct)
-
- ELSEIF (halomethod == 3) THEN
- !halomethod is always 3 in the standard CSLAM setup
- CALL CubedSphereFillHalo_Cubic(fcube, fcubehalo, p, ncube_reconstruct)
- ELSE
- WRITE (*,*) 'Fatal Error: In ReconstructABPGradient'
- WRITE (*,*) 'Invalid halo method: ', halomethod
- WRITE (*,*) 'Halo method must be 0, 1 or 3.'
- STOP
- ENDIF
- ENDDO
-
- ! Nonequidistant linear reconstruction
- IF (recons_method == 1) THEN
- CALL ReconstructABPGradient_NEL(fcubehalo, recons, order)
-
- ! Nonequidistant parabolic reconstruction (JCP paper)
- ELSEIF (recons_method == 2) THEN
- WRITE(*,*) "Nonequidistant parabolic reconstruction"
- CALL ReconstructABPGradient_NEP(fcubehalo, recons, order)
-
- ! Piecewise linear reconstruction with rotation
- ELSEIF (recons_method == 3) THEN
- CALL ReconstructABPGradient_PLM(fcubehalo, recons, order)
-
- ! Piecewise parabolic reconstruction with rotation
- ELSEIF (recons_method == 4) THEN
- CALL ReconstructABPGradient_PPM(fcubehalo, recons, order)
-
- ELSE
- WRITE(*,*) 'Fatal Error: In ReconstructABPGradient'
- WRITE(*,*) 'Specified recons_method out of range. Given: ', recons_method
- WRITE(*,*) 'Valid values: 1, 2, 3, 4'
- STOP
- ENDIF
-
- ! Apply monotone filtering
- SELECT CASE (kmono)
- CASE (0) !Do nothing
- WRITE(*,*) "no filter applied to the reconstruction"
- CASE (1)
-
- !Simplest filter: just scales the recon so it's extreme value
- !is no bigger than the original values of this point and its neighbors
- CALL MonotonizeABPGradient(fcubehalo, order, recons, .FALSE.)
-
- CASE (2)
-
- !Applies a more sophisticated Van Leer limiter (or, to be consistent, a filter)
- CALL VanLeerLimit(fcubehalo, order, recons)
-
- CASE (3)
-
- !Applies a selective filter
- CALL MonotonizeABPGradient(fcubehalo, order, recons, .TRUE.)
-
- CASE (4)
-
- !A filter that filters the linear part first
- CALL MonotonizeABPGradient_New(fcubehalo, order, recons)
-
- CASE DEFAULT
- WRITE(*,*) "Limiter kmono = ", kmono, " does not exist."
- STOP 1201
-
- END SELECT
-
- !Apply positive-definite filtering, if desired. This should
- !ONLY be applied to the S-L method, since the flux-form
- !method needs something different done. (In particular, using
- !positive-definite reconstructions does not ensure that a flux-
- !form scheme is positive definite, since we could get negatives
- !when subtracting the resulting fluxes.)
- !HOWEVER...we will allow this to be enabled, for testing purposes
- IF ( (kpd > 0 .AND. kscheme == 2) .OR. (kpd == 2 .AND. kscheme == 4) ) THEN
- WRITE(*,*) "applying positive deifnite constraint"
- CALL PosDefABPGradient(fcubehalo, order, recons)
- END IF
-
-
- END SUBROUTINE
-
-
-
-!------------------------------------------------------------------------------
-!------------------------------------------------------------------------------
-! SUBROUTINE AdjustLimiter
-!
-! Description:
-! Adjust the slope limiter based on new point values.
-!
-! Parameters:
-! value - Point value
-! element_value - Value at the center of the element
-! local_max - Local maximum value of the function (from neighbours)
-! local_min - Local minimum value of the function (to neighbours)
-! min_phi (INOUT) - Slope limiter
-!------------------------------------------------------------------------------
- SUBROUTINE AdjustLimiter(value, element_value, local_min, local_max, min_phi)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), INTENT(IN) :: value, element_value
- REAL (KIND=dbl_kind), INTENT(IN) :: local_min, local_max
- REAL (KIND=dbl_kind), INTENT(INOUT) :: min_phi
-
- ! Local variables
- REAL (KIND=dbl_kind) :: phi = 0.0
-
- IF ((local_min > element_value ) .OR. (local_max < element_value )) THEN
- WRITE (*,*) 'Fatal Error: In AdjustLimiter'
- WRITE (*,*) 'Local min: ', local_min, ' max: ', local_max
- WRITE (*,*) 'Elemn: ', element_value
- STOP
- ENDIF
-
- ! Check against the minimum bound on the reconstruction
- IF (value - element_value > tiny * value) THEN
- phi = (local_max - element_value) / &
- (value - element_value)
-
- min_phi = MIN(min_phi, phi)
-
- ! Check against the maximum bound on the reconstruction
- ELSEIF (value - element_value < -tiny * value) THEN
- phi = (local_min - element_value) / &
- (value - element_value)
-
- min_phi = MIN(min_phi, phi)
-
- ENDIF
-
- IF (min_phi < 0.0) THEN
- WRITE (*,*) 'Fatal Error: In AdjustLimiter'
- WRITE (*,*) 'Min_Phi: ', min_phi
- WRITE (*,*) 'Phi: ', phi
- WRITE (*,*) 'Value: ', value
- WRITE (*,*) 'Elemn: ', element_value
- WRITE (*,*) 'Val-E: ', value - element_value
- STOP
- ENDIF
-
- END SUBROUTINE
-
-!------------------------------------------------------------------------------
-! SUBROUTINE VanLeerLimit
-!
-! Description:
-! Apply a 2D Van Leer-type limiter to a reconstruction. This acts ONLY
-! on the linear part of the reconstruction , if any. If passed a PCoM
-! reconstruction, this just returns without altering the recon.
-!
-! Parameters:
-! fcubehalo - Scalar field on the cubed sphere to use in reconstruction
-! order - Order of the reconstruction
-! recons (INOUT) - Array of reconstructed coefficients
-!
-! Remarks:
-! The Van Leer Limiter described here is given on pages 328--329
-! of Dukowicz and Baumgardner (2000). There are no guarantees
-! on what it will do to PPM.
-!------------------------------------------------------------------------------
- SUBROUTINE VanLeerLimit(fcubehalo, order, recons)
-
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), &
- INTENT(IN) :: fcubehalo
-
- INTEGER (KIND=int_kind), INTENT(IN) :: order
-
- REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons
-
- ! Local variables
- INTEGER (KIND=int_kind) :: i, j, k, m, n
-
- REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, &
- recon_min, recon_max
-
- ! The first-order piecewise constant scheme is monotone by construction
- IF (order == 1) THEN
- RETURN
- ENDIF
-
- ! Apply monotone limiting
- DO k = 1, 6
- DO j = 1, ncube_reconstruct-1
- DO i = 1, ncube_reconstruct-1
- CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.)
-
- ! Initialize the limiter
- min_phi = one
-
- ! For the second-order calculation, the minima and maxima will occur
- ! at the corner points of the element. For the Van Leer limiter, we
- !wish to find BOTH of the reconstruction extrema.
- recon_min = bignum
- recon_max = -bignum
-
- DO m = i, i+1
- DO n = j, j+1
-
- ! Evaluate the function at each corner point
- CALL EvaluateABPReconstruction( &
- fcubehalo, recons, i, j, k, gp(m), gp(n), order, value)
- recon_min = MIN(recon_min, value)
- recon_max = MAX(recon_max, value)
-
- ENDDO
- ENDDO
-
- !This is equation 27 in Dukowicz and Baumgardner 2000
- min_phi = MIN(one, MAX(0.0, (local_min - fcubehalo(i,j,k))/(recon_min - fcubehalo(i,j,k))), &
- MAX(0.0, (local_max - fcubehalo(i,j,k))/(recon_max - fcubehalo(i,j,k))) )
-
- IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN
- WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient'
- WRITE (*,*) 'Slope limiter out of range: ', min_phi
- STOP
- ENDIF
-
- ! Apply monotone limiter to all reconstruction coefficients
- recons(1,i,j,k) = min_phi * recons(1,i,j,k)
- recons(2,i,j,k) = min_phi * recons(2,i,j,k)
-
- END DO
- END DO
- END DO
-
-
-
-
- END SUBROUTINE VanLeerLimit
-
- !------------------------------------------------------------------------------
- ! SUBROUTINE EquiangularElementArea
- !
- ! Description:
- ! Compute the area of a single equiangular cubed sphere grid cell.
- !
- ! Parameters:
- ! alpha - Alpha coordinate of lower-left corner of grid cell
- ! da - Delta alpha
- ! beta - Beta coordinate of lower-left corner of grid cell
- ! db - Delta beta
- !------------------------------------------------------------------------------
- REAL(KIND=dbl_kind) FUNCTION EquiangularElementArea(alpha, da, beta, db)
-
- IMPLICIT NONE
-
-! REAL (kind=dbl_kind) :: EquiangularElementArea
- REAL (kind=dbl_kind) :: alpha, da, beta, db
- REAL (kind=dbl_kind) :: a1, a2, a3, a4
-
- ! Calculate interior grid angles
- a1 = EquiangularGridAngle(alpha , beta )
- a2 = pi - EquiangularGridAngle(alpha+da, beta )
- a3 = pi - EquiangularGridAngle(alpha , beta+db)
- a4 = EquiangularGridAngle(alpha+da, beta+db)
-
- ! Area = r*r*(-2*pi+sum(interior angles))
- EquiangularElementArea = -pi2 + a1 + a2 + a3 + a4
-
- END FUNCTION EquiangularElementArea
-
- !------------------------------------------------------------------------------
- ! FUNCTION EquiangularGridAngle
- !
- ! Description:
- ! Compute the angle between equiangular cubed sphere projection grid lines.
- !
- ! Parameters:
- ! alpha - Alpha coordinate of evaluation point
- ! beta - Beta coordinate of evaluation point
- !------------------------------------------------------------------------------
- REAL(KIND=dbl_kind) FUNCTION EquiangularGridAngle(alpha, beta)
- IMPLICIT NONE
- REAL (kind=dbl_kind) :: alpha, beta
- EquiangularGridAngle = ACOS(-SIN(alpha) * SIN(beta))
- END FUNCTION EquiangularGridAngle
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereFillHalo
-!
-! Description:
-! Recompute the cubed sphere data storage array, with the addition of a
-! halo region around the specified panel.
-!
-! Parameters:
-! parg - Current panel values
-! zarg (OUT) - Calculated panel values with halo/ghost region
-! np - Panel number
-! ncube - Dimension of the cubed sphere (# of grid lines)
-! nhalo - Number of halo/ghost elements around each panel
-!------------------------------------------------------------------------------
- SUBROUTINE CubedSphereFillHalo(parg, zarg, np, ncube, nhalo)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), &
- INTENT(OUT) :: zarg
-
- INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube,nhalo
-
- ! Local variables
- INTEGER (KIND=int_kind) :: jh,jhy
-
- !zarg = 0.0 !DBG
- zarg(1:ncube-1,1:ncube-1,np) = parg(1:ncube-1,1:ncube-1,np)
-
- zarg(1-nhalo:0,1-nhalo:0,np) = 0.0
- zarg(1-nhalo:0,ncube:ncube+nhalo-1,np) = 0.0
- zarg(ncube:ncube+nhalo-1,1-nhalo:0,np) = 0.0
- zarg(ncube:ncube+nhalo-1,ncube:ncube+nhalo-1,np) = 0.0
-
- ! Equatorial panels
- IF (np==1) THEN
- DO jh=1,nhalo
- zarg(ncube+jh-1,1:ncube-1 ,1) = parg(jh ,1:ncube-1 ,2) !exchange right
- zarg(1-jh ,1:ncube-1 ,1) = parg(ncube-jh ,1:ncube-1 ,4) !exchange left
- zarg(1:ncube-1 ,1-jh ,1) = parg(1:ncube-1 ,ncube-jh ,5) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,1) = parg(1:ncube-1 ,jh ,6) !exchange over
- ENDDO
-
- ELSE IF (np==2) THEN
- DO jh=1,nhalo
- zarg(1-jh ,1:ncube-1 ,2) = parg(ncube-jh,1:ncube-1 ,1) !exchange left
- zarg(ncube+jh-1,1:ncube-1 ,2) = parg(jh ,1:ncube-1 ,3) !exchange right
- zarg(1:ncube-1 ,1-jh ,2) = parg(ncube-jh,ncube-1:1:-1,5) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,2) = parg(ncube-jh,1:ncube-1 ,6) !exchange over
- ENDDO
-
- ELSE IF (np==3) THEN
- DO jh=1,nhalo
- zarg(ncube+jh-1,1:ncube-1 ,3) = parg(jh ,1:ncube-1,4) !exchange right
- zarg(1-jh ,1:ncube-1 ,3) = parg(ncube-jh ,1:ncube-1,2) !exchange left
- zarg(1:ncube-1 ,1-jh ,3) = parg(ncube-1:1:-1,jh ,5) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,3) = parg(ncube-1:1:-1,ncube-jh ,6) !exchange over
- ENDDO
-
- ELSE IF (np==4) THEN
- DO jh=1,nhalo
- zarg(1-jh ,1:ncube-1 ,4) = parg(ncube-jh,1:ncube-1 ,3) !exchange left
- zarg(ncube+jh-1,1:ncube-1 ,4) = parg(jh ,1:ncube-1 ,1) !exchange right
- zarg(1:ncube-1 ,1-jh ,4) = parg(jh ,1:ncube-1 ,5) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,4) = parg(jh ,ncube-1:1:-1,6) !exchange over
- ENDDO
-
- ! Bottom panel
- ELSE IF (np==5) THEN
- DO jh=1,nhalo
- zarg(1-jh ,1:ncube-1 ,5) = parg(1:ncube-1 ,jh ,4) !exchange left
- zarg(ncube+jh-1,1:ncube-1 ,5) = parg(ncube-1:1:-1,jh ,2) !exchange right
- zarg(1:ncube-1 ,1-jh ,5) = parg(ncube-1:1:-1,jh ,3) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,5) = parg(1:ncube-1 ,jh ,1) !exchange over
- ENDDO
-
- ! Top panel
- ELSE IF (np==6) THEN
- DO jh=1,nhalo
- zarg(1-jh ,1:ncube-1 ,6) = parg(ncube-1:1:-1,ncube-jh,4) !exchange left
- zarg(ncube+jh-1,1:ncube-1 ,6) = parg(1:ncube-1 ,ncube-jh,2) !exchange right
- zarg(1:ncube-1 ,1-jh ,6) = parg(1:ncube-1 ,ncube-jh,1) !exchange below
- zarg(1:ncube-1 ,ncube+jh-1,6) = parg(ncube-1:1:-1,ncube-jh,3) !exchange over
- ENDDO
-
- ELSE
- WRITE (*,*) 'Fatal error: In CubedSphereFillHalo'
- WRITE (*,*) 'Invalid panel id ', np
- STOP
- ENDIF
-
- END SUBROUTINE CubedSphereFillHalo
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereFillHalo_Linear
-!
-! Description:
-! Recompute the cubed sphere data storage array, with the addition of a
-! 2-element halo region around the specified panel. Use linear order
-! interpolation to translate between panels.
-!
-! Parameters:
-! parg - Current panel values
-! zarg (OUT) - Calculated panel values with halo/ghost region
-! np - Panel number
-! ncube - Dimension of the cubed sphere (# of grid lines)
-!------------------------------------------------------------------------------
- SUBROUTINE CubedSphereFillHalo_Linear(parg, zarg, np, ncube)
-
-! USE CubedSphereTrans ! Cubed sphere transforms
-
- IMPLICIT NONE
-
- INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2
-
- REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), &
- INTENT(OUT) :: zarg
-
- INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube
-
- ! Local variables
- INTEGER (KIND=int_kind) :: ii, iref, jj, ipanel, imin, imax
- REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta
-
- REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha
- REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg
-
- ! Use 0.0 order interpolation to begin
- CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo)
-
- zarg(:,:,np) = yarg(:,:,np)
-
- ! Calculate the overlapping alpha coordinates
- width = pih / DBLE(ncube-1)
-
- DO jj = 1, nhalo
- DO ii = 0, ncube
- prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq
- beta = - width * (DBLE(jj-1) + 0.5) - piq
-
- CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, &
- newalpha(ii,jj), newbeta)
- ENDDO
- ENDDO
-
- ! Now apply linear interpolation to obtain edge components
- DO jj = 1, nhalo
- ! Reset the reference index
- iref = 2
-
- ! Interpolation can be applied to more elements after first band
- IF (jj == 1) THEN
- imin = 1
- imax = ncube-1
- ELSE
- imin = 0
- imax = ncube
- ENDIF
-
- ! Apply linear interpolation
- DO ii = imin, imax
- DO WHILE ((iref .NE. ncube-1) .AND. &
- (newalpha(ii,jj) > prealpha(iref,jj)))
- iref = iref + 1
- ENDDO
-
- IF ((newalpha(ii,jj) > prealpha(iref-1,jj)) .AND. &
- (newalpha(ii,jj) .LE. prealpha(iref ,jj))) &
- THEN
- a = (newalpha(ii,jj) - prealpha(iref-1,jj)) / &
- (prealpha(iref,jj) - prealpha(iref-1,jj))
-
- IF ((a < 0.0) .OR. (a > one)) THEN
- WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear'
- WRITE (*,*) 'a out of bounds'
- STOP
- ENDIF
-
- ! Bottom edge of panel
- zarg(ii, 1-jj, np) = &
- (one - a) * yarg(iref-1, 1-jj, np) + &
- a * yarg(iref, 1-jj, np)
-
- ! Left edge of panel
- zarg(1-jj, ii, np) = &
- (one - a) * yarg(1-jj, iref-1, np) + &
- a * yarg(1-jj, iref, np)
-
- ! Top edge of panel
- zarg(ii, ncube+jj-1, np) = &
- (one - a) * yarg(iref-1, ncube+jj-1, np) + &
- a * yarg(iref, ncube+jj-1, np)
-
- ! Right edge of panel
- zarg(ncube+jj-1, ii, np) = &
- (one - a) * yarg(ncube+jj-1, iref-1, np) + &
- a * yarg(ncube+jj-1, iref, np)
-
- ELSE
- WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear'
- WRITE (*,*) 'ii: ', ii, ' jj: ', jj
- WRITE (*,*) 'newalpha: ', newalpha(ii,jj)
- WRITE (*,*) 'prealpha: ', prealpha(iref-1,jj), '-', prealpha(iref,jj)
- STOP
- ENDIF
- ENDDO
- ENDDO
-
- ! Fill in corner bits
- zarg(0, 0, np) = &
- 0.25 * (zarg(1,0,np) + zarg(0,1,np) + &
- zarg(-1,0,np) + zarg(0,-1,np))
- zarg(0, ncube, np) = &
- 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + &
- zarg(-1,ncube,np) + zarg(1,ncube,np))
- zarg(ncube, 0, np) = &
- 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + &
- zarg(ncube,-1,np) + zarg(ncube,1,np))
- zarg(ncube, ncube, np) = &
- 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + &
- zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np))
-
- END SUBROUTINE CubedSphereFillHalo_Linear
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereFillHalo_Cubic
-!
-! Description:
-! Recompute the cubed sphere data storage array, with the addition of a
-! 2-element halo region around the specified panel. Use higher order
-! interpolation to translate between panels.
-!
-! Parameters:
-! parg - Current panel values
-! zarg (OUT) - Calculated panel values with halo/ghost region
-! np - Panel number
-! ncube - Dimension of the cubed sphere (# of grid lines)
-!------------------------------------------------------------------------------
- SUBROUTINE CubedSphereFillHalo_Cubic(parg, zarg, np, ncube)
-
-! USE CubedSphereTrans ! Cubed sphere transforms
-! USE MathUtils ! Has function for 1D cubic interpolation
-
- IMPLICIT NONE
-
- INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2
-
- REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), &
- INTENT(OUT) :: zarg
-
- INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube
-
- ! Local variables
- INTEGER (KIND=int_kind) :: ii, iref, ibaseref, jj, ipanel, imin, imax
- REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta
-
- REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha
- REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha
- REAL (KIND=dbl_kind), DIMENSION(1:4) :: C, D, X
-
- REAL (KIND=dbl_kind), &
- DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg
-
- ! Use 0.0 order interpolation to begin
- CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo)
-
- zarg(:,:,np) = yarg(:,:,np)
-
- ! Calculate the overlapping alpha coordinates
- width = pih / DBLE(ncube-1)
-
- DO jj = 1, nhalo
- DO ii = 0, ncube
- !
- ! alpha,beta for the cell center (extending the panel)
- !
- prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq
- beta = - width * (DBLE(jj-1) + 0.5) - piq
-
- CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, &
- newalpha(ii,jj), newbeta)
- ENDDO
- ENDDO
-
- ! Now apply cubic interpolation to obtain edge components
- DO jj = 1, nhalo
- ! Reset the reference index, which gives the element in newalpha that
- ! is closest to ii, looking towards larger values of alpha.
- iref = 2
-
- ! Interpolation can be applied to more elements after first band
-! IF (jj == 1) THEN
-! imin = 1
-! imax = ncube-1
-! ELSE
- imin = 0
- imax = ncube
-! ENDIF
-
- ! Apply cubic interpolation
- DO ii = imin, imax
- DO WHILE ((iref .NE. ncube-1) .AND. &
- (newalpha(ii,jj) > prealpha(iref,jj)))
- iref = iref + 1
- ENDDO
-
- ! Smallest index for cubic interpolation - apply special consideration
- IF (iref == 2) THEN
- ibaseref = iref-1
-
- ! Largest index for cubic interpolation - apply special consideration
- ELSEIF (iref == ncube-1) THEN
- ibaseref = iref-3
-
- ! Normal range
- ELSE
- ibaseref = iref-2
- ENDIF
-
- ! Bottom edge of panel
- zarg(ii, 1-jj, np) = &
- CUBIC_EQUISPACE_INTERP( &
- width, newalpha(ii,jj) - prealpha(ibaseref,jj), &
- yarg(ibaseref:ibaseref+3, 1-jj, np))
-
- ! Left edge of panel
- zarg(1-jj, ii, np) = &
- CUBIC_EQUISPACE_INTERP( &
- width, newalpha(ii,jj) - prealpha(ibaseref,jj), &
- yarg(1-jj, ibaseref:ibaseref+3, np))
-
- ! Top edge of panel
- zarg(ii, ncube+jj-1, np) = &
- CUBIC_EQUISPACE_INTERP( &
- width, newalpha(ii,jj) - prealpha(ibaseref,jj), &
- yarg(ibaseref:ibaseref+3, ncube+jj-1, np))
-
- ! Right edge of panel
- zarg(ncube+jj-1, ii, np) = &
- CUBIC_EQUISPACE_INTERP( &
- width, newalpha(ii,jj) - prealpha(ibaseref,jj), &
- yarg(ncube+jj-1, ibaseref:ibaseref+3, np))
-
- ENDDO
- ENDDO
-
- ! Fill in corner bits
- zarg(0, 0, np) = &
- 0.25 * (zarg(1,0,np) + zarg(0,1,np) + &
- zarg(-1,0,np) + zarg(0,-1,np))
- zarg(0, ncube, np) = &
- 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + &
- zarg(-1,ncube,np) + zarg(1,ncube,np))
- zarg(ncube, 0, np) = &
- 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + &
- zarg(ncube,-1,np) + zarg(ncube,1,np))
- zarg(ncube, ncube, np) = &
- 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + &
- zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np))
-
- END SUBROUTINE CubedSphereFillHalo_Cubic
-
-!------------------------------------------------------------------------------
-! SUBROUTINE CubedSphereABPFromABP
-!
-! Description:
-! Determine the (alpha,beta,idest) coordinate of a source point on
-! panel isource.
-!
-! Parameters:
-! alpha_in - Alpha coordinate in
-! beta_in - Beta coordinate in
-! isource - Source panel
-! idest - Destination panel
-! alpha_out (OUT) - Alpha coordinate out
-! beta_out (OUT) - Beta coordiante out
-!------------------------------------------------------------------------------
- SUBROUTINE CubedSphereABPFromABP(alpha_in, beta_in, isource, idest, &
- alpha_out, beta_out)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha_in, beta_in
- INTEGER (KIND=int_kind), INTENT(IN) :: isource, idest
- REAL (KIND=dbl_kind), INTENT(OUT) :: alpha_out, beta_out
-
- ! Local variables
- REAL (KIND=dbl_kind) :: a1, b1
- REAL (KIND=dbl_kind) :: xx, yy, zz
- REAL (KIND=dbl_kind) :: sx, sy, sz
-
- ! Convert to relative Cartesian coordinates
- a1 = TAN(alpha_in)
- b1 = TAN(beta_in)
-
- sz = (one + a1 * a1 + b1 * b1)**(-0.5)
- sx = sz * a1
- sy = sz * b1
-
- ! Convert to full Cartesian coordinates
- IF (isource == 6) THEN
- yy = sx; xx = -sy; zz = sz
-
- ELSEIF (isource == 5) THEN
- yy = sx; xx = sy; zz = -sz
-
- ELSEIF (isource == 1) THEN
- yy = sx; zz = sy; xx = sz
-
- ELSEIF (isource == 3) THEN
- yy = -sx; zz = sy; xx = -sz
-
- ELSEIF (isource == 2) THEN
- xx = -sx; zz = sy; yy = sz
-
- ELSEIF (isource == 4) THEN
- xx = sx; zz = sy; yy = -sz
-
- ELSE
- WRITE(*,*) 'Fatal Error: Source panel invalid in CubedSphereABPFromABP'
- WRITE(*,*) 'panel = ', isource
- STOP
- ENDIF
-
- ! Convert to relative Cartesian coordinates on destination panel
- IF (idest == 6) THEN
- sx = yy; sy = -xx; sz = zz
-
- ELSEIF (idest == 5) THEN
- sx = yy; sy = xx; sz = -zz
-
- ELSEIF (idest == 1) THEN
- sx = yy; sy = zz; sz = xx
-
- ELSEIF (idest == 3) THEN
- sx = -yy; sy = zz; sz = -xx
-
- ELSEIF (idest == 2) THEN
- sx = -xx; sy = zz; sz = yy
-
- ELSEIF (idest == 4) THEN
- sx = xx; sy = zz; sz = -yy
-
- ELSE
- WRITE(*,*) 'Fatal Error: Dest panel invalid in CubedSphereABPFromABP'
- WRITE(*,*) 'panel = ', idest
- STOP
- ENDIF
- IF (sz < 0) THEN
- WRITE(*,*) 'Fatal Error: In CubedSphereABPFromABP'
- WRITE(*,*) 'Invalid relative Z coordinate'
- STOP
- ENDIF
-
- ! Use panel information to calculate (alpha, beta) coords
- alpha_out = ATAN(sx / sz)
- beta_out = ATAN(sy / sz)
-
- END SUBROUTINE
-
-
-!------------------------------------------------------------------------------
-! FUNCTION CUBIC_EQUISPACE_INTERP
-!
-! Description:
-! Apply cubic interpolation on the specified array of values, where all
-! points are equally spaced.
-!
-! Parameters:
-! dx - Spacing of points
-! x - X coordinate where interpolation is to be applied
-! y - Array of 4 values = f(x + k * dx) where k = 0,1,2,3
-!------------------------------------------------------------------------------
- FUNCTION CUBIC_EQUISPACE_INTERP(dx, x, y)
-
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind) :: CUBIC_EQUISPACE_INTERP
- REAL (KIND=dbl_kind) :: dx, x
- REAL (KIND=dbl_kind), DIMENSION(1:4) :: y
-
- CUBIC_EQUISPACE_INTERP = &
- (-y(1) / (6.0 * dx**3)) * (x - dx) * (x - 2.0 * dx) * (x - 3.0 * dx) + &
- ( y(2) / (2.0 * dx**3)) * (x) * (x - 2.0 * dx) * (x - 3.0 * dx) + &
- (-y(3) / (2.0 * dx**3)) * (x) * (x - dx) * (x - 3.0 * dx) + &
- ( y(4) / (6.0 * dx**3)) * (x) * (x - dx) * (x - 2.0 * dx)
-
- END FUNCTION CUBIC_EQUISPACE_INTERP
-
-! FUNCTION I_10_ab(alpha,beta)
-! IMPLICIT NONE
-! REAL (KIND=dbl_kind) :: I_10_AB
-! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-! I_10_ab = -ASINH(COS(alpha) * TAN(beta))
-! END FUNCTION I_10_AB
-!!
-!
-! REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta)
-! IMPLICIT NONE
-! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-! I_01_ab = -ASINH(COS(beta) * TAN(alpha))
-! END FUNCTION I_01_AB
-!
-! REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta)
-! IMPLICIT NONE
-! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-!
-! I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta))
-! END FUNCTION I_20_AB
-!
-! REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta)
-! IMPLICIT NONE
-! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-!
-! I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta))
-! END FUNCTION I_02_AB
-!
-! REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta)
-! IMPLICIT NONE
-! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-!
-! I_11_ab = -SQRT(1.0+TAN(alpha)**2+TAN(beta)**2)
-! END FUNCTION I_11_AB
-!
-
-
-END MODULE reconstruct
-
diff --git a/tools/topo_tool/cube_to_target/remap.F90 b/tools/topo_tool/cube_to_target/remap.F90
deleted file mode 100644
index b56b7fd493..0000000000
--- a/tools/topo_tool/cube_to_target/remap.F90
+++ /dev/null
@@ -1,1561 +0,0 @@
-MODULE remap
- INTEGER, PARAMETER :: &
- int_kind = KIND(1), &
- real_kind = SELECTED_REAL_KIND(p=14,r=100),&
- dbl_kind = selected_real_kind(13)
-
- INTEGER :: nc,nhe
-
-! LOGICAL, PARAMETER:: ldbgr_r = .FALSE.
- LOGICAL :: ldbgr
- LOGICAL :: ldbg_global
-
- REAL(kind=real_kind), PARAMETER :: &
- one = 1.0 ,&
- aa = 1.0 ,&
- tiny= 1.0E-9 ,&
- bignum = 1.0E20
- REAL (KIND=dbl_kind), parameter :: fuzzy_width = 10.0*tiny !CAM-SE add
-
- contains
-
-
- subroutine compute_weights_cell(xcell_in,ycell_in,jx,jy,nreconstruction,xgno,ygno,&
- jx_min, jx_max, jy_min, jy_max,tmp,&
- ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,&
- nc_in,nhe_in,nvertex,ldbg)
-
- implicit none
- integer (kind=int_kind) , intent(in):: nreconstruction, jx,jy,ngauss,jmax_segments
- real (kind=real_kind) , dimension(0:nvertex+1) :: xcell_in,ycell_in
-! real (kind=real_kind) , dimension(0:5), intent(in):: xcell_in,ycell_in
- integer (kind=int_kind), intent(in) :: nc_in,nhe_in,nvertex
- logical, intent(in) :: ldbg
- !
- ! ipanel is just for debugging
- !
- integer (kind=int_kind), intent(in) :: jx_min, jy_min, jx_max, jy_max
- real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: xgno
- real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: ygno
- !
- ! for Gaussian quadrature
- !
- real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae
- !
- ! boundaries of domain
- !
- real (kind=real_kind):: tmp
- !
- ! Number of Eulerian sub-cell integrals for the cell in question
- !
- integer (kind=int_kind), intent(out) :: jcollect
- !
- ! local workspace
- !
- !
- ! max number of line segments is:
- !
- ! (number of longitudes)*(max average number of crossings per line segment = 3)*ncube*2
- !
- real (kind=real_kind) , &
- dimension(jmax_segments,nreconstruction), intent(out) :: weights
- integer (kind=int_kind), &
- dimension(jmax_segments,2), intent(out) :: weights_eul_index
-
- real (kind=real_kind), dimension(0:3) :: x,y
- integer (kind=int_kind),dimension(0:5) :: jx_eul, jy_eul
- integer (kind=int_kind) :: jsegment,i
- !
- ! variables for registering crossings with Eulerian latitudes and longitudes
- !
- integer (kind=int_kind) :: jcross_lat, iter
- !
- ! max. crossings per side is 2*nhe
- !
- real (kind=real_kind), &
- dimension(jmax_segments,2) :: r_cross_lat
- integer (kind=int_kind), &
- dimension(jmax_segments,2) :: cross_lat_eul_index
- real (kind=real_kind) , dimension(1:nvertex) :: xcell,ycell
-
- real (kind=real_kind) :: eps
-
- ldbg_global = ldbg
- ldbgr = ldbg
-
- nc = nc_in
- nhe = nhe_in
-
- xcell = xcell_in(1:nvertex)
- ycell = ycell_in(1:nvertex)
-
-
- !
- ! this is to avoid ill-conditioning problems
- !
- eps = 1.0E-9
-
- jsegment = 0
- weights = 0.0D0
- jcross_lat = 0
- !
- !**********************
- !
- ! Integrate cell sides
- !
- !**********************
-
-
- IF (jx<-nhe.OR.jx>nc+1+nhe.OR.jy<-nhe.OR.jy>nc+1+nhe) THEN
- WRITE(*,*) "jx,jy,-nhe,nc+1+nhe",jx,jy,-nhe,nc+1+nhe
- STOP
- END IF
-
-
- call side_integral(xcell,ycell,nvertex,jsegment,jmax_segments,&
- weights,weights_eul_index,nreconstruction,jx,jy,xgno,ygno,jx_min, jx_max, jy_min, jy_max,&
- ngauss,gauss_weights,abscissae,&
- jcross_lat,r_cross_lat,cross_lat_eul_index)
-
- !
- !**********************
- !
- ! Do inner integrals
- !
- !**********************
- !
- call compute_inner_line_integrals_lat_nonconvex(r_cross_lat,cross_lat_eul_index,&
- jcross_lat,jsegment,jmax_segments,xgno,jx_min, jx_max, jy_min, jy_max,&
- weights,weights_eul_index,&
- nreconstruction,ngauss,gauss_weights,abscissae)
- !
- ! collect line-segment that reside in the same Eulerian cell
- !
- if (jsegment>0) then
- call collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments)
- !
- ! DBG
- !
- tmp=0.0
- do i=1,jcollect
- tmp=tmp+weights(i,1)
- enddo
-
- IF (abs(tmp)>0.01) THEN
- WRITE(*,*) "sum of weights too large",tmp
- stop
- END IF
- IF (tmp<-1.0E-9) THEN
- WRITE(*,*) "sum of weights is negative - negative area?",tmp,jx,jy
- ! ldbgr=.TRUE.
- stop
- END IF
- else
- jcollect = 0
- end if
- end subroutine compute_weights_cell
-
-
- !
- !****************************************************************************
- !
- ! organize data and store it
- !
- !****************************************************************************
- !
- subroutine collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments)
- implicit none
- integer (kind=int_kind) , intent(in) :: nreconstruction
- real (kind=real_kind) , dimension(jmax_segments,nreconstruction), intent(inout) :: weights
- integer (kind=int_kind), dimension(jmax_segments,2 ), intent(inout) :: weights_eul_index
- integer (kind=int_kind), INTENT(OUT ) :: jcollect
- integer (kind=int_kind), INTENT(IN ) :: jsegment,jmax_segments
- !
- ! local workspace
- !
- integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k,h
- logical :: ltmp
-
- real (kind=real_kind) , dimension(jmax_segments,nreconstruction) :: weights_out
- integer (kind=int_kind), dimension(jmax_segments,2 ) :: weights_eul_index_out
-
- weights_out = 0.0D0
- weights_eul_index_out = -100
-
- imin = MINVAL(weights_eul_index(1:jsegment,1))
- imax = MAXVAL(weights_eul_index(1:jsegment,1))
- jmin = MINVAL(weights_eul_index(1:jsegment,2))
- jmax = MAXVAL(weights_eul_index(1:jsegment,2))
-
- ltmp = .FALSE.
-
- jcollect = 1
-
- do j=jmin,jmax
- do i=imin,imax
- do k=1,jsegment
- if (weights_eul_index(k,1)==i.AND.weights_eul_index(k,2)==j) then
- weights_out(jcollect,1:nreconstruction) = &
- weights_out(jcollect,1:nreconstruction) + weights(k,1:nreconstruction)
- ltmp = .TRUE.
- h = k
- endif
- enddo
- if (ltmp) then
- weights_eul_index_out(jcollect,:) = weights_eul_index(h,:)
- jcollect = jcollect+1
- endif
- ltmp = .FALSE.
- enddo
- enddo
- jcollect = jcollect-1
- weights = weights_out
- weights_eul_index = weights_eul_index_out
- end subroutine collect
- !
- !*****************************************************************************************
- !
- !
- !
- !*****************************************************************************************
- !
- subroutine compute_inner_line_integrals_lat(r_cross_lat,cross_lat_eul_index,&
- jcross_lat,jsegment,jmax_segments,xgno,jx_min,jx_max,jy_min, jy_max,weights,weights_eul_index,&
- nreconstruction,ngauss,gauss_weights,abscissae)!phl add jx_min etc.
- implicit none
- !
- ! for Gaussian quadrature
- !
- real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae
- !
- ! variables for registering crossings with Eulerian latitudes and longitudes
- !
- integer (kind=int_kind), intent(in):: jcross_lat, jmax_segments,nreconstruction,ngauss
- integer (kind=int_kind), intent(inout):: jsegment
- !
- ! max. crossings per side is 2*nhe
- !
- real (kind=real_kind), &
- dimension(jmax_segments,2), intent(in):: r_cross_lat
- integer (kind=int_kind), &
- dimension(jmax_segments,2), intent(in):: cross_lat_eul_index
- integer (kind=int_kind), intent(in) ::jx_min, jx_max, jy_min, jy_max
- real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: xgno
- real (kind=real_kind) , &
- dimension(jmax_segments,nreconstruction), intent(inout) :: weights
- integer (kind=int_kind), &
- dimension(jmax_segments,2), intent(inout) :: weights_eul_index
- real (kind=real_kind) , dimension(nreconstruction) :: weights_tmp
-
- integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k, isgn, h, eul_jx, eul_jy
- integer (kind=int_kind) :: idx_start_y,idx_end_y
- logical :: ltmp,lcontinue
- real (kind=real_kind), dimension(2) :: rstart,rend,rend_tmp
- real (kind=real_kind), dimension(2) :: xseg, yseg
-5 FORMAT(10e14.6)
-
-
- if (jcross_lat>0) then
- do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2))
- !
- ! find "first" crossing with Eulerian cell i
- !
- do k=1,jcross_lat
- if (cross_lat_eul_index(k,2)==i) exit
- enddo
- do j=k+1,jcross_lat
- !
- ! find "second" crossing with Eulerian cell i
- !
- if (cross_lat_eul_index(j,2)==i) then
- if (r_cross_lat(k,1)0) then
- do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2))
- ! WRITE(*,*) "looking at latitude ",i !xxxx
- count = 1
- !
- ! find all crossings with Eulerian latitude i
- !
- do k=1,jcross_lat
- if (cross_lat_eul_index(k,2)==i) then
- ! WRITE(*,*) "other crossings with latitude",i ," is ",k!xxxx
- r_cross_lat_seg (count,:) = r_cross_lat (k,:)
- cross_lat_eul_index_seg(count,:) = cross_lat_eul_index(k,:)
-
- IF (ldbg_global) then
- WRITE(*,*) r_cross_lat_seg(count,1),r_cross_lat_seg(count,2)
- WRITE(*,*) " "
- END IF
- count = count+1
- end if
- enddo
- count = count-1
- IF (ABS((count/2)-DBLE(count)/2.0)1000) THEN
- WRITE(*,*) "search not converging",iter
- STOP
- END IF
- lsame_cell_x = (x(2).GE.xgno(jx_eul).AND.x(2).LE.xgno(jx_eul+1))
- lsame_cell_y = (y(2).GE.ygno(jy_eul).AND.y(2).LE.ygno(jy_eul+1))
-! IF (ldbgr) WRITE(*,*) "lsame_cell_x,lsame_cell_y=",lsame_cell_x,lsame_cell_y
- IF (lsame_cell_x.AND.lsame_cell_y) THEN
- !
- !****************************
- !
- ! same cell integral
- !
- !****************************
- !
-! IF (ldbgr) WRITE(*,*) "same cell integral",jx_eul,jy_eul
- xseg(1) = x(1); yseg(1) = y(1); xseg(2) = x(2); yseg(2) = y(2)
- jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul;
- lcontinue = .FALSE.
- !
- ! prepare for next side if (x(2),y(2)) is on a grid line
- !
- IF (x(2).EQ.xgno(jx_eul+1).AND.x(3)>xgno(jx_eul+1)) THEN
- !
- ! cross longitude jx_eul+1
- !
-! IF (ldbgr) WRITE(*,*) "cross longitude",jx_eul+1
- jx_eul=jx_eul+1
- ELSE IF (x(2).EQ.xgno(jx_eul ).AND.x(3)ygno(jy_eul+1)) THEN
- !
- ! register crossing with latitude: line-segments point Northward
- !
- jcross_lat = jcross_lat + 1
- jy_eul = jy_eul + 1
-! IF (ldbgr) WRITE(*,*) "cross latitude",jy_eul
- cross_lat_eul_index(jcross_lat,1) = jx_eul
- cross_lat_eul_index(jcross_lat,2) = jy_eul
- r_cross_lat(jcross_lat,1) = x(2)
- r_cross_lat(jcross_lat,2) = y(2)
- ELSE IF (y(2).EQ.ygno(jy_eul ).AND.y(3)y(1) else "0"
- ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1"
- !
- !*******************************************************************************
- !
- ! there is at least one crossing with latitudes but no crossing with longitudes
- !
- !*******************************************************************************
- !
- yeul = ygno(jy_eul+ysgn1)
- IF (x(1).EQ.x(2)) THEN
- !
- ! line segment is parallel to longitude (infinite slope)
- !
-! IF (ldbgr) WRITE(*,*) "line segment parallel to longitude"
- xcross = x(1)
- ELSE
- slope = (y(2)-y(1))/(x(2)-x(1))
- xcross = x_cross_eul_lat(x(1),y(1),yeul,slope)
- !
- ! constrain crossing to be "physically" possible
- !
- xcross = MIN(MAX(xcross,xgno(jx_eul)),xgno(jx_eul+1))
-
-
-! IF (ldbgr) WRITE(*,*) "cross latitude"
- !
- ! debugging
- !
- IF (xcross.GT.xgno(jx_eul+1).OR.xcross.LT.xgno(jx_eul)) THEN
- WRITE(*,*) "xcross is out of range",jx,jy
- WRITE(*,*) "xcross-xgno(jx_eul+1), xcross-xgno(jx_eul))",&
- xcross-xgno(jx_eul+1), xcross-ygno(jx_eul)
- STOP
- END IF
- END IF
- xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul
- jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul;
- !
- ! prepare for next iteration
- !
- x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2
- !
- ! register crossing with latitude
- !
- jcross_lat = jcross_lat+1
- cross_lat_eul_index(jcross_lat,1) = jx_eul
- if (ysgn2>0) then
- cross_lat_eul_index(jcross_lat,2) = jy_eul
- else
- cross_lat_eul_index(jcross_lat,2) = jy_eul+1
- end if
- r_cross_lat(jcross_lat,1) = xcross
- r_cross_lat(jcross_lat,2) = yeul
- ELSE IF (lsame_cell_y) THEN
-! IF (ldbgr) WRITE(*,*) "same cell y"
- !
- !*******************************************************************************
- !
- ! there is at least one crossing with longitudes but no crossing with latitudes
- !
- !*******************************************************************************
- !
- xsgn1 = (1+INT(SIGN(1.0D0,x(2)-x(1))))/2 !"1" if x(2)>x(1) else "0"
- xsgn2 = INT(SIGN(1.0D0,x(2)-x(1))) !"1" if x(2)>x(1) else "-1"
- xeul = xgno(jx_eul+xsgn1)
-! IF (ldbgr) WRITE(*,*) " crossing longitude",jx_eul+xsgn1
- IF (ABS(x(2)-x(1))x(1) else "0"
- xsgn2 = (INT(SIGN(1.0D0,x(2)-x(1)))) !"1" if x(2)>x(1) else "0"
- xeul = xgno(jx_eul+xsgn1)
- ysgn1 = (1+INT(SIGN(1.0D0,y(2)-y(1))))/2 !"1" if y(2)>y(1) else "0"
- ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1"
- yeul = ygno(jy_eul+ysgn1)
-
- slope = (y(2)-y(1))/(x(2)-x(1))
- IF (ABS(x(2)-x(1))0.AND.xcross.LE.xeul).OR.(xsgn2<0.AND.xcross.GE.xeul)) THEN
- !
- ! cross latitude
- !
-! IF (ldbgr) WRITE(*,*) "crossing latitude",jy_eul+ysgn1
- xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul
- jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul;
- !
- ! prepare for next iteration
- !
- x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2
- !
- ! register crossing with latitude
- !
- jcross_lat = jcross_lat+1
- cross_lat_eul_index(jcross_lat,1) = jx_eul
- if (ysgn2>0) then
- cross_lat_eul_index(jcross_lat,2) = jy_eul
- else
- cross_lat_eul_index(jcross_lat,2) = jy_eul+1
- end if
- r_cross_lat(jcross_lat,1) = xcross
- r_cross_lat(jcross_lat,2) = yeul
- ELSE
- !
- ! cross longitude
- !
-! IF (ldbgr) WRITE(*,*) "crossing longitude",jx_eul+xsgn1
- xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xeul; yseg(2) = ycross
- jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul;
- !
- ! prepare for next iteration
- !
- x(0) = x(1); y(0) = y(1); x(1) = xeul; y(1) = ycross; jx_eul = jx_eul+xsgn2
- END IF
-
- END IF
- END IF
- !
- ! register line-segment (don't register line-segment if outside of panel)
- !
- if (jx_eul_tmp>=jx_min.AND.jy_eul_tmp>=jy_min.AND.&
- jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1) then
- ! jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1.AND.side_count<3) then
- jsegment=jsegment+1
- weights_eul_index(jsegment,1) = jx_eul_tmp
- weights_eul_index(jsegment,2) = jy_eul_tmp
- call get_weights_gauss(weights(jsegment,1:nreconstruction),&
- xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae)
-
-! if (ldbg_global) then
-! OPEN(unit=40, file='side_integral.dat',status='old',access='append')
-! WRITE(40,*) xseg(1),yseg(1)
-! WRITE(40,*) xseg(2),yseg(2)
-! WRITE(40,*) " "
-! CLOSE(40)
-! end if
-
-
- jdbg=jdbg+1
-
- if (xseg(1).EQ.xseg(2))then
- slope = bignum
- else if (abs(yseg(1) -yseg(2))0) THEN
- compute_slope = (y(2)-y(1))/(x(2)-x(1))
- else
- compute_slope = bignum
- end if
- end function compute_slope
-
- real (kind=real_kind) function y_cross_eul_lon(x,y,xeul,slope)
- implicit none
- real (kind=real_kind), intent(in) :: x,y
- real (kind=real_kind) , intent(in) :: xeul,slope
- ! line: y=a*x+b
- real (kind=real_kind) :: a,b
- b = y-slope*x
- y_cross_eul_lon = slope*xeul+b
- end function y_cross_eul_lon
-
- real (kind=real_kind) function x_cross_eul_lat(x,y,yeul,slope)
- implicit none
- real (kind=real_kind), intent(in) :: x,y
- real (kind=real_kind) , intent(in) :: yeul,slope
-
- if (fuzzy(ABS(slope),fuzzy_width)>0) THEN
- x_cross_eul_lat = x+(yeul-y)/slope
- ELSE
- ! WRITE(*,*) "WARNING: slope is epsilon - ABORT"
- x_cross_eul_lat = bignum
- END IF
- end function x_cross_eul_lat
-
- subroutine get_weights_exact(weights,xseg,yseg,nreconstruction)
-! use cslam_analytic_mod, only: I_00, I_10, I_01, I_20, I_02, I_11
- implicit none
- integer (kind=int_kind), intent(in) :: nreconstruction
- real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights
- real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg
- !
- ! compute weights
- !
- real (kind=real_kind) :: tmp,slope,b,integral,dx2,xc
- integer (kind=int_kind) :: i
-! weights(:) = -half*(xseg(1)*yseg(2)-xseg(2)*yseg(1)) !dummy for testing
-
- weights(1) = ((I_00(xseg(2),yseg(2))-I_00(xseg(1),yseg(1))))
- if (ABS(weights(1))>1.0) THEN
- WRITE(*,*) "1 exact weights(jsegment)",weights(1),xseg,yseg
- stop
- end if
- if (nreconstruction>1) then
- weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1))))
- weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1))))
- endif
- if (nreconstruction>3) then
- weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1))))
- weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1))))
- weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1))))
- endif
-
- end subroutine get_weights_exact
-
-
-
- subroutine get_weights_gauss(weights,xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae)
- implicit none
- integer (kind=int_kind), intent(in) :: nreconstruction,ngauss
- real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights
- real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg
- real (kind=real_kind) :: slope
- !
- ! compute weights
- !
- !
- ! for Gaussian quadrature
- !
- real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae
-
- ! if line-segment parallel to x or y use exact formulaes else use qudrature
- !
- real (kind=real_kind) :: tmp,b,integral,dx2,xc,x,y
- integer (kind=int_kind) :: i
-
-
-
-
-! if (fuzzy(abs(xseg(1) -xseg(2)),fuzzy_width)==0)then
- if (xseg(1).EQ.xseg(2))then
- weights = 0.0D0
- else if (abs(yseg(1) -yseg(2))1) then
- weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1))))
- weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1))))
- endif
- if (nreconstruction>3) then
- weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1))))
- weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1))))
- weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1))))
- endif
- else
-
-
- slope = (yseg(2)-yseg(1))/(xseg(2)-xseg(1))
- b = yseg(1)-slope*xseg(1)
- dx2 = 0.5D0*(xseg(2)-xseg(1))
- if (ldbgr) WRITE(*,*) "dx2 and slope in gauss weight",dx2,slope
- xc = 0.5D0*(xseg(1)+xseg(2))
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_00(x,y)
- enddo
- weights(1) = integral*dx2
- if (nreconstruction>1) then
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_10(x,y)
- enddo
- weights(2) = integral*dx2
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_01(x,y)
- enddo
- weights(3) = integral*dx2
- endif
- if (nreconstruction>3) then
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_20(x,y)
- enddo
- weights(4) = integral*dx2
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_02(x,y)
- enddo
- weights(5) = integral*dx2
- integral = 0.0D0
- do i=1,ngauss
- x = xc+abscissae(i)*dx2
- y = slope*x+b
- integral = integral+gauss_weights(i)*F_11(x,y)
- enddo
- weights(6) = integral*dx2
- endif
- end if
- end subroutine get_weights_gauss
-
- real (kind=real_kind) function F_00(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,tmp
-
- x = x_in
- y = y_in
-
- F_00 =y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y))
- end function F_00
-
- real (kind=real_kind) function F_10(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,tmp
-
- x = x_in
- y = y_in
-
- F_10 =x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y))
- end function F_10
-
- real (kind=real_kind) function F_01(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,tmp
-
- x = x_in
- y = y_in
-
- F_01 =-1.0D0/(SQRT(1.0D0+x*x+y*y))
- end function F_01
-
- real (kind=real_kind) function F_20(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,tmp
-
- x = x_in
- y = y_in
-
- F_20 =x*x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y))
- end function F_20
-
- real (kind=real_kind) function F_02(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,alpha, tmp
-
- x = x_in
- y = y_in
-
- alpha = ATAN(x)
- tmp=y*COS(alpha)
- F_02 =-y/SQRT(1.0D0+x*x+y*y)+log(tmp+sqrt(tmp*tmp+1))
-
- !
- ! cos(alpha) = 1/sqrt(1+x*x)
- !
- end function F_02
-
- real (kind=real_kind) function F_11(x_in,y_in)
- implicit none
- real (kind=real_kind), intent(in) :: x_in,y_in
- real (kind=real_kind) :: x,y,tmp
-
- x = x_in
- y = y_in
-
- F_11 =-x/(SQRT(1.0D0+x*x+y*y))
- end function F_11
-
- subroutine which_eul_cell(x,j_eul,gno)
- implicit none
- integer (kind=int_kind) , intent(inout) :: j_eul
- real (kind=real_kind), dimension(3) , intent(in) :: x
- real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl
-! real (kind=real_kind), intent(in) :: eps
-
- real (kind=real_kind) :: d1,d2,d3,d1p1
- logical :: lcontinue
- integer :: iter
-
-
- !
- ! this is not needed in transport code search
- !
-! IF (x(1)gno(nc+2+nhe)) j_eul=nc+1+nhe
-! RETURN
-
-! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added
-
- lcontinue = .TRUE.
- iter = 0
- IF (ldbgr) WRITE(*,*) "from which_eul_cell",x(1),x(2),x(3)
- DO WHILE (lcontinue)
- iter = iter+1
- IF (x(1).GE.gno(j_eul).AND.x(1).LT.gno(j_eul+1)) THEN
- lcontinue = .FALSE.
- !
- ! special case when x(1) is on top of grid line
- !
- IF (x(1).EQ.gno(j_eul)) THEN
-! IF (ABS(x(1)-gno(j_eul))1000.OR.j_eul<-nhe.OR.j_eul>nc+2+nhe) THEN
- WRITE(*,*) "search in which_eul_cell not converging!", iter,j_eul
- WRITE(*,*) "input", x
- WRITE(*,*) "gno", gno(nc),gno(nc+1),gno(nc+2),gno(nc+3)
- STOP
- END IF
- END DO
- END subroutine which_eul_cell
-
-
- subroutine truncate_vertex(x,j_eul,gno)
- implicit none
- integer (kind=int_kind) , intent(inout) :: j_eul
- real (kind=real_kind) , intent(inout) :: x
- real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl
-! real (kind=real_kind), intent(in) :: eps
-
- logical :: lcontinue
- integer :: iter
- real (kind=real_kind) :: xsgn,dist,dist_new,tmp
-
- !
- ! this is not needed in transport code search
- !
-! IF (xgno(nc+2+nhe)) j_eul=nc+1+nhe
-!
-! RETURN
-
-
- lcontinue = .TRUE.
- iter = 0
- dist = bignum
-! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added
- xsgn = INT(SIGN(1.0_dbl_kind,x-gno(j_eul)))
- DO WHILE (lcontinue)
- iter = iter+1
- tmp = x-gno(j_eul)
- dist_new = ABS(tmp)
- IF (dist_new>dist) THEN
- lcontinue = .FALSE.
-! ELSE IF (ABS(tmp)<1.0E-11) THEN
- ELSE IF (ABS(tmp)<1.0E-9) THEN
-! ELSE IF (ABS(tmp)<1.0E-4) THEN
- x = gno(j_eul)
- lcontinue = .FALSE.
- ELSE
- j_eul = j_eul+xsgn
- dist = dist_new
- END IF
- IF (iter>10000) THEN
- WRITE(*,*) "truncate vertex not converging"
- STOP
- END IF
- END DO
- END subroutine truncate_vertex
-
-
-
-
-!********************************************************************************
-!
-! Gauss-Legendre quadrature
-!
-! Tabulated values
-!
-!********************************************************************************
-subroutine gauss_points(n,weights,points)
- implicit none
- real (kind=real_kind), dimension(n), intent(out) :: weights, points
- integer (kind=int_kind) , intent(in ) :: n
-
- select case (n)
-! CASE(1)
-! abscissae(1) = 0.0D0
-! weights(1) = 2.0D0
- case(2)
- points(1) = -sqrt(1.0D0/3.0D0)
- points(2) = sqrt(1.0D0/3.0D0)
- weights(1) = 1.0D0
- weights(2) = 1.0D0
- case(3)
- points(1) = -0.774596669241483377035853079956D0
- points(2) = 0.0D0
- points(3) = 0.774596669241483377035853079956D0
- weights(1) = 0.555555555555555555555555555556D0
- weights(2) = 0.888888888888888888888888888889D0
- weights(3) = 0.555555555555555555555555555556D0
- case(4)
- points(1) = -0.861136311594052575223946488893D0
- points(2) = -0.339981043584856264802665659103D0
- points(3) = 0.339981043584856264802665659103D0
- points(4) = 0.861136311594052575223946488893D0
- weights(1) = 0.347854845137453857373063949222D0
- weights(2) = 0.652145154862546142626936050778D0
- weights(3) = 0.652145154862546142626936050778D0
- weights(4) = 0.347854845137453857373063949222D0
- case(5)
- points(1) = -(1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0))
- points(2) = -(1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0))
- points(3) = 0.0D0
- points(4) = (1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0))
- points(5) = (1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0))
- weights(1) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0
- weights(2) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0
- weights(3) = 128.0D0/225.0D0
- weights(4) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0
- weights(5) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0
- case default
- write(*,*) 'n out of range in glwp of module gll. n=',n
- write(*,*) '0 0.0D0) THEN
- signum = 1.0D0
- ELSEIF (x < 0.0D0) THEN
- signum = -1.0D0
- ELSE
- signum = 0.0D0
- ENDIF
- end function
-
-!------------------------------------------------------------------------------
-! FUNCTION SIGNUM_FUZZY
-!
-! Description:
-! Gives the sign of the given real number, returning zero if x is within
-! a small amount from zero.
-!------------------------------------------------------------------------------
- function signum_fuzzy(x)
- implicit none
-
- real (kind=real_kind) :: signum_fuzzy
- real (kind=real_kind) :: x
-
- IF (x > fuzzy_width) THEN
- signum_fuzzy = 1.0D0
- ELSEIF (x < fuzzy_width) THEN
- signum_fuzzy = -1.0D0
- ELSE
- signum_fuzzy = 0.0D0
- ENDIF
- end function
-
- function fuzzy(x,epsilon)
- implicit none
-
- integer (kind=int_kind) :: fuzzy
- real (kind=real_kind), intent(in) :: epsilon
- real (kind=real_kind) :: x
-
- IF (ABS(x)epsilon) THEN
- fuzzy = 1
- ELSE !IF (x < fuzzy_width) THEN
- fuzzy = -1
- ENDIF
- end function
-
-!
-! see, e.g., http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/
-!
-subroutine check_lines_cross(x1,x2,x3,x4,y1,y2,y3,y4,lcross)
- implicit none
- real (kind=real_kind), INTENT(IN) :: x1,x2,x3,x4,y1,y2,y3,y4
- LOGICAL, INTENT(OUT) :: lcross
- !
- ! local workspace
- !
- real (kind=real_kind) :: cp,tx,ty
-
- cp = (y4-y3)*(x2-x1)-(x4-x3)*(y2-y1)
- IF (ABS(cp)-tiny.AND.tx<1.0D0+tiny.AND.&
- ty>-tiny.AND.ty<1.0D0+tiny) THEN
- lcross = .TRUE.
- ELSE
- lcross = .FALSE.
-! WRITE(*,*) "not parallel but not crossing,",tx,ty
- ENDIF
- ENDIF
-end subroutine check_lines_cross
-
-
- REAL (KIND=dbl_kind) FUNCTION I_00(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y
-
- x = x_in/aa
- y = y_in/aa
-! x = x_in
-! y = y_in
- I_00 = ATAN(x*y/SQRT(one+x*x+y*y))
- END FUNCTION I_00
-
- REAL (KIND=dbl_kind) FUNCTION I_10(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y,tmp
-
- x = x_in/aa
- y = y_in/aa
- tmp = ATAN(x)
- I_10 = -ASINH(y*COS(tmp))
- !
- ! = -arcsinh(y/sqrt(1+x^2))
- !
- END FUNCTION I_10
-
- REAL (KIND=dbl_kind) FUNCTION I_10_ab(alpha,beta)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
- I_10_ab = -ASINH(COS(alpha) * TAN(beta))
- END FUNCTION I_10_AB
-
- REAL (KIND=dbl_kind) FUNCTION I_01(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y!,beta
-
- x = x_in/aa
- y = y_in/aa
-! beta = ATAN(y)
-! I_01 = -ASINH(x*COS(beta))
- I_01 = -ASINH(x/SQRT(1+y*y))
- END FUNCTION I_01
-
- REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
- I_01_ab = -ASINH(COS(beta) * TAN(alpha))
- END FUNCTION I_01_AB
-
- REAL (KIND=dbl_kind) FUNCTION I_20(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta
-
- x = x_in/aa
- y = y_in/aa
-! alpha = aa*ATAN(x)
-! beta = aa*ATAN(y)
-
- tmp = one+y*y
-
-! I_20 = y*ASINH(COS(beta)*x)+ACOS(SIN(alpha)*SIN(beta))
- I_20 = y*ASINH(x/SQRT(tmp))+ACOS(x*y/(SQRT((one+x*x)*tmp)))
- END FUNCTION I_20
-
- REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-
- I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta))
- END FUNCTION I_20_AB
-
- REAL (KIND=dbl_kind) FUNCTION I_02(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta
-
- x = x_in/aa
- y = y_in/aa
-! alpha = aa*ATAN(x)
-! beta = aa*ATAN(y)
-
- tmp=one+x*x
-
- I_02 = x*ASINH(y/SQRT(tmp))+ACOS(x*y/SQRT(tmp*(1+y*y)))
- END FUNCTION I_02
-
- REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-
- I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta))
- END FUNCTION I_02_AB
-
-
- REAL (KIND=dbl_kind) FUNCTION I_11(x_in,y_in)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in
- REAL (KIND=dbl_kind) :: x,y
-
- x = x_in/aa
- y = y_in/aa
-
- I_11 = -SQRT(1+x*x+y*y)
- END FUNCTION I_11
-
- REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta
-
- I_11_ab = -SQRT(one+TAN(alpha)**2+TAN(beta)**2)
- END FUNCTION I_11_AB
-!------------------------------------------------------------------------------
-! FUNCTION ASINH
-!
-! Description:
-! Hyperbolic arcsin function
-!------------------------------------------------------------------------------
- FUNCTION ASINH(x)
- IMPLICIT NONE
-
- REAL (KIND=dbl_kind) :: ASINH
- REAL (KIND=dbl_kind) :: x
-
- ASINH = LOG(x + SQRT(x * x + one))
- END FUNCTION
-
-
- !********************************************************************************
- !
- ! Gauss-Legendre quadrature
- !
- ! Tabulated values
- !
- !********************************************************************************
- SUBROUTINE glwp(n,weights,abscissae)
- IMPLICIT NONE
- REAL (KIND=dbl_kind), DIMENSION(n), INTENT(OUT) :: weights, abscissae
- INTEGER (KIND=int_kind) , INTENT(IN ) :: n
-
- SELECT CASE (n)
- CASE(1)
- abscissae(1) = 0.0
- weights(1) = 2.0
- CASE(2)
- abscissae(1) = -SQRT(1.0/3.0)
- abscissae(2) = SQRT(1.0/3.0)
- weights(1) = 1.0
- weights(2) = 1.0
- CASE(3)
- abscissae(1) = -0.774596669241483377035853079956_dbl_kind
- abscissae(2) = 0.0
- abscissae(3) = 0.774596669241483377035853079956_dbl_kind
- weights(1) = 0.555555555555555555555555555556_dbl_kind
- weights(2) = 0.888888888888888888888888888889_dbl_kind
- weights(3) = 0.555555555555555555555555555556_dbl_kind
- CASE(4)
- abscissae(1) = -0.861136311594052575223946488893_dbl_kind
- abscissae(2) = -0.339981043584856264802665659103_dbl_kind
- abscissae(3) = 0.339981043584856264802665659103_dbl_kind
- abscissae(4) = 0.861136311594052575223946488893_dbl_kind
- weights(1) = 0.347854845137453857373063949222_dbl_kind
- weights(2) = 0.652145154862546142626936050778_dbl_kind
- weights(3) = 0.652145154862546142626936050778_dbl_kind
- weights(4) = 0.347854845137453857373063949222_dbl_kind
- CASE(5)
- abscissae(1) = -(1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0))
- abscissae(2) = -(1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0))
- abscissae(3) = 0.0
- abscissae(4) = (1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0))
- abscissae(5) = (1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0))
- weights(1) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind
- weights(2) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind
- weights(3) = 128.0_dbl_kind/225.0_dbl_kind
- weights(4) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind
- weights(5) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind
- CASE DEFAULT
- WRITE(*,*) 'n out of range in glwp of module gll. n=',n
- WRITE(*,*) '0 shr_kind_r8
- implicit none
-!
- integer, parameter :: ntile = 33 ! number of tiles in USGS GTOPO30 dataset
- integer, parameter :: im = 43200 ! total grids in x direction of 30-sec global dataset
- integer, parameter :: jm = 21600 ! total grids in y direction of 30-sec global dataset
- real(r8), parameter :: dx = 1.0/120.0 ! space interval for 30-sec data (in degree)
-
- character (len=7) :: nmtile(ntile) ! name of each tile
- integer :: ncols,nrows ! number of columns and rows for 30-sec tile
- integer :: nodata ! integer for ocean point
- real(r8):: ulxmap ! longitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8):: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8):: lon_start ! longitude at the center of grid (1,1) in the 30-sec netCDF global data
- real(r8):: lat_start ! latitude at the center of grid (1,1) in the 30-sec netCDF global data
- real(r8):: lonsw ! longitude at the center of southwest corner cell in the 30-sec tile
- real(r8):: latsw ! latitude at the center of southwest corner cell in the 30-sec tile
- integer :: i1,j1 ! the (i,j) point of the southwest corner of the 30-sec tile in the global grid
-
- integer*2, allocatable, dimension(:,:) :: terr ! global 30-sec terrain data
- integer*1, allocatable, dimension(:,:) :: land_fraction ! global 30-sec land fraction
-
- integer :: alloc_error,dealloc_error
- integer :: i,j,n ! index
- integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile
- integer*2, allocatable, dimension(:,:) :: terr_tile ! terrain data for 30-sec tile
- integer*1, allocatable, dimension(:,:) :: land_fraction_tile
-!
- lat_start=-90.0 + 0.5 * dx
- lon_start=0.5*dx
- !
- ! Initialize each tile name
- !
- nmtile(1) = 'W180N90'
- nmtile(2) = 'W140N90'
- nmtile(3) = 'W100N90'
- nmtile(4) = 'W060N90'
- nmtile(5) = 'W020N90'
- nmtile(6) = 'E020N90'
- nmtile(7) = 'E060N90'
- nmtile(8) = 'E100N90'
- nmtile(9) = 'E140N90'
-
- nmtile(10) = 'W180N40'
- nmtile(11) = 'W140N40'
- nmtile(12) = 'W100N40'
- nmtile(13) = 'W060N40'
- nmtile(14) = 'W020N40'
- nmtile(15) = 'E020N40'
- nmtile(16) = 'E060N40'
- nmtile(17) = 'E100N40'
- nmtile(18) = 'E140N40'
-
- nmtile(19) = 'W180S10'
- nmtile(20) = 'W140S10'
- nmtile(21) = 'W100S10'
- nmtile(22) = 'W060S10'
- nmtile(23) = 'W020S10'
- nmtile(24) = 'E020S10'
- nmtile(25) = 'E060S10'
- nmtile(26) = 'E100S10'
- nmtile(27) = 'E140S10'
-
- nmtile(28) = 'W180S60'
- nmtile(29) = 'W120S60'
- nmtile(30) = 'W060S60'
- nmtile(31) = 'W000S60'
- nmtile(32) = 'E060S60'
- nmtile(33) = 'E120S60'
-
-
- allocate ( land_fraction(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for land_fraction'
- stop
- end if
-
- allocate ( terr(im,jm),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr'
- stop
- end if
-
- do j = 1, jm
- do i = 1, im
- terr(i,j) = -999999.0
- land_fraction(i,j) = -99.0
- end do
- end do
-
- do n = 1,ntile
-!
-! Read header for each tile
-!
- call rdheader(nmtile(n),nrows,ncols,nodata,ulxmap,ulymap)
-
-!
-! Allocate space for array iterr
-!
- allocate ( iterr(ncols,nrows),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for iterr'
- stop
- end if
-!
-! Read terr data for each tile
-!
- call rdterr(nmtile(n),nrows,ncols,iterr)
-!
-! Allocate space for arrays terr_tile and psea10m
-!
- allocate ( terr_tile(ncols,nrows),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for terr_tile'
- stop
- end if
- allocate ( land_fraction_tile(ncols,nrows),stat=alloc_error )
- if( alloc_error /= 0 ) then
- print*,'Program could not allocate space for land_fraction_tile'
- stop
- end if
-!
-! Expand Caspian Sea for tiles 6 and 15
-!
- if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,3600,5300)
- if(nmtile(n).eq.'E020N90')call expand_sea(ncols,nrows,iterr,nodata,4088,5874)
- if(nmtile(n).eq.'E020N40')call expand_sea(ncols,nrows,iterr,nodata,3600,1)
- print *, "min and maxiterr: ", minval(iterr), maxval(iterr)
-!
-! area average of 30-sec tile to 30-sec tile
-!
- call avg(ncols,nrows,iterr,nodata,ulymap,dx,terr_tile,land_fraction_tile)
-
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(terr_tile), maxval(terr_tile)
- print *, "min and max land_fraction: ", minval(land_fraction_tile), maxval(land_fraction_tile)
-!
-! fit the 30-sec tile into global 30-sec dataset
-!
-
- latsw= ulymap - (nrows-1) * dx
- lonsw = ulxmap
- if( lonsw < 0.0 ) lonsw=360.0+lonsw
- i1 = nint( (lonsw - lon_start) / dx )+1
- if( i1 <= 0 ) i1 = i1 + im
- if( i1 > im ) i1 = i1 - im
- j1 = nint( (latsw- lat_start) / dx )+1
-
-! print*,'ulymap,ulxmap,latsw10,lonsw = ',ulymap,ulxmap,latsw10,lonsw
-! print*,'i1,j1 = ', i1,j1
-
- call fitin(ncols,nrows,terr_tile,land_fraction_tile,i1,j1,im,jm,terr,land_fraction)
-!
-! Deallocate working space for arrays iterr, terr_tile and psea10m
-!
- deallocate ( iterr,terr_tile,land_fraction_tile,stat=dealloc_error )
- if( dealloc_error /= 0 ) then
- print*,'Unexpected deallocation error for arrays iterr,terr_tile'
- stop
- end if
-
- end do
- WRITE(*,*) 'done reading in USGS data'
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(terr), maxval(terr)
- print *, "min and max land frac: ", minval(land_fraction), maxval(land_fraction)
-!
-! Write 30-sec terrain dataset, and land_fraction to NetCDF file
-!
-! call wrtncdf(im,jm,terr,land_fraction,dx)
- call wrtncdf(im,jm,terr,land_fraction,dx,100)
- end program convterr
-
- subroutine rdheader(nmtile,nrows,ncols,nodata,ulxmap,ulymap)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine read the header of USGA Global30 sec TOPO data set.
-!
- implicit none
-!
-! Dummy arguments
-!
- character (len=7), intent(in) :: nmtile ! name of the tile
- integer, intent(out) :: nrows ! number of rows
- integer, intent(out) :: ncols ! number of column
- integer, intent(out) :: nodata ! integer for ocean data point
- real(r8), intent(out) :: ulxmap
- real(r8), intent(out) :: ulymap
-!
-! Local variables
-!
- character (len=11) :: flheader ! file name of the header
- character (len=13) :: chars ! dummy character
-
- flheader=nmtile//'.HDR'
-
- print*,'flheader = ', flheader
-!
-! Open GTOPO30 Header File
-!
- open(unit=10,file=flheader,status='old',form='formatted')
-!
-! Read GTOPO30 Header file
-!
- read (10, *)
- read (10, *)
- read (10, *) chars,nrows
- print*,chars,' = ',nrows
- read (10, *) chars,ncols
- print*,chars,' = ',ncols
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *)
- read (10, *) chars,nodata
- print*,chars,' = ',nodata
- read (10, *) chars,ulxmap
- print*,chars,' = ',ulxmap
- read (10, *) chars,ulymap
- print*,chars,' = ',ulymap
- close(10)
-
- end subroutine rdheader
-
- subroutine rdterr(nmtile,nrows,ncols,iterr)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine read the USGS Global 30-sec terrain data for each tile.
-!
- implicit none
-!
-! Dummy arguments
-!
- character (len=7), intent(in) :: nmtile ! name of the tile
- integer, intent(in) :: nrows ! number of rows
- integer, intent(in) :: ncols ! number of column
- integer*2, dimension(ncols,nrows), intent(out) :: iterr ! terrain data
-!
-! Local variables
-!
- character (len=11) :: flterr ! file name for each terr dataset
- integer :: io_error ! I/O status
- integer :: i,j ! Index
- integer :: length ! record length
-
- flterr=nmtile//'.DEM'
-
-! print*,'flterr = ', flterr
-! print*,'nrows,ncols = ',nrows,ncols
-!
-! Open GTOPO30 Terrain dataset File
-!
-
- length = 2 * ncols * nrows
- io_error=0
- open(unit=11,file=flterr,access='direct',recl=length,iostat=io_error)
- if( io_error /= 0 ) then
- print*,'Open file error in subroutine rdterr'
- print*,'iostat = ', io_error
- stop
- end if
-!
-! Read GTOPO30 Terrain data file
-!
- read (11,rec=1,iostat=io_error) ((iterr(i,j),i=1,ncols),j=1,nrows)
-!
- if( io_error /= 0 ) then
- print*,'Data file error in subroutine rdterr'
- print*,'iostat = ', io_error
- stop
- end if
-!
-! Print some info on the fields
- print *, "min and max elevations: ", minval(iterr), maxval(iterr)
-!
-! Correct missing data in source files
-!
-! Missing data near dateline
-
- if( nmtile == 'W180S60' ) then
- do j = 1, nrows
- iterr(1,j) = iterr(2,j)
- end do
- else if (nmtile == 'E120S60') then
- do j = 1, nrows
- iterr(ncols-1,j) = iterr(ncols-2,j)
- iterr(ncols,j) = iterr(ncols-2,j)
- end do
- end if
-!
-! Missing data at the southermost row near South pole
-!
- if( nmtile == 'E060S60' .or. nmtile == 'E120S60' .or. nmtile == 'W000S60' .or. &
- nmtile == 'W060S60' .or. nmtile == 'W120S60' .or. nmtile == 'W180S60' ) then
- do i=1,ncols
- iterr(i,nrows) = iterr(i,nrows-1)
- end do
- end if
-!
-! print*,'iterr(1,1),iterr(ncols,nrows) = ', &
-! iterr(1,1),iterr(ncols,nrows)
-
- close (11)
- end subroutine rdterr
-
- subroutine avg(ncols,nrows,iterr,nodata,ulymap,dx,terr_tile,land_fraction_tile)
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncols ! number of column for 30-sec tile
- integer, intent(in) :: nrows ! number of rows for 30-sec tile
- integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile
- integer, intent(in) :: nodata ! integer for ocean data point
- real(r8),intent(in) :: ulymap ! latitude at the center of the upper-left corner cell in the 30-sec tile
- real(r8),intent(in) :: dx ! spacing interval for 30-sec data (in degree)
- integer*2, dimension(ncols,nrows), intent(out) :: terr_tile ! terrain data for 30-sec tile
- integer*1, dimension(ncols,nrows), intent(out) :: land_fraction_tile
-!
-! Local variables
-!
- real(r8) :: lats,latn ! latitudes (in rad) for ths south and north edges of each 30-sec cell
- real(r8) :: wt ! area weighting of each 30-sec cell
- real(r8) :: wt_tot ! total weighting of each 30-sec cell
- real(r8) :: sumterr ! summation of terrain height of each 30-sec cell
- real(r8) :: sumsea ! summation of sea coverage of each 30-sec cell
- real(r8) :: pi ! pi=3.1415
- real(r8) :: latul ! latitude of the upper-left coner of 30-sec tile
- integer :: n1,itmp,i1,i2,j1,j2 ! temporary working spaces
- integer :: i,j,ii,jj ! index
- logical, dimension(ncols,nrows) :: oflag
-
- pi = 4.0 * atan(1.0)
-!
- n1 = ncols / ncols
- print*,'ncols,ncols,n1 = ',ncols,ncols,n1
-
- itmp = nint( ulymap + 0.5 * dx )
- latul = itmp
- print*,'ulymap,latul = ', ulymap,latul
- oflag = .false.
-
- do j = 1, nrows
- j1 = j
- j2 = j
- do i = 1, ncols
- i1 = i
- i2 = i
- terr_tile(i,j) = 0
- land_fraction_tile(i,j) = 1
- if ( iterr(i,j) == nodata ) then
- land_fraction_tile(i,j) = 0
- else
- if ( iterr(i,j) .lt.nodata ) then
- ! this can only happen in the expand_sea routine
- land_fraction_tile(i,j) = 0
- iterr(i,j) = iterr(i,j) - nodata - nodata
- endif
- terr_tile(i,j) = iterr(i,j)
- end if
- end do
- end do
-
- end subroutine avg
-
- subroutine expand_sea(ncols,nrows,iterr,nodata,startx,starty)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine reduces the resolution of the terrain data from 30-sec to 30-sec and
-! compute the percentage of ocean cover (psea10m)
-!
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncols ! number of column for 30-sec tile
- integer, intent(in) :: nrows ! number of rows for 30-sec tile
- integer*2, dimension(ncols,nrows), intent(inout) :: iterr ! terrain data for 30-sec tile
- integer, intent(in) :: nodata ! integer for ocean data point
- integer, intent(in) :: startx, starty ! where to begin the sea
-!
-! Local variables
-!
- real(r8):: maxh
- integer :: i,j,per,ii,jj ! index
- logical, dimension(0:ncols+1,0:nrows+1) :: flag ! terrain data for 30-sec tile
- logical :: found
-
- flag = .false.
-
- maxh = iterr(startx,starty)
-
- iterr(startx,starty) = iterr(startx,starty) + nodata + nodata
- flag(startx-1:startx+1,starty-1:starty+1) = .true.
-
- per = 0
- print *, 'expanding sea at ',maxh,' m '
-
-2112 per = per + 1
- found = .false.
- do j = starty - per, starty + per, per*2
- do i = startx - per, startx + per
- if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then
- if( iterr(i,j).eq.maxh .and. flag(i,j) ) then
- iterr(i,j) = iterr(i,j) + nodata + nodata
- flag(i-1:i+1,j-1:j+1) = .true.
- found = .true.
- endif
- endif
- end do
- end do
-
- do i = startx - per, startx + per, per*2
- do j = starty - per + 1, starty + per - 1
- if(i.ge.1.and.i.le.ncols.and.j.ge.1.and.j.le.nrows)then
- if( iterr(i,j).eq.maxh .and. flag(i,j) ) then
- iterr(i,j) = iterr(i,j) + nodata + nodata
- flag(i-1:i+1,j-1:j+1) = .true.
- found = .true.
- endif
- endif
- end do
- end do
- if (found)goto 2112
- print *, 'done with expand_sea'
- return
-
- end subroutine expand_sea
-
- subroutine fitin(ncols,nrows,terr_tile,land_fraction_tile,i1,j1,im,jm,terr,land_fraction)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine put 30-sec tile into the global dataset
-!
- implicit none
-!
-! Dummy arguments
-!
- integer, intent(in) :: ncols ! number of columns for 30-sec tile
- integer, intent(in) :: nrows ! number of rows for 30-sec tile
- integer*2, dimension(ncols,nrows), intent(in) :: terr_tile ! terrain data for 30-sec tile
- integer*1, dimension(ncols,nrows), intent(in) :: land_fraction_tile
- integer, intent(in) :: i1,j1 ! the (i,j) point of the southwest corner of the 30-sec tile
- ! in the global grid
- integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset
- integer*2,dimension(im,jm), intent(out) :: terr ! global 30-sec terrain data
- integer*1,dimension(im,jm), intent(out) :: land_fraction ! global 30-sec land fraction
-!
-! Local variables
-!
- integer :: i,j,ii,jj ! index
-
- do j = 1, nrows
- jj = j1 + (nrows - j)
- do i = 1, ncols
- ii = i1 + (i-1)
-
- if( i == 1 .and. j == 1 ) &
- print*,'i,j,ii,jj = ',i,j,ii,jj
- if( i == ncols .and. j == nrows ) &
- print*,'i,j,ii,jj = ',i,j,ii,jj
-
- if( ii > im ) ii = ii - im
- terr(ii,jj) = terr_tile(i,j)
- land_fraction(ii,jj) = land_fraction_tile(i,j)
- end do
- end do
- end subroutine fitin
-
- subroutine wrtncdf(im,jm,terr,land_fraction,dx)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine save 30-sec terrain data, land fraction to NetCDF file
-!
- implicit none
-
-# include
-
-!
-! Dummy arguments
-!
- integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset
- integer*2,dimension(im,jm), intent(in) :: terr ! global 30-sec terrain data
- integer*1,dimension(im,jm), intent(in) :: land_fraction !global 30-sec land fraction
- real(r8), intent(in) :: dx
-!
-! Local variables
-!
- real(r8),dimension(im) :: lonar ! longitude array
- real(r8),dimension(im) :: latar ! latitude array
- character (len=32) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: htopoid
- integer :: landfid
- integer, dimension(2) :: htopodim,landfdim
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j
- character (len=8) :: datestring
-
- integer*2,dimension(im,jm) :: h ! global 30-sec terrain data
- integer*1,dimension(im,jm) :: lnd
-
-
-!
-! Fill lat and lon arrays
-!
- do i = 1,im
- lonar(i)= dx * (i-0.5)
- enddo
- do j = 1,jm
- latar(j)= -90.0 + dx * (j-0.5)
- enddo
-
- do j=1,jm
- do i=1,im
- h(i,j) = terr(i,j)
- lnd(i,j) = land_fraction(i,j)
- end do
- end do
-
- fout='usgs-rawdata.nc'
-!
-! Create NetCDF file for output
-!
- print *,"Create NetCDF file for output"
- status = nf_create (fout, NF_64BIT_OFFSET , foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create dimensions for output
-!
- print *,"Create dimensions for output"
- status = nf_def_dim (foutid, 'lon', im, lonid)
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_def_dim (foutid, 'lat', jm, latid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create variable for output
-!
- print *,"Create variable for output"
- htopodim(1)=lonid
- htopodim(2)=latid
- status = nf_def_var (foutid,'htopo', NF_INT, 2, htopodim, htopoid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- landfdim(1)=lonid
- landfdim(2)=latid
- status = nf_def_var (foutid,'landfract', NF_INT, 2, landfdim, landfid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! Create attributes for output variables
-!
- status = nf_put_att_text (foutid,htopoid,'long_name', 41, '30-sec elevation from USGS 30-sec dataset')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter')
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- status = nf_put_att_text (foutid,landfid,'long_name', 23, '30-second land fraction')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)')
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data')
- if (status .ne. NF_NOERR) call handle_err(status)
- call DATE_AND_TIME(DATE=datestring)
- status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring )
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! End define mode for output file
-!
- status = nf_enddef (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Write variable for output
-!
- print*,"writing terrain data"
- status = nf_put_var_int2 (foutid, htopoid, h)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing terrain data"
-!
- status = nf_put_var_int1 (foutid, landfid, lnd)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- print*,"writing lat data"
- status = nf_put_var_double (foutid, latvid, latar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lat data"
-
- print*,"writing lon data"
- status = nf_put_var_double (foutid, lonvid, lonar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lon data"
-!
-! Close output file
-!
- print *,"close file"
- status = nf_close (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- end subroutine wrtncdf
-
-
- !
- ! same as wrtncdf but the output is coarsened
- !
- subroutine wrtncdf_coarse(im,jm,terr,land_fraction,dx,ic)
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! This subroutine save 30-sec terrain data, land fraction to NetCDF file
-!
- implicit none
-
-# include
-
-!
-! Dummy arguments
-!
- integer, intent(in) :: im,jm ! the dimensions of the 30-sec global dataset
- integer, intent(in) :: ic ! coarsening factor
- integer*2,dimension(im,jm), intent(in) :: terr ! global 30-sec terrain data
- integer*1,dimension(im,jm), intent(in) :: land_fraction !global 30-sec land fraction
- real(r8), intent(in) :: dx
-!
-! Local variables
-!
- real(r8),dimension(im/ic) :: lonar ! longitude array
- real(r8),dimension(im/ic) :: latar ! latitude array
- character (len=32) :: fout ! NetCDF output file
- integer :: foutid ! Output file id
- integer :: lonid, lonvid
- integer :: latid, latvid
- integer :: htopoid
- integer :: landfid
- integer, dimension(2) :: htopodim,landfdim
- integer :: status ! return value for error control of netcdf routin
- integer :: i,j
- character (len=8) :: datestring
-
- integer*2,dimension(im/ic,jm/ic) :: h ! global 30-sec terrain data
- integer*1,dimension(im/ic,jm/ic) :: lnd
-
-
-!
-! Fill lat and lon arrays
-!
- do i = 1,im/ic
- lonar(i)= real(ic)*dx * (i-0.5)
- enddo
- do j = 1,jm/ic
- latar(j)= -90.0 + real(ic)*dx * (j-0.5)
- enddo
-
- do j=1,jm/ic
- do i=1,im/ic
- h(i,j) = terr(i*ic,j*ic)
- lnd(i,j) = land_fraction(i*ic,j*ic)
- end do
- end do
-
- fout='usgs-lowres.nc'
-!
-! Create NetCDF file for output
-!
- print *,"Create NetCDF file for output"
- status = nf_create (fout, NF_64BIT_OFFSET , foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create dimensions for output
-!
- print *,"Create dimensions for output"
- status = nf_def_dim (foutid, 'lon', im/ic, lonid)
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_def_dim (foutid, 'lat', jm/ic, latid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Create variable for output
-!
- print *,"Create variable for output"
- htopodim(1)=lonid
- htopodim(2)=latid
- status = nf_def_var (foutid,'htopo', NF_INT, 2, htopodim, htopoid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- landfdim(1)=lonid
- landfdim(2)=latid
- status = nf_def_var (foutid,'landfract', NF_INT, 2, landfdim, landfid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! Create attributes for output variables
-!
- status = nf_put_att_text (foutid,htopoid,'long_name', 41, '30-sec elevation from USGS 30-sec dataset')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,htopoid,'units', 5, 'meter')
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- status = nf_put_att_text (foutid,landfid,'long_name', 23, '30-second land fraction')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,landfid,'units', 14, 'fraction (0-1)')
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations')
- if (status .ne. NF_NOERR) call handle_err(status)
-
- status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30')
- if (status .ne. NF_NOERR) call handle_err(status)
- status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data')
- if (status .ne. NF_NOERR) call handle_err(status)
- call DATE_AND_TIME(DATE=datestring)
- status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring )
- if (status .ne. NF_NOERR) call handle_err(status)
-
-!
-! End define mode for output file
-!
- status = nf_enddef (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
-! Write variable for output
-!
- print*,"writing terrain data"
- status = nf_put_var_int2 (foutid, htopoid, h)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing terrain data"
-!
- status = nf_put_var_int1 (foutid, landfid, lnd)
- if (status .ne. NF_NOERR) call handle_err(status)
-!
- print*,"writing lat data"
- status = nf_put_var_double (foutid, latvid, latar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lat data"
-
- print*,"writing lon data"
- status = nf_put_var_double (foutid, lonvid, lonar)
- if (status .ne. NF_NOERR) call handle_err(status)
- print*,"done writing lon data"
-!
-! Close output file
-!
- print *,"close file"
- status = nf_close (foutid)
- if (status .ne. NF_NOERR) call handle_err(status)
-
- end subroutine wrtncdf_coarse
-!************************************************************************
-!!handle_err
-!************************************************************************
-!
-!!ROUTINE: handle_err
-!!DESCRIPTION: error handler
-!--------------------------------------------------------------------------
-
- subroutine handle_err(status)
-
- implicit none
-
-# include
-
- integer status
-
- if (status .ne. nf_noerr) then
- print *, nf_strerror(status)
- stop 'Stopped'
- endif
-
- end subroutine handle_err
-
-
-
diff --git a/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90 b/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90
deleted file mode 100644
index fc1ed8e94a..0000000000
--- a/tools/topo_tool/gen_netCDF_from_USGS/shr_kind_mod.F90
+++ /dev/null
@@ -1,20 +0,0 @@
-!===============================================================================
-! CVS: $Id$
-! CVS: $Source$
-! CVS: $Name$
-!===============================================================================
-
-MODULE shr_kind_mod
-
- !----------------------------------------------------------------------------
- ! precision/kind constants add data public
- !----------------------------------------------------------------------------
- public
- integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
- integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
- integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
- integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
- integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
- integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
-
-END MODULE shr_kind_mod