From 613980f2f70c0cac82f5bdbe3eafb803a220f0bb Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 25 Mar 2024 10:44:38 -0400 Subject: [PATCH 01/10] change relative path in lenkf.j to abs path --- src/Applications/LDAS_App/ldas_setup | 3 ++- src/Applications/LDAS_App/lenkf.j.template | 8 ++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Applications/LDAS_App/ldas_setup b/src/Applications/LDAS_App/ldas_setup index 6c1eada8..6cf1c5ae 100755 --- a/src/Applications/LDAS_App/ldas_setup +++ b/src/Applications/LDAS_App/ldas_setup @@ -1392,7 +1392,8 @@ class LDASsetup: if self.ladas_coupling > 0: fout.write(line.replace('MY_ADAS_EXPDIR', self.rqdExeInp['ADAS_EXPDIR'])) else : - fout.write(line.replace('MY_EXPDIR',self.exphome+'/$EXPID')) + my_expdir = self.exphome + '/' + self.rqdExeInp['EXP_ID'] + fout.write(line.replace('MY_EXPDIR',my_expdir)) sp.call(['chmod', '755', 'lenkf.j']) diff --git a/src/Applications/LDAS_App/lenkf.j.template b/src/Applications/LDAS_App/lenkf.j.template index 7f6afcb0..7324b768 100644 --- a/src/Applications/LDAS_App/lenkf.j.template +++ b/src/Applications/LDAS_App/lenkf.j.template @@ -8,8 +8,8 @@ # Batch Parameters for Run Job ####################################################################### -#SBATCH --output=../scratch/GEOSldas_log_txt -#SBATCH --error=../scratch/GEOSldas_err_txt +#SBATCH --output=MY_EXPDIR/scratch/GEOSldas_log_txt +#SBATCH --error=MY_EXPDIR/scratch/GEOSldas_err_txt #SBATCH --account=MY_ACCOUNT #SBATCH --time=MY_WALLTIME #SBATCH --nodes=MY_NODES --ntasks-per-node=MY_NTASKS_PER_NODE @@ -21,8 +21,8 @@ #PBS -N MY_JOB #PBS -q MY_QOS #PBS -W group_list=MY_ACCOUNT -#PBS -o ../scratch/GEOSldas_log_txt -#PBS -e ../scratch/GEOSldas_err_txt +#PBS -o MY_EXPDIR/scratch/GEOSldas_log_txt +#PBS -e MY_EXPDIR/scratch/GEOSldas_err_txt #PBS -j oe ####################################################################### From 4c543775e89514ad26beb0083382d22ef1c5b97f Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Mon, 25 Mar 2024 13:25:54 -0400 Subject: [PATCH 02/10] switching back to components.yaml file from develop --- components.yaml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/components.yaml b/components.yaml index c041aafc..36d4d1e6 100644 --- a/components.yaml +++ b/components.yaml @@ -1,15 +1,18 @@ GEOSldas: fixture: true + develop: develop env: local: ./@env remote: ../ESMA_env.git tag: v4.23.0 + develop: main cmake: local: ./@cmake remote: ../ESMA_cmake.git tag: v3.41.0 + develop: develop ecbuild: local: ./@cmake/@ecbuild @@ -21,27 +24,31 @@ NCEP_Shared: remote: ../NCEP_Shared.git tag: v1.3.0 sparse: ./config/NCEP_Shared.sparse + develop: main GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git tag: v1.9.7 sparse: ./config/GMAO_Shared.sparse + develop: main GEOS_Util: local: ./src/Shared/@GMAO_Shared/@GEOS_Util remote: ../GEOS_Util.git tag: v2.0.7 sparse: ./config/GEOS_Util.sparse + develop: main MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git tag: v2.44.1 + develop: develop GEOSgcm_GridComp: local: ./src/Components/GEOSldas_GridComp/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: v2.5.2 + branch: develop sparse: ./config/GEOSgcm_GridComp_ldas.sparse - + develop: develop From 01f63b733a82dc764251e942a1f53da07e6c09aa Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 25 Mar 2024 14:34:25 -0400 Subject: [PATCH 03/10] Move LDAS_App to GEOSldas_App under GEOSldas_GridComp --- doc/README.ConfigurationFiles.md | 20 +- doc/README.OutputSpecs.md | 32 +- src/Applications/CMakeLists.txt | 1 - src/CMakeLists.txt | 1 - .../GEOSldas_GridComp/CMakeLists.txt | 4 +- .../GEOSlandassim_GridComp/mwRTM_routines.F90 | 606 +++++++++--------- .../GEOSlandassim_GridComp/mwRTM_types.F90 | 278 ++++---- .../GEOSldas_App}/CMakeLists.txt | 0 .../GEOSldas_App}/GEOSldas.F90 | 0 .../GEOSldas_App}/GEOSldas_CAP.rc | 0 .../GEOSldas_App}/GEOSldas_ExtData.rc | 0 .../GEOSldas_App}/GEOSldas_HIST.rc | 0 .../GEOSldas_App}/GEOSldas_LDAS.rc | 0 .../LDASsa_DEFAULT_inputs_adapt.nml | 0 .../LDASsa_DEFAULT_inputs_catbias.nml | 0 .../LDASsa_DEFAULT_inputs_ensprop.nml | 0 .../LDASsa_DEFAULT_inputs_ensupd.nml | 0 .../GEOSldas_App}/README_LDAS_App | 22 +- .../ens_forcing/average_ensemble_forcing.py | 0 .../GEOSldas_App}/ens_forcing/enpert_forc.csh | 0 .../ens_forcing/ensemble_forc.py | 0 .../GEOSldas_App}/ens_forcing/regrid_forc.csh | 0 .../ens_forcing/test_enpert_forc.j | 0 .../GEOSldas_App}/ldas_setup | 0 .../GEOSldas_App}/lenkf.j.template | 0 .../GEOSldas_App}/preprocess_ldas.F90 | 0 .../preprocess_ldas_routines.F90 | 0 .../GEOSldas_App}/process_hist.csh | 0 .../GEOSldas_App}/remap_config_ldas.py | 0 .../LADAS/HISTORY.rc.atmens | 10 +- .../LADAS/HISTORY.rc.central | 0 .../LADAS/exeinp.txt.Hy4dEnVar.atmens | 0 .../LADAS/exeinp.txt.Hy4dEnVar.central | 0 .../GEOSldas_App}/tile_bin2nc4.F90 | 0 .../config/Create_ccorr_cat_progn_default.m | 0 .../util/config/generate_catchincr_hist.py | 24 +- .../util/config/rewind_GEOSldas.csh | 0 .../util/inputs/ASCAT_sm_mask/CMakeLists.txt | 0 .../inputs/ASCAT_sm_mask/ascat_mask_maker.F90 | 0 .../mwRTM_params/Create_mwRTM_param_file.m | 64 +- .../Create_vegopacity_8day_clim.m | 124 ++-- ...reprocess_L2DCA_mwRTM_params_to_dailymat.m | 106 +-- .../mwRTM_params/fill_gaps_in_tiledata.m | 0 .../get_L2_RTM_constants_tile_data.m | 0 .../inputs/mwRTM_params/get_mwRTM_lookup.m | 0 .../mwRTM_params/get_mwRTM_vegcls_based.m | 0 .../inputs/mwRTM_params/mwrtm_bin2nc4.F90 | 0 .../Run_get_L4_Tb_scale_SMAP.m | 58 +- ...get_model_and_obs_clim_stats_latlon_grid.m | 10 +- .../inputs/obs_scaling_params/dist_km2deg.m | 0 .../get_ij_ind_from_latlon.m | 0 .../get_model_and_obs_clim_stats.m | 0 ...get_model_and_obs_clim_stats_latlon_grid.m | 0 .../obs_scaling_params/get_tile_num_for_obs.m | 0 .../get_tile_num_in_cell_ij.m | 0 .../write_netcdf_latlon_grid.m | 0 .../obs_scaling_params/write_seqbin_file.m | 0 .../util/postproc/climatology/README | 0 .../climatology/Run_L4_sm_clim_stats.m | 0 .../Write_L4_sm_clim_stat_bin2nc4.m | 0 .../climatology/get_model_clim_stats.m | 0 .../climatology/read_seqbin_clim_pctl_file.m | 0 .../climatology/write_seqbin_clim_pctl_file.m | 0 .../util/postproc/compress_bit-shaved_nc4.sh | 0 .../util/postproc/write_smapL4SMqa.m | 268 ++++---- .../util/shared/matlab/EASEv2_ind2latlon.m | 0 .../util/shared/matlab/EASEv2_latlon2ind.m | 0 .../util/shared/matlab/J2000_to_DateTime.m | 0 .../shared/matlab/MAPL_ReadForcing_fullfile.m | 0 .../util/shared/matlab/augment_date_time.m | 0 .../util/shared/matlab/days_in_month.m | 0 .../util/shared/matlab/get_dofyr_pentad.m | 0 .../util/shared/matlab/is_leap_year.m | 0 .../util/shared/matlab/pentad_of_year.m | 0 .../util/shared/matlab/read_ObsFcstAna.m | 0 .../util/shared/matlab/read_catparam.m | 0 .../util/shared/matlab/read_obslog.m | 0 .../util/shared/matlab/read_obsparam.m | 0 .../util/shared/matlab/read_smapL4SMaup.m | 0 .../util/shared/matlab/read_smapL4SMlmc.m | 0 .../util/shared/matlab/read_tilecoord.m | 0 .../util/shared/matlab/read_tilegrids.m | 0 .../util/shared/matlab/tile2grid.m | 0 83 files changed, 814 insertions(+), 814 deletions(-) delete mode 100644 src/Applications/CMakeLists.txt rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/CMakeLists.txt (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/GEOSldas.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/GEOSldas_CAP.rc (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/GEOSldas_ExtData.rc (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/GEOSldas_HIST.rc (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/GEOSldas_LDAS.rc (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/LDASsa_DEFAULT_inputs_adapt.nml (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/LDASsa_DEFAULT_inputs_catbias.nml (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/LDASsa_DEFAULT_inputs_ensprop.nml (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/LDASsa_DEFAULT_inputs_ensupd.nml (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/README_LDAS_App (56%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ens_forcing/average_ensemble_forcing.py (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ens_forcing/enpert_forc.csh (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ens_forcing/ensemble_forc.py (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ens_forcing/regrid_forc.csh (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ens_forcing/test_enpert_forc.j (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/ldas_setup (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/lenkf.j.template (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/preprocess_ldas.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/preprocess_ldas_routines.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/process_hist.csh (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/remap_config_ldas.py (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/sample_config_files/LADAS/HISTORY.rc.atmens (99%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/sample_config_files/LADAS/HISTORY.rc.central (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/tile_bin2nc4.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/config/Create_ccorr_cat_progn_default.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/config/generate_catchincr_hist.py (89%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/config/rewind_GEOSldas.csh (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/ASCAT_sm_mask/CMakeLists.txt (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/Create_mwRTM_param_file.m (93%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m (93%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m (89%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/get_mwRTM_lookup.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m (90%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m (98%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/dist_km2deg.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/get_tile_num_for_obs.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/inputs/obs_scaling_params/write_seqbin_file.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/README (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/Run_L4_sm_clim_stats.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/get_model_clim_stats.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/read_seqbin_clim_pctl_file.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/climatology/write_seqbin_clim_pctl_file.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/compress_bit-shaved_nc4.sh (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/postproc/write_smapL4SMqa.m (95%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/EASEv2_ind2latlon.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/EASEv2_latlon2ind.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/J2000_to_DateTime.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/MAPL_ReadForcing_fullfile.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/augment_date_time.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/days_in_month.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/get_dofyr_pentad.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/is_leap_year.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/pentad_of_year.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_ObsFcstAna.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_catparam.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_obslog.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_obsparam.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_smapL4SMaup.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_smapL4SMlmc.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_tilecoord.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/read_tilegrids.m (100%) rename src/{Applications/LDAS_App => Components/GEOSldas_GridComp/GEOSldas_App}/util/shared/matlab/tile2grid.m (100%) diff --git a/doc/README.ConfigurationFiles.md b/doc/README.ConfigurationFiles.md index bfa29754..b84b64e9 100644 --- a/doc/README.ConfigurationFiles.md +++ b/doc/README.ConfigurationFiles.md @@ -1,32 +1,32 @@ # GEOSldas Configuration Files -This document describes the files involved in the specification and pre-processing of the GEOSldas configuration parameters. +This document describes the files involved in the specification and pre-processing of the GEOSldas configuration parameters. Note that the values of the configuration parameters that are used during the execution of `GEOSldas.x` are written into the GEOSldas log file (`./output/*/rc_out/Y*/M*/*.ldas_log.*.txt`). --- ### `"exeinp"` and `"batinp"` files -Inputs to `ldas_setup` that contain user-defined configuration information. +Inputs to `ldas_setup` that contain user-defined configuration information. -Use `ldas_setup` to create sample files that contain descriptions of the configuration parameters. +Use `ldas_setup` to create sample files that contain descriptions of the configuration parameters. For details, see [README.md](https://github.com/GEOS-ESM/GEOSldas/blob/main/README.md). --- ### `LDASsa_SPECIAL_inputs_*.nml` - -Optional Fortran namelist (nml) files that contain additional user-defined configuration information for ensemble perturbations and data assimilation. -The path to these nml files is specified in the `"exeinp"` file. +Optional Fortran namelist (nml) files that contain additional user-defined configuration information for ensemble perturbations and data assimilation. -During `ldas_setup`, **default** configuration files (`LDASsa_DEFAULT_inputs_*.nml`) are created in the experiment `./run` directory. These files contain a complete set of the available configuration parameters with descriptions. The default configuration is a single-member land model simulation without perturbations and without data assimilation. The "DEFAULT" nml files must be present in the experiment `./run` directory and should not be edited. +The path to these nml files is specified in the `"exeinp"` file. + +During `ldas_setup`, **default** configuration files (`LDASsa_DEFAULT_inputs_*.nml`) are created in the experiment `./run` directory. These files contain a complete set of the available configuration parameters with descriptions. The default configuration is a single-member land model simulation without perturbations and without data assimilation. The "DEFAULT" nml files must be present in the experiment `./run` directory and should not be edited. To run GEOSldas with ensemble perturbations and data assimilation, users must create "SPECIAL" nml files (`LDASsa_SPECIAL_inputs_*.nml`) that contain the desired settings of the parameters. Only the nml parameters that are different from those in the "DEFAULT" files need to be included in the "SPECIAL" nml files. Parameters are grouped into three separate nml files: -* `ensprop` : Perturbations applied during the land model ensemble propagation step. +* `ensprop` : Perturbations applied during the land model ensemble propagation step. * `ensupd` : Assimilated observations and parameters of the ensemble-based analysis. * `catbias` : Dynamic bias estimation (defunct). @@ -50,11 +50,11 @@ If an experiment did not complete successfully (e.g., because of a system downti Contains parameters needed to run the main GEOSldas executable (`GEOSldas.x`), including information on land model configuration, version, grid, time steps, processor layout. -Created in the experiment `./run` directory during `ldas_setup`. Merges information from the `"exeinp"` and `"batinp"` files and the resource parameter template files for GEOSldas, i.e., [GEOSldas_LDAS.rc](https://github.com/GEOS-ESM/GEOSldas/blob/main/src/Applications/LDAS_App/GEOSldas_LDAS.rc) and [GEOS_SurfaceGridComp.rc](https://github.com/GEOS-ESM/GEOSgcm_GridComp/blob/main/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc) (from the linked GEOSgcm_GridComp repository). +Created in the experiment `./run` directory during `ldas_setup`. Merges information from the `"exeinp"` and `"batinp"` files and the resource parameter template files for GEOSldas, i.e., [GEOSldas_LDAS.rc](https://github.com/GEOS-ESM/GEOSldas/blob/main/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc) and [GEOS_SurfaceGridComp.rc](https://github.com/GEOS-ESM/GEOSgcm_GridComp/blob/main/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc) (from the linked GEOSgcm_GridComp repository). **Users are generally discouraged from editing** `LDAS.rc`. For example, editing `MET_PATH` does not change the associated directory link. Instead, users should run `ldas_setup` to create `LDAS.rc`. -`LDAS.rc` can be useful as a compact overview of the experiment configuration. +`LDAS.rc` can be useful as a compact overview of the experiment configuration. --- ### `lenkf.j` diff --git a/doc/README.OutputSpecs.md b/doc/README.OutputSpecs.md index 05338171..c985b9b5 100644 --- a/doc/README.OutputSpecs.md +++ b/doc/README.OutputSpecs.md @@ -7,26 +7,26 @@ Most diagnostic output from GEOSldas is generated through the **HISTORY** functi Restart/checkpoint files are also written through MAPL (although not through HISTORY). The key configuration parameters that control checkpoint file output are described in the sample "exeinp" files that can be generated using `ldas_setup`. For details, see [README.md](https://github.com/GEOS-ESM/GEOSldas/blob/main/README.md). Notable exceptions from the MAPL-generated output include: -* log files [ASCII], +* log files [ASCII], * observation-space "ObsFcstAna" data assimilation diagnostics [BINARY], and * SMAP L4_SM-specific "aup" data assimilation diagnostics files (available _**only**_ for simulations in EASEv2_M09 tile space) [BINARY]. -Output of the latter two sets of files can be turned on/off in the `[NML_INPUT_PATH]/LDASsa_SPECIAL_inputs_ensupd.nml` configuration file, and Matlab readers are available in the -[src/Applications/LDAS_App/util](https://github.com/GEOS-ESM/GEOSldas/tree/main/src/Applications/LDAS_App/util) directory. +Output of the latter two sets of files can be turned on/off in the `[NML_INPUT_PATH]/LDASsa_SPECIAL_inputs_ensupd.nml` configuration file, and Matlab readers are available in the +[src/Components/GEOSldas_GridComp/GEOSldas_App/util](https://github.com/GEOS-ESM/GEOSldas/tree/main/src/Components/GEOSldas_GridComp/GEOSldas_App/util) directory. ### MAPL HISTORY output -As part of `ldas_setup`, a sample `HISTORY.rc` configuration file is created in the experiment's `./run` directory. Users specify the desired output by editing `HISTORY.rc`. +As part of `ldas_setup`, a sample `HISTORY.rc` configuration file is created in the experiment's `./run` directory. Users specify the desired output by editing `HISTORY.rc`. `HISTORY.rc` defines a number of output file "Collections", each of which contains one or more output variables. Output can be in the native tile space ("1d") or gridded ("2d"), _**except**_ when the simulation is in the EASE grid tile space (see below). All variables contained in a given Collection are written: -* on the same ("2d") grid (if gridded), -* at the same frequency, and -* with either time-average ("tavg") or instantaneous ("inst") sampling mode. +* on the same ("2d") grid (if gridded), +* at the same frequency, and +* with either time-average ("tavg") or instantaneous ("inst") sampling mode. -In the following example, two Collections are written. The `tavg3_2d_lnd_Nx` Collection contains time-average ("tavg"), 3-hourly ("3"), gridded ("2d") data, and the `inst1_1d_lfs_Nt` Collection contains snapshot/instantaneous ("inst"), 1-hourly, tile-space ("1d") data. +In the following example, two Collections are written. The `tavg3_2d_lnd_Nx` Collection contains time-average ("tavg"), 3-hourly ("3"), gridded ("2d") data, and the `inst1_1d_lfs_Nt` Collection contains snapshot/instantaneous ("inst"), 1-hourly, tile-space ("1d") data. ``` COLLECTIONS: 'tavg3_2d_lnd_Nx' @@ -46,12 +46,12 @@ For example, to write 3-hourly, time-average output of the "WCSF" and "WCRZ" var :: ``` -To be available for output through MAPL HISTORY, a variable ("field") must be defined as an `ExportSpec` in a `GEOS_*GridComp.F90` file. The list of variables ("fields") in the definition of each Collection consists of three columns: +To be available for output through MAPL HISTORY, a variable ("field") must be defined as an `ExportSpec` in a `GEOS_*GridComp.F90` file. The list of variables ("fields") in the definition of each Collection consists of three columns: - (column 1) variable name in `GEOS_[GCNAME]GridComp.F90` file, -- (column 2) GridComp name [GCNAME], and +- (column 2) GridComp name [GCNAME], and - (column 3) user-specified variable name that appears in nc4 output (optional). -The same variable can be written in more than one Collection (i.e., at the same or different temporal and/or spatial resolutions), and there is no limit to the number of Collections that are defined for and written by a simulation. +The same variable can be written in more than one Collection (i.e., at the same or different temporal and/or spatial resolutions), and there is no limit to the number of Collections that are defined for and written by a simulation. Gridded ("2d") output can be on a grid other than the "native" grid that is associated with the tile space used in the simulation, as long as the output grid is defined in `HISTORY.rc`. For example, if the simulation uses a cube-sphere tile space, the 1/2-degree lat/lon output grid mentioned above would be defined as follows: ``` @@ -71,20 +71,20 @@ MAPL HISTORY can generally write gridded ("2d") output in binary or netcdf-4 (nc **Special considerations for GEOSldas** -1. Gridded ("2d") output _**cannot**_ be written for simulations in any EASE-grid tile space. But since each EASE-grid cell contains at most one tile, it is straightforward to convert tile-space ("1d") output into gridded output (2d arrays) on the fly using the `i_indg` and `j_indg` data in the `./rc_out/*tilecoord*` file. See Matlab readers and scripts in `./src/Application/LDAS_App/util`. +1. Gridded ("2d") output _**cannot**_ be written for simulations in any EASE-grid tile space. But since each EASE-grid cell contains at most one tile, it is straightforward to convert tile-space ("1d") output into gridded output (2d arrays) on the fly using the `i_indg` and `j_indg` data in the `./rc_out/*tilecoord*` file. See Matlab readers and scripts in `./src/Components/GEOSldas_GridComp/GEOSldas_App/util`. -2. When running in EASE-grid tile space, the main GEOSldas executable (`GEOSldas.x`) first writes tile-space ("1d") output in binary format using MAPL HISTORY. If nc4 output is requested in `HISTORY.rc`, the binary output from `GEOSldas.x` is then automatically converted into nc4 format in post-processing as part of the `lenkf.j` job script using the `tile_bin2nc4.F90` utility. +2. When running in EASE-grid tile space, the main GEOSldas executable (`GEOSldas.x`) first writes tile-space ("1d") output in binary format using MAPL HISTORY. If nc4 output is requested in `HISTORY.rc`, the binary output from `GEOSldas.x` is then automatically converted into nc4 format in post-processing as part of the `lenkf.j` job script using the `tile_bin2nc4.F90` utility. -3. GEOSldas can bundle sub-daily nc4 output into daily nc4 files and write monthly-average output through the `POSTPROC_HIST` configuration option. +3. GEOSldas can bundle sub-daily nc4 output into daily nc4 files and write monthly-average output through the `POSTPROC_HIST` configuration option. **Enhanced file compression and bit shaving** -To save disk space, MAPL can facilitate enhanced file compression through the modification of scientifically meaningless information in the output files. The `\*.nbits` parameter specifies the number of bits retained: +To save disk space, MAPL can facilitate enhanced file compression through the modification of scientifically meaningless information in the output files. The `\*.nbits` parameter specifies the number of bits retained: ``` tavg3_2d_lnd_Nx.nbits: 12, ``` -Many MERRA-2 and FP products, for example, use `\*.nbits: 12` and `\*.nbits: 10`, respectively. +Many MERRA-2 and FP products, for example, use `\*.nbits: 12` and `\*.nbits: 10`, respectively. To realize the disk space savings, bit-shaved output **must be compressed separately** after the simulation has finished. Binary files can be compressed with `gzip`; nc4 files can be compressed using the `compress_bit-shaved_nc4.sh` utility script. For reasons of efficiency, the compression is not included in GEOSldas `POSTPROC_HIST`. diff --git a/src/Applications/CMakeLists.txt b/src/Applications/CMakeLists.txt deleted file mode 100644 index 0b6508c1..00000000 --- a/src/Applications/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -add_subdirectory (LDAS_App) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 938bb668..6c5e032a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,4 +1,3 @@ add_subdirectory (Shared) add_subdirectory (Components) -add_subdirectory (Applications) diff --git a/src/Components/GEOSldas_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/CMakeLists.txt index d6a7018a..b4c0974e 100644 --- a/src/Components/GEOSldas_GridComp/CMakeLists.txt +++ b/src/Components/GEOSldas_GridComp/CMakeLists.txt @@ -1,6 +1,6 @@ esma_set_this () -esma_add_subdirectory(GEOSgcm_GridComp ) +esma_add_subdirectory(GEOSgcm_GridComp) set (alldirs GEOSmetforce_GridComp @@ -15,3 +15,5 @@ esma_add_library(${this} SUBDIRS LDAS_Shared DEPENDENCIES GEOSland_GridComp makebcs MAPL INCLUDES ${INC_ESMF}) + +esma_add_subdirectory(GEOSldas_App) diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 index 8a2fc5b6..45decf32 100644 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 +++ b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 @@ -3,11 +3,11 @@ module mwRTM_routines ! subroutines for microwave radiative transfer model ! - ! Select a specific configuration of the RTM via the field - ! "RTM_ID" in the "obs_param" type. + ! Select a specific configuration of the RTM via the field + ! "RTM_ID" in the "obs_param" type. ! ! %RTM_ID = ID of radiative transfer model to use for Tb forward modeling - ! (subroutine get_obs_pred()) + ! (subroutine get_obs_pred()) ! 0 = none ! 1 = L-band tau-omega model as in De Lannoy et al. 2013 (doi:10.1175/JHM-D-12-092.1) (SMOS) ! 2 = same as 1 but without Pellarin atm corr (SMAP) @@ -22,12 +22,12 @@ module mwRTM_routines use MAPL_ConstantsMod, ONLY: & MAPL_PI, & MAPL_TICE - + use mwRTM_types, ONLY: & mwRTM_param_type, & mwRTM_param_nodata_check, & assignment (=) - + use LDAS_ensdrv_globals, ONLY: & logit, & logunit, & @@ -40,29 +40,29 @@ module mwRTM_routines LDAS_GENERIC_ERROR implicit none - + ! everything is private by default unless made public - + private - + public :: mwRTM_get_Tb, catch2mwRTM_vars - + ! --------------------------------------------------------- - + real, parameter :: Tb_sky = 2.7 ! cosmic mw background temp [K] complex, parameter :: diel_ice = (3.2, 0.1) ! dielec. const. of ice complex, parameter :: diel_air = (1.0, 0.0) ! dielec. const. of air complex, parameter :: diel_rock = (5.5, 0.2) ! dielec. const. of rock - + real, parameter :: diel_watinf = 4.9 ! dielec. const. of water @ high freq. ! (Stogryn 1971) - + real, parameter :: eps_0 = 8.854e-12 ! vacuum permittivity [Farads/meter] ! (Klein and Swift 1977) real, parameter :: rho_soil = 2.66 ! soil specific density [g/cm3] - + contains ! ********************************************************************** @@ -70,102 +70,102 @@ module mwRTM_routines ! Subroutine mwRTM_get_param() reads binary mwRTM files and is no longer used. ! ! The subroutine has been replaced by: - ! - Applications/LDAS_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 + ! - Components/GEOSldas_GridComp/GEOSldas_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 ! - get_mwrtm_param() in GEOS_LandAssimGridComp.F90 converts the internal state ! variables of the Land Assim GridComp into the mwRTM structure. ! ! reichle, 4 Aug 2020 - + ! subroutine mwRTM_get_param( N_catg, N_tile, d2g, tile_id, mwRTM_param_path, & ! need_mwRTM_param, mwp) -! +! ! ! Read microwave RTM parameters from file. ! ! -! ! reichle, 17 May 2011 +! ! reichle, 17 May 2011 ! ! reichle, 21 Oct 2011 - added input of mwRTM_param from file -! ! reichle, 23 Oct 2012 - removed look-up table option (too complicated with +! ! reichle, 23 Oct 2012 - removed look-up table option (too complicated with ! ! "new" (200+) soil classes) ! ! - added tile_id check when reading mwRTM params from file -! +! ! implicit none -! +! ! integer, intent(in) :: N_catg, N_tile -! +! ! integer, dimension(N_tile), intent(in) :: d2g, tile_id ! -! character(200), intent(in) :: mwRTM_param_path +! character(200), intent(in) :: mwRTM_param_path ! ! logical, intent(in) :: need_mwRTM_param ! ! type(mwRTM_param_type), dimension(N_tile), intent(out) :: mwp ! mwRTM parameters -! +! ! ! local variables -! +! ! integer, parameter :: N_search_dir_max = 5 -! +! ! integer :: n, N_search_dir, istat -! +! ! character( 80) :: fname -! +! ! character(100), dimension(N_search_dir_max) :: search_dir ! ! logical :: all_nodata, mwp_nodata -! +! ! character(len=*), parameter :: Iam = 'mwRTM_get_param' ! character(len=400) :: err_msg ! ! ! ---------------------------------------------------------------------- ! ! ! ! initialize -! +! ! do n=1,N_tile -! mwp(n) = nodata_generic +! mwp(n) = nodata_generic ! end do -! +! ! ! read mwRTM parameters from file -! +! ! if (logit) write (logunit,*) 'Reading microwave RTM parameters from file' -! +! ! fname = '/mwRTM_param.bin' -! +! ! N_search_dir = 2 ! specify sub-dirs of mwRTM_param_path to search for file "fname" -! +! ! search_dir(1) = 'mwRTM' ! search_dir(2) = '.' -! -! ! when called with optional argument "istat" subroutine "open_land_param_file()" -! ! will *NOT* stop upon failure to open the file -! +! +! ! when called with optional argument "istat" subroutine "open_land_param_file()" +! ! will *NOT* stop upon failure to open the file +! ! istat = open_land_param_file( 10, .false., .true., N_search_dir, fname, & ! mwRTM_param_path, search_dir, ignore_stop=.true.) -! +! ! if (istat==0) then -! +! ! call io_mwRTM_param_type( 'r', 10, N_tile, mwp, N_catg, tile_id, d2g ) -! +! ! close (10,status='keep') -! +! ! if (logit) write (logunit,*) 'done reading' ! if (logit) write (logunit,*) -! +! ! else -! +! ! if (logit) write (logunit,*) 'WARNING: Could not open file!' ! if (logit) write (logunit,*) -! +! ! end if -! +! ! ! check for no-data-values in parameters ! ! if any field is a nodata value, set all fields to nodata value ! ! all_nodata = .true. -! +! ! do n=1,N_tile -! +! ! call mwRTM_param_nodata_check( mwp(n), mwp_nodata ) -! +! ! if (.not. mwp_nodata) all_nodata = .false. -! +! ! end do ! ! ! stop if mwRTM parameters needed but not available (ie, all are no-data) @@ -178,7 +178,7 @@ module mwRTM_routines ! ! warn if mwRTM parameters are all no-data (may not be needed) ! ! if (all_nodata .and. logit) then -! +! ! write (logunit,*) '#########################################################' ! write (logunit,*) ! write (logunit,*) ' WARNING: *All* parameters for the microwave radiative ' @@ -188,47 +188,47 @@ module mwRTM_routines ! write (logunit,*) ! ! end if -! +! ! end subroutine mwRTM_get_param - + ! **************************************************************** subroutine catch2mwRTM_vars( N_tile, vegcls_catch, poros_catch, poros_mwRTM, & sfmc_catch, tsurf_catch, tp1_catch, sfmc_mwRTM, tsoil_mwRTM, tp1_in_Kelvin ) - + ! convert soil moisture, surface temperature, and soil temperature from the Catchment - ! model into soil moisture and soil temperature inputs for the microwave radiative - ! transfer model (mwRTM) + ! model into soil moisture and soil temperature inputs for the microwave radiative + ! transfer model (mwRTM) ! ! reichle, 11 Dec 2013 ! ! added optional switch to allow tp1_catch input in Kelvin ! - reichle & borescan, 6 Nov 2020 - + implicit none - + integer, intent(in) :: N_tile - + integer, dimension(N_tile), intent(in) :: vegcls_catch - + real, dimension(N_tile), intent(in) :: poros_catch, poros_mwRTM real, dimension(N_tile), intent(in) :: sfmc_catch, tsurf_catch, tp1_catch - + real, dimension(N_tile), intent(out) :: sfmc_mwRTM, tsoil_mwRTM logical, intent(in), optional :: tp1_in_Kelvin ! local variables - + logical :: tp1_in_K real, dimension(N_tile) :: tp1 - + ! ----------------------------------------------------------------------- ! ! reichle, 22 Oct 2012: scaling factor added because it is necessary for ! proper functioning of mwRTM calibration to SMOS obs - + sfmc_mwRTM = sfmc_catch * poros_mwRTM / poros_catch ! diagnose soil temperature to be used with mwRTM @@ -238,19 +238,19 @@ subroutine catch2mwRTM_vars( N_tile, vegcls_catch, poros_catch, poros_mwRTM, & ! NOTE: By default, "tp" is assumed to be in deg Celsius tp1_in_K = .false. - + if (present(tp1_in_Kelvin)) tp1_in_K = tp1_in_Kelvin tp1 = tp1_catch - + if (.not. tp1_in_K) tp1 = tp1 + MAPL_TICE ! convert units if not already in Kelvin - + tsoil_mwRTM = tp1 - + end subroutine catch2mwRTM_vars - + ! **************************************************************** - + subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & LAI, soilmoist, soiltemp, SWE, Tair, RTM_ID, Tb_h, Tb_v ) @@ -259,7 +259,7 @@ subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & !23 Nov 2010: - adapted to include the atmospheric correction ! GDL, code based on CMEMv3.0 ! - !Instead of passing on the whole diagnostic structure, + !Instead of passing on the whole diagnostic structure, !only pass rtmv, T5, Tc !GDL, 22Oct10 ! !N_cat could be either all tiles or only a part of them! @@ -268,12 +268,12 @@ subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & !FYI: !SM vol/vol ~ g/cm3 !gravim SM (g/g) * bulk densit (g/cm3) = volum SM (vol/vol) ~ g/cm3 - ! + ! !== VWC: Vegetation water content in kg/m2 (=mm) !== T5: Soil temperature [K] - !== Tc: Vegetation canopy temperature [K] + !== Tc: Vegetation canopy temperature [K] ! - !21 Mar 2011: - temperature treatment changed + !21 Mar 2011: - temperature treatment changed !==> instead of passing on T5 and Tc (= tsurf) !we now pass on tsurf and tp1 and diagnose T10cm (~T5) from it HERE !==> tsurf and tp1 are now input variables @@ -289,16 +289,16 @@ subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & ! 23 Nov 2011: - reichle: changed tsoil_threshold b/c QC now done for individual ! ensemble members ! 22 Oct 2012: - reichle: removed interception water ("capac") contribution - ! + ! !--------------------------------------------------- - + implicit none integer, intent(in) :: N_tile ! number of tiles real, intent(in) :: freq ! [Hz] real, intent(in) :: inc_angle ! [deg] - + type(mwRTM_param_type), dimension(N_tile), intent(in) :: mwp real, dimension(N_tile), intent(in) :: elev ! [m] @@ -310,82 +310,82 @@ subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & real, dimension(N_tile), intent(in) :: Tair ! [K] integer, intent(in) :: RTM_ID - + real, dimension(N_tile), intent(out) :: Tb_h, Tb_v ! [K] - + ! -------------------- - + ! local variables - + real, parameter :: tsoil_threshold = MAPL_TICE+0.2 ! avoid "frozen" soil [K] real, parameter :: SWE_threshold = 1.e-4 ! avoid snow [kg/m2] - + integer :: n - + real :: inc, sin_inc, cos_inc - complex :: c_er, tmpc1, tmpc2 + complex :: c_er, tmpc1, tmpc2 real :: roh, rov, rsh, rsv real :: h_mc, Q, slope - + real :: vwc, Ah, Av, exptauh, exptauv, exptauh2, exptauv2, tmpreal - + real :: exptau_atm, tau_atm, Tb_ad, Tb_au - + real :: soiltemp_in_C, Tc - + !real :: er_r ! for realdobson logical :: veg_params_nodata - + character(len=*), parameter :: Iam = 'mwRTM_get_Tb' character(len=400) :: err_msg - + !--------------------------------------------------- - + !if (logit) write(logunit,*) 'entering mwRTM_get_Tb...' ! check first element of elevation against no-data-value ! (elevation is only needed for RTMs with Pellarin atm corr) select case (RTM_ID) - + case(1,3) - + if ( abs(elev(1)-nodata_generic)=mwp(n)%rgh_wmax) then - + h_mc = mwp(n)%rgh_hmin - + else - + slope = & (mwp(n)%rgh_hmin - mwp(n)%rgh_hmax)/ & (mwp(n)%rgh_wmax - mwp(n)%rgh_wmin) - + h_mc = mwp(n)%rgh_hmax + slope * (soilmoist(n) - mwp(n)%rgh_wmin) - + endif - + ! 2) polarization mixing, Q as defined in CMEM: - + if (freq < 2.e9) then select case (RTM_ID) - + case(1,2) - + Q = 0. ! Q is assumed zero at low frequency case(3,4) - - Q = 0.1771 * h_mc - - case default + + Q = 0.1771 * h_mc + + case default err_msg = 'unknown RTM_ID (during pol mixing)' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - + end select - - else - + + else + Q = 0.35 * (1.0 - exp(-0.6 * (mwp(n)%rgh_polmix**2) * (freq/1.e9) )) - + end if ! rough surface reflectivity select case (RTM_ID) - + case(1,2) - - rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**mwp(n)%rgh_nrh) + + rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**mwp(n)%rgh_nrh) rsv = ( (1-Q) * rov + Q * roh) * EXP(-h_mc*cos_inc**mwp(n)%rgh_nrv) - + case(3,4) - - rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**2) + + rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**2) rsv = ( (1-Q) * rov + Q * roh) * EXP(-h_mc*cos_inc**2) case default - + err_msg = 'unknown RTM_ID (during rough reflectivity)' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - + end select ! ------------------------------------------------------------- @@ -514,118 +514,118 @@ subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & ! the if statement above, in conjunction with mwRTM_param_nodata_check() called earlier, ! ensures that we have "good" values for either (vegopacity) or (bh,bv,lewt) - + if ( LDAS_is_nodata( mwp(n)%vegopacity ) ) then - + ! == vwc: Vegetation water content in kg/m2 (=mm) ! needs to be the total columnar vegetation water content, ! depends on greenness/NDVI/LAI... ! VWC=LEWT*LAI, lewt is actually a time-varying parameter! - ! For now LEWT is guessed based on literature, and kept cst. - + ! For now LEWT is guessed based on literature, and kept cst. + vwc = mwp(n)%lewt * lai(n) ! removed contribution of interception water ("capac") ! - !! ! add bit of intercepted water as well - !! + !! ! add bit of intercepted water as well + !! !! vwc = vwc + capac(n) - + ! Vegetation optical thickness tau=b*VWC (eq. (2) in Crow et al. 2005) - + tmpreal = vwc/cos_inc - + exptauh = EXP( -mwp(n)%bh * tmpreal ) exptauv = EXP( -mwp(n)%bv * tmpreal ) else - + exptauh = EXP( -mwp(n)%vegopacity) exptauv = EXP( -mwp(n)%vegopacity) end if - + Tc = soiltemp(n) ! canopy temp = soil temp - + tmpreal = Tc * (1. - mwp(n)%omega) Ah = tmpreal * (1. - exptauh) Av = tmpreal * (1. - exptauv) - + ! Eq.(1) in Crow et al. 2005: ! ! Tb_tov = Tb_soil.e_p.exp(-tau/cos theta) + Tb_veg.(1 + r_r.exp(-tau/cos theta)) - + Tb_h(n) = soiltemp(n) * (1. - rsh) * exptauh + Ah * (1. + rsh * exptauh) Tb_v(n) = soiltemp(n) * (1. - rsv) * exptauv + Av * (1. + rsv * exptauv) - - + + ! ------------------------------------------------------------- ! ! Atmospheric correction ! - ! GDL 23nov10 + ! GDL 23nov10 select case (RTM_ID) - + case(1,3) - + exptauh2 = exptauh * exptauh exptauv2 = exptauv * exptauv - + if (freq<2.e9) then - + call ATMPELLARIN( elev(n)/1000., Tair(n), cos_inc, tau_atm, Tb_ad, Tb_au ) - + else - + err_msg = 'cannot compute atm corr for given freq' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - + end if - + exptau_atm = EXP( - tau_atm/cos_inc ) - + Tb_h(n) = Tb_h(n) + Tb_ad*rsh*exptauh2 ! top-of-veg Tb_h (incl atm. contrib.) Tb_v(n) = Tb_v(n) + Tb_ad*rsv*exptauv2 ! top-of-veg Tb_v (incl atm. contrib.) - + Tb_h(n) = Tb_h(n) * exptau_atm + Tb_au ! top-of-atmosphere Tb_h Tb_v(n) = Tb_v(n) * exptau_atm + Tb_au ! top-of-atmosphere Tb_v case(2,4) - + ! do nothing - + case default - + err_msg = 'unknown RTM_ID (during Pellarin atm corr)' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - + end select else ! snow present, soil frozen, or mwRTM params not available - + Tb_h(n) = nodata_generic Tb_v(n) = nodata_generic - + endif end do - + !if (logit) write(logunit,*) 'exiting mwRTM_get_Tb.' - + end subroutine mwRTM_get_Tb - - + + ! ********************************************************************** - + subroutine atmpellarin( Z, tair, costheta, tau_atm, tb_ad, tb_au) ! opacity and brightness temperature of atmosphere for low-freq microwave ! (up to and incl. L-band) ! - ! GDL, 23nov10 + ! GDL, 23nov10 ! Code based on CMEMv3.0 ! ! reichle, 16 May 2011: included in LDASsa @@ -639,13 +639,13 @@ subroutine atmpellarin( Z, tair, costheta, tau_atm, tb_ad, tb_au) real, intent(in) :: costheta ! cosine of incidence angle [dim-less] real, intent(in) :: Z ! elevation above sea-level [km] real, intent(in) :: tair ! surface air temperature [K] - + real, intent(out) :: tau_atm ! atmospheric opacity [dim-less] real, intent(out) :: tb_ad ! downwelling atm Tb [K] real, intent(out) :: tb_au ! upwelling atm Tb [K] ! local variables - + real :: GOSSAT, TAEQ !--------------------------------------------------------------------- @@ -654,24 +654,24 @@ subroutine atmpellarin( Z, tair, costheta, tau_atm, tb_ad, tb_au) tau_atm = exp( -3.926 - 0.2211 * Z - 0.00369 *tair) - + ! 2. Calculate up- and downward atmospheric radiation GOSSAT = exp(-tau_atm/ costheta) TAEQ = exp( 4.927 + 0.002195 * tair) - + tb_ad = TAEQ*(1. - GOSSAT) + Tb_sky * GOSSAT - + tb_au = TAEQ*(1. - GOSSAT) - + end subroutine atmpellarin - + ! ************************************************************ - + subroutine dielwang( FREQ, WC, TS, wt, wp, poros, sand, clay, eps) - + ! GDL, 28Mar11 ! Code adapted from CMEMv3.0 ! @@ -679,23 +679,23 @@ subroutine dielwang( FREQ, WC, TS, wt, wp, poros, sand, clay, eps) ! ! ! Purpose : - ! Calculate the dielectric constant of a wet soil + ! Calculate the dielectric constant of a wet soil ! Developed and validated for 1.4 and 5 GHz. ! ! Reference: - ! Wang and Schmugge, 1980: An empirical model for the + ! Wang and Schmugge, 1980: An empirical model for the ! complex dielectric permittivity of soils as a function of water ! content. IEEE Trans. Geosci. Rem. Sens., GE-18, No. 4, 288-295. ! !--------------------------------------------------------------------------- - + implicit none - + real, intent(in) :: FREQ ! microwave frequency [Hz] real, intent(in) :: TS ! soil temperature [deg C] - + real, intent(in) :: WC ! volumetric soil water content [m3/m3] - + real, intent(in) :: wt ! transition soil moisture [m3/m3] real, intent(in) :: wp ! wilting point [m3/m3] real, intent(in) :: poros ! porosity @@ -703,40 +703,40 @@ subroutine dielwang( FREQ, WC, TS, wt, wp, poros, sand, clay, eps) real, intent(in) :: clay ! clay fraction [0-1] complex, intent(out) :: eps ! dielectric constant of soil-water mixture [dim-less] - + ! ------------------------------------- - ! + ! ! local variables - complex, parameter :: j = (0. , 1. ) + complex, parameter :: j = (0. , 1. ) real :: gamma ! fitting parameter real :: ecl ! conductivity loss complex :: ew ! dielectric constant of water complex :: ex ! dielectric constant of the initially absorbed water - + real :: alpha - + !--------------------------------------------------------------------------- ! ! 0. Compute dielectric constant of free water ! ! assume soil salinity = 0 - + call DIEL_WAT( 2, 2, TS, 0., FREQ, clay, sand, poros, wc, ew) - + !--------------------------------------------------------------------------- ! ! 1. Calculate dielectric constant of soil-water mixture - + gamma = -0.57 * wp + 0.481 ! wt = 0.49 * wp + 0.165 transition SM parameter from Wang and Schmugge 1980; ! note typo in De Lannoy et al 2013 (0.48 instead of 0.49) - + IF (wc <= wt) THEN - + ex = diel_ice + (ew-diel_ice)*(wc/wt)*gamma eps = wc*ex + (poros-wc)*diel_air + (1.-poros)*diel_rock @@ -748,28 +748,28 @@ subroutine dielwang( FREQ, WC, TS, wt, wp, poros, sand, clay, eps) eps = wt*ex + (wc-wt)*ew + (poros-wc)*diel_air + (1.-poros)*diel_rock ENDIF - + !--------------------------------------------------------------------------- ! ! 2. add conductivity loss (Wang dielectric model) if (FREQ > 2.5e9) then - + alpha = 0. else - + alpha = min( 100.*wp, 26.) - + end if - + ecl = alpha * wc**2. - + eps = eps + j * ecl - + end subroutine dielwang - - + + ! ************************************************************ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) @@ -778,10 +778,10 @@ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) ! ! included in LDASsa, reichle - 2 Jun 2011 - ! Purpose : - ! Calculate dielectric constant of water in three different media : + ! Purpose : + ! Calculate dielectric constant of water in three different media : ! pure water, sea water, soil water - + ! Reference: ! Dielectric constant of pure water ! Ulaby p 2020 @@ -797,17 +797,17 @@ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) ! 1) Dobson '85. Modified Debye expression ! Stern_Gouy double layer theory ! 2) Ulaby p 2024 - + ! Interface : ! medium = pure water(0) sea water(1) soil water(2) ! isal = Stogryn (1) Klein and Swift (2) - + ! local variables : ! N : normality from salinity (Stogryn, modified by Klein and Swift 1977) ! T : temperature of water (C) ! ew : dielectric constant of water - ! sal : water salinity (psu = ppt(weight) ) - ! eps_w0 : static dielectric constant of pure water (Klein and Swift 1977) + ! sal : water salinity (psu = ppt(weight) ) + ! eps_w0 : static dielectric constant of pure water (Klein and Swift 1977) ! eps_sw0 : Static dielectric constant of soil water ! tau_w : relaxation time of pure water (stogryn, 1970) ! tau_sw : relaxation time of saline water @@ -816,7 +816,7 @@ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) !--------------------------------------------------------------------------- IMPLICIT NONE - + INTEGER, intent(in) :: medium ! 0=pure water, 1=sea water, 2=soil water INTEGER, intent(in) :: isal ! 1=Stogryn, 2=Klein and Swift REAL, intent(in) :: T ! temperature of water [C] @@ -828,13 +828,13 @@ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) real, intent(in) :: wc ! soil moisture [m3/m3] COMPLEX, intent(out) :: ew ! dielec. const. of water at given freq, T, sal, etc. - + ! local variables - - complex, parameter :: j = (0. , 1. ) - - real :: rho_b - + + complex, parameter :: j = (0. , 1. ) + + real :: rho_b + REAL :: N, omega, wc_c REAL :: sigma_eff REAL :: tau_w, tau_sw @@ -853,89 +853,89 @@ SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) ! ! tau_w = 1./(2.*pi) * (1.1109e-10 - 3.824e-12 * T + 6.938e-14 * T**2 & ! - 5.096e-16 * T**3) - + omega = 2.0 * MAPL_PI * freq - rho_b = (1.-poros)*rho_soil ! soil bulk density [g/cm3] - - + rho_b = (1.-poros)*rho_soil ! soil bulk density [g/cm3] + + SELECT CASE (isal) - + CASE ( 1 ) ! Stogryn (1971) - + N = 0.9141 * sal * (1.707e-2 + sal*(1.205e-5 + sal*4.058e-9)) - + eps_sw0 = 87.74 + T*(-0.4008 + T*(9.398e-4 + T*1.410e-6)) a = 1. + N*(-0.2551 + N*(5.151e-2 - N*6.889e-3)) eps_sw0 = eps_sw0 * a - - bb = 1. + N*(-0.04896 + 0.1463e-2*T + N*(-0.02967 + N*5.644e-3)) - + + bb = 1. + N*(-0.04896 + 0.1463e-2*T + N*(-0.02967 + N*5.644e-3)) + tau_sw = tau_w * bb - + CASE ( 2 ) ! Klein and Swift (1977) - + eps_sw0 = 87.134 + T*(-1.949e-1 + T*(-1.276e-2 + T*2.491e-4)) - + a = 1. + sal*( 1.613e-5*T -3.656e-3 + sal*(3.210e-5 - sal*4.232e-7)) - + eps_sw0 = eps_sw0 * a - + bb = 1. + sal*(2.282e-5*T - 7.638e-4 + sal*(-7.760e-6 + sal*1.105e-8)) - + tau_sw = tau_w * bb - + END SELECT - - + + SELECT CASE (medium) - + CASE ( 0 ) ! pure water - + eps_w0 = 88.045 + T*(-0.4147 + T*(6.295e-4 + T*1.075e-5)) - + ew = diel_watinf + (eps_w0 - diel_watinf) / (1. - j * omega * tau_w) - + CASE ( 1 ) ! sea water - + err_msg = 'medium=1 (sea water) not implemented' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - CASE ( 2 ) ! soil water + + CASE ( 2 ) ! soil water ! changed units of sand, clay to [0-1], reichle, 2 Jun 2011 - - ! Avoid negative sigma_eff for very sandy soils with low bulk densities. - + + ! Avoid negative sigma_eff for very sandy soils with low bulk densities. + sigma_eff = max( 0., -1.645 + 1.939*rho_b - 2.256*sand + 1.594*clay) - + ! Modified Debye expression, Dobson '85 - + wc_c = MAX(0.001, wc) ! to avoid dividing by zero - + ew = diel_watinf + (eps_sw0 - diel_watinf) / (1. - j * omega * tau_sw) & + j * sigma_eff / (omega * eps_0) * (rho_soil - rho_b) / (rho_soil * wc_c) - + END SELECT - + END SUBROUTINE DIEL_WAT - + ! ********************************************************************** - + SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) - + ! Soil dielectric mixing model by Mironov et al IEEE TGRS 2009, doi:10.1109/TGRS.2008.2011631 ! ! 8 May 2023: Implementation taken from SMAP L2_SM_P retrieval model by qliu; clean-up by reichle - + IMPLICIT NONE REAL, INTENT(IN) :: freq ! microwave frequency [Hz] REAL, INTENT(IN) :: mv ! volumetric soil water content [m3/m3] REAL, INTENT(IN) :: clayfrac ! clay fraction [0-1] - + COMPLEX, INTENT(OUT) :: er_r ! complex dielectric constant of moist soil ! ------------------------------ @@ -953,15 +953,15 @@ SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) REAL :: tmptauu, tmptauu2plus1, tmpdiffepsu REAL :: tmpreal, tmprealb, tmprealu - + ! -------------------------------------------------------------------------------------- f = freq ! Section IV C = clayfrac*100 ! Section VI - + !! Mironov's regression expressions based on Curtis, Dobson, and Hallikainen datasets !! - !! mvt : max bound water fraction + !! mvt : max bound water fraction !! !! eps(*) : dielectric constant (real part) and loss factor (imaginary part) !! n(*) : refractive index @@ -973,7 +973,7 @@ SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) !! d: dry soil !! b: bound soil water (BSW) !! u: unbound (free) soil water (FSW) - + nd = 1.634 - 0.539e-2 * C + 0.2748e-4 * C**2 ! Eqn 17 kd = 0.03952 - 0.04038e-2 * C ! Eqn 18 mvt = 0.02863 + 0.30673e-2 * C ! Eqn 19 @@ -983,29 +983,29 @@ SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) sigu = 0.3631 + 1.217e-2 * C ! Eqn 23 eps0u = 100. ! Eqn 24 tauu = 8.5e-12 ! Eqn 25 - + !! Debye relaxation equations for water as a function of frequency ! Eqn 16 - + tmp2PIf = 2.*MAPL_PI*f tmpeps0 = tmp2PIf*eps_0 - + tmptaub = tmp2PIf*taub tmptauu = tmp2PIf*tauu - + tmptaub2plus1 = 1. + tmptaub**2 tmptauu2plus1 = 1. + tmptauu**2 tmpdiffepsb = eps0b - diel_watinf tmpdiffepsu = eps0u - diel_watinf - - epsb_real = diel_watinf + tmpdiffepsb/tmptaub2plus1 + + epsb_real = diel_watinf + tmpdiffepsb/tmptaub2plus1 epsb_imag = tmpdiffepsb/tmptaub2plus1 * tmptaub + sigb/tmpeps0 - epsu_real = diel_watinf + tmpdiffepsu/tmptauu2plus1 + epsu_real = diel_watinf + tmpdiffepsu/tmptauu2plus1 epsu_imag = tmpdiffepsu/tmptauu2plus1 * tmptauu + sigu/tmpeps0 - - !! Refractive indices and normalized attenuation coefficients - + + !! Refractive indices and normalized attenuation coefficients + tmpreal = 1/sqrt(2.0) tmprealb = sqrt( epsb_real**2 + epsb_imag**2 ) @@ -1015,14 +1015,14 @@ SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) kb = tmpreal * sqrt( tmprealb - epsb_real ) ! Eqn 15 nu = tmpreal * sqrt( tmprealu + epsu_real ) ! Eqn 14 ku = tmpreal * sqrt( tmprealu - epsu_real ) ! Eqn 15 - + IF (mv <= mvt) THEN - + nm = nd + (nb - 1.) * mv ! Eqn 12 km = kd + kb * mv ! Eqn 13 - + ELSE - + nm = nd + (nb - 1.) * mvt + (nu - 1.) * (mv - mvt) ! Eqn 12 km = kd + kb * mvt + ku * (mv - mvt) ! Eqn 13 @@ -1032,15 +1032,15 @@ SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) er_r_real = nm**2 - km**2 ! Eqn 11 er_r_imag = 2. * nm * km ! Eqn 11 - + er_r = CMPLX(er_r_real,er_r_imag) - + END SUBROUTINE mironov - + ! ********************************************************************** - + end module mwRTM_routines - + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if 0 @@ -1048,15 +1048,15 @@ end module mwRTM_routines ! driver routines for testing program test_mwRTM_types - + use mwRTM_routines - + implicit none - + type(mwRTM_param_type) :: mwRTM_param - + mwRTM_param = -9999. - + write (*,*) mwRTM_param end program test_mwRTM_types diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 index 5c88a945..5080c291 100644 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 +++ b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 @@ -12,7 +12,7 @@ module mwRTM_types ! reichle, 21 Oct 2011 - added field "poros" to "mwRTM_param_type" ! ! -------------------------------------------------------------------------- - + use LDAS_ensdrv_globals, ONLY: & nodata_generic, & nodata_tol_generic, & @@ -23,22 +23,22 @@ module mwRTM_types LDAS_GENERIC_ERROR implicit none - + ! everything is private by default unless made public - + private - + public :: mwRTM_param_type public :: mwRTM_param_nodata_check - + public :: assignment (=) - + ! --------------------------------------------------------- - + ! model parameters - + type :: mwRTM_param_type - + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! WARNING: When modifying this derived type make sure that the corresponding ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are @@ -47,19 +47,19 @@ module mwRTM_types integer :: vegcls ! land cover/veg class (can differ from cat_param%vegcls ! ) integer :: soilcls ! soil class (can differ from cat_param%soilcls30! ) - + real :: sand ! sand fraction [0-1] real :: clay ! clay fraction [0-1] - + real :: poros ! porosity (can differ from cat_param%poros!) [m3/m3] ! parameters relating to soil mixing model - + real :: wang_wt ! Wang dielectric model: transition s.m. [m3/m3] real :: wang_wp ! Wang dielectric model: wilting point s.m. [m3/m3] - + ! parameters relating to emissivity of rough surface - + real :: rgh_hmin ! min roughness [dim-less] real :: rgh_hmax ! max roughness [dim-less] real :: rgh_wmin ! soil moisture for transition to hmax [m3/m3] @@ -67,24 +67,24 @@ module mwRTM_types real :: rgh_Nrh ! h-pol exponent for inc angle parameterization [dim-less] real :: rgh_Nrv ! v-pol exponent for inc angle parameterization [dim-less] real :: rgh_polmix ! polarization mixing parameter [dim-less] - + real :: omega ! single scattering albedo [dim-less] - ! parameters relating to vegetation opacity - + ! parameters relating to vegetation opacity + real :: bh ! veg b parameter (h-pol) (tau = b*VWC) [dim-less] real :: bv ! veg b parameter (v-pol) (tau = b*VWC) [dim-less] real :: lewt ! VWC = lewt*LAI [kg/m2] real :: vegopacity ! veg opacity = tau/cos(inc_angle) [dim-less] - + end type mwRTM_param_type - + ! --------------------------------------------------------- - + interface assignment (=) module procedure scalar2mwRTM_param end interface - + contains ! ********************************************************************** @@ -92,43 +92,43 @@ module mwRTM_types ! Subroutine io_mwRTM_param_type() reads and writes binary mwRTM files and is no longer used. ! ! The subroutine has been replaced by: - ! - Applications/LDAS_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 + ! - Components/GEOSldas_GridComp/GEOSldas_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 ! - get_mwrtm_param() in GEOS_LandAssimGridComp.F90 converts the internal state ! variables of the Land Assim GridComp into the mwRTM structure. ! ! reichle, 4 Aug 2020 -! subroutine io_mwRTM_param_type( action, unitnum, N_tile, mwp, N_catg, tile_id, d2g ) -! +! subroutine io_mwRTM_param_type( action, unitnum, N_tile, mwp, N_catg, tile_id, d2g ) +! ! ! read/write mwRTM_param for domain from/to file ! ! ! ! write: write mwRTM params for N_tile tiles in domain ! ! -! ! read: read mwRTM params for -! +! ! read: read mwRTM params for +! ! ! ! ! reichle, 1 Jun 2011 ! ! reichle, 21 Oct 2011 -- added "read" for mwRTM params ! ! reichle, 22 Oct 2012 -- added check for tile_id to mwRTM param input -! ! +! ! ! ! ------------------------------------------------------------------- -! +! ! implicit none -! +! ! character, intent(in) :: action -! +! ! integer, intent(in) :: unitnum -! +! ! integer, intent(in) :: N_tile ! =N_catd -! +! ! type(mwRTM_param_type), dimension(N_tile), intent(inout) :: mwp ! -! integer, optional, intent(in) :: N_catg +! integer, optional, intent(in) :: N_catg ! ! integer, optional, dimension(N_tile), intent(in) :: tile_id, d2g ! ! ! local variables -! +! ! integer :: n, N_tmp ! ! integer, dimension(:), allocatable :: tmpint @@ -140,125 +140,125 @@ module mwRTM_types ! ! ------------------------------------------------------------------ ! ! select case (action) -! +! ! case ('w','W') ! write mwp for all tiles in domain -! +! ! write (unitnum) N_tile -! +! ! write (unitnum) (mwp(n)%vegcls , n=1,N_tile) ! integer ! write (unitnum) (mwp(n)%soilcls , n=1,N_tile) ! integer -! -! write (unitnum) (mwp(n)%sand , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%clay , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%poros , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%wang_wt , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%wang_wp , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%rgh_hmin , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_hmax , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_wmin , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_wmax , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_Nrh , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_Nrv , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_polmix, n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%omega , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%bh , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%bv , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%lewt , n=1,N_tile) ! real -! +! +! write (unitnum) (mwp(n)%sand , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%clay , n=1,N_tile) ! real +! +! write (unitnum) (mwp(n)%poros , n=1,N_tile) ! real +! +! write (unitnum) (mwp(n)%wang_wt , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%wang_wp , n=1,N_tile) ! real +! +! write (unitnum) (mwp(n)%rgh_hmin , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_hmax , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_wmin , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_wmax , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_Nrh , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_Nrv , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%rgh_polmix, n=1,N_tile) ! real +! +! write (unitnum) (mwp(n)%omega , n=1,N_tile) ! real +! +! write (unitnum) (mwp(n)%bh , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%bv , n=1,N_tile) ! real +! write (unitnum) (mwp(n)%lewt , n=1,N_tile) ! real +! ! case ('r','R') ! ! ! read the parameters for all global tiles (similar to read_land_parameters()) -! +! ! ! optional inputs N_catg and d2g must be present -! +! ! if ( (.not. present(N_catg )) .or. & ! (.not. present(tile_id)) .or. & ! (.not. present(d2g )) ) then ! err_msg = 'missing optional inputs N_catg, tile_id, d2g' ! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) ! end if -! +! ! ! read how many tiles are in file and double-check against N_catg -! +! ! read (unitnum) N_tmp -! +! ! if (N_tmp .ne. N_catg) then ! err_msg = 'number of tiles in file .ne. N_catg' ! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) ! end if -! +! ! ! allocate tmp vectors -! +! ! allocate(tmpint( N_catg)) ! allocate(tmpreal(N_catg)) -! +! ! ! read tile IDs (first record) -! +! ! read (unitnum) tmpint; ! ! ! make sure tile IDs match (works only for "SiB2_V2" and newer versions) -! +! ! if (any(tile_id/=tmpint(d2g(1:N_tile)))) then ! err_msg = 'mismatch of tile IDs for mwRTM_parameters' ! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) ! end if -! +! ! ! read and subset from global tile space to domain -! +! ! read (unitnum) tmpint; mwp(1:N_tile)%vegcls = tmpint( d2g(1:N_tile)) ! read (unitnum) tmpint; mwp(1:N_tile)%soilcls = tmpint( d2g(1:N_tile)) -! +! ! read (unitnum) tmpreal; mwp(1:N_tile)%sand = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%clay = tmpreal(d2g(1:N_tile)) -! +! ! read (unitnum) tmpreal; mwp(1:N_tile)%poros = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%wang_wt = tmpreal(d2g(1:N_tile)) +! +! read (unitnum) tmpreal; mwp(1:N_tile)%wang_wt = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%wang_wp = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_hmin = tmpreal(d2g(1:N_tile)) +! +! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_hmin = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_hmax = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_wmin = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_wmax = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_Nrh = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_Nrv = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_polmix = tmpreal(d2g(1:N_tile)) -! +! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_polmix = tmpreal(d2g(1:N_tile)) +! ! read (unitnum) tmpreal; mwp(1:N_tile)%omega = tmpreal(d2g(1:N_tile)) -! +! ! read (unitnum) tmpreal; mwp(1:N_tile)%bh = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%bv = tmpreal(d2g(1:N_tile)) ! read (unitnum) tmpreal; mwp(1:N_tile)%lewt = tmpreal(d2g(1:N_tile)) -! +! ! ! clean up ! ! deallocate(tmpreal) ! deallocate(tmpint) -! +! ! case default -! +! ! err_msg = 'unknown action ' // action ! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! +! ! end select -! +! ! end subroutine io_mwRTM_param_type - + ! ************************************************************ - + subroutine scalar2mwRTM_param( mwRTM_param, scalar ) - + implicit none - + real, intent(in) :: scalar - + type(mwRTM_param_type), intent(out) :: mwRTM_param - + ! --------------------- mwRTM_param%vegcls = nint(scalar) @@ -281,41 +281,41 @@ subroutine scalar2mwRTM_param( mwRTM_param, scalar ) mwRTM_param%bv = scalar mwRTM_param%lewt = scalar mwRTM_param%vegopacity = scalar - + end subroutine scalar2mwRTM_param ! ************************************************************ - + subroutine mwRTM_param_nodata_check( mwp, mwp_nodata ) ! check microwave radiative transfer model parameters for no-data values ! ! if there is a no-data value in any required field, set "all" fields - ! within the corresponding group of parameters to no-data + ! within the corresponding group of parameters to no-data ! ! vegetation attenuation parameters can come from either of two sources: ! - static look-up table or calibrated parameters (bh, bv, lewt), to be combined ! with time-varying LAI ! - vegetation opacity (from file); varies with time ! - ! preprocessing of the mwRTM restart and vegopacity files must ensure that + ! preprocessing of the mwRTM restart and vegopacity files must ensure that ! either (bh,bv,lewt) or (vegopacity) is no-data ! ! - reichle, 13 July 2021 (revised for using vegopacity from file) - + implicit none - + type(mwRTM_param_type), intent(inout) :: mwp - + logical, intent( out), optional :: mwp_nodata - + ! local variables - + logical :: veg_atten_static_params_nodata, veg_params_nodata, other_params_nodata real :: realvegcls, realsoilcls - character(len=*), parameter :: Iam = 'mwRTM_param_nodata_check' + character(len=*), parameter :: Iam = 'mwRTM_param_nodata_check' character(len=400) :: err_msg ! ----------------------------------------------------------------------------- @@ -328,53 +328,53 @@ subroutine mwRTM_param_nodata_check( mwp, mwp_nodata ) veg_atten_static_params_nodata = & ( & - LDAS_is_nodata( mwp%bh ) .or. & + LDAS_is_nodata( mwp%bh ) .or. & LDAS_is_nodata( mwp%bv ) .or. & LDAS_is_nodata( mwp%lewt ) & ) - + if ( (.not. veg_atten_static_params_nodata) .and. (.not. LDAS_is_nodata( mwp%vegopacity )) ) then - - ! inconsistent mwRTM restart and vegopacity files: + + ! inconsistent mwRTM restart and vegopacity files: ! for a given tile, (bh, bv, lewt) from mwRTM restart and (vegopacity) from file must ! not both have good values - + err_msg = 'inconsistent mwRTM restart and vegopacity files: found good values for (bh,bv,lewt) *and* (vegopacity)' call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - + end if ! return if *only* interested in checking no-data consistency for veg attenuation params - + if (.not. present(mwp_nodata)) return - ! - - - - - - - - - - - - - - - - - - - - - - + ! - - - - - - - - - - - - - - - - - - - - - - ! ! rest of subroutine only needs to run once - if ( veg_atten_static_params_nodata ) then - + if ( veg_atten_static_params_nodata ) then + ! make sure all related fields in this group are no-data if at least one is nodata - + mwp%bh = nodata_generic mwp%bv = nodata_generic mwp%lewt = nodata_generic - + end if - + ! veg_params_nodata = .true. if missing vegetation attenuation info altogether - + veg_params_nodata = & ( & veg_atten_static_params_nodata & .and. & - LDAS_is_nodata( mwp%vegopacity ) & + LDAS_is_nodata( mwp%vegopacity ) & ) ! ----------------------------------------------------------------------------- ! Group 2: Parameters for the rest of the tau-omega equations - + realvegcls = real(mwp%vegcls) realsoilcls = real(mwp%soilcls) @@ -395,12 +395,12 @@ subroutine mwRTM_param_nodata_check( mwp, mwp_nodata ) LDAS_is_nodata( mwp%rgh_Nrv ) .or. & LDAS_is_nodata( mwp%rgh_polmix ) .or. & LDAS_is_nodata( mwp%omega ) & - ) + ) if ( other_params_nodata ) then - + ! make sure all related fields in this group are no-data if at least one is nodata - + mwp%vegcls = nint(nodata_generic) mwp%soilcls = nint(nodata_generic) mwp%sand = nodata_generic @@ -416,27 +416,27 @@ subroutine mwRTM_param_nodata_check( mwp, mwp_nodata ) mwp%rgh_Nrv = nodata_generic mwp%rgh_polmix = nodata_generic mwp%omega = nodata_generic - + end if - + ! ----------------------------------------------------------------------------- - + ! need both groups for full tau-omega calculations: - + if ( veg_params_nodata .or. other_params_nodata ) then - + mwp_nodata = .true. - + else - + mwp_nodata = .false. - + end if - + end subroutine mwRTM_param_nodata_check - + end module mwRTM_types - + ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if 0 @@ -444,15 +444,15 @@ end module mwRTM_types ! driver routines for testing program test_mwRTM_types - + use mwRTM_types - + implicit none - + type(mwRTM_param_type) :: mwRTM_param - + mwRTM_param = -9999. - + write (*,*) mwRTM_param mwRTM_param%lewt = 0.5 @@ -460,8 +460,8 @@ program test_mwRTM_types write (*,*) mwRTM_param call mwRTM_param_nodata_check(mwRTM_param) - - write (*,*) mwRTM_param + + write (*,*) mwRTM_param end program test_mwRTM_types diff --git a/src/Applications/LDAS_App/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt similarity index 100% rename from src/Applications/LDAS_App/CMakeLists.txt rename to src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt diff --git a/src/Applications/LDAS_App/GEOSldas.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 similarity index 100% rename from src/Applications/LDAS_App/GEOSldas.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 diff --git a/src/Applications/LDAS_App/GEOSldas_CAP.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc similarity index 100% rename from src/Applications/LDAS_App/GEOSldas_CAP.rc rename to src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc diff --git a/src/Applications/LDAS_App/GEOSldas_ExtData.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_ExtData.rc similarity index 100% rename from src/Applications/LDAS_App/GEOSldas_ExtData.rc rename to src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_ExtData.rc diff --git a/src/Applications/LDAS_App/GEOSldas_HIST.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc similarity index 100% rename from src/Applications/LDAS_App/GEOSldas_HIST.rc rename to src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc diff --git a/src/Applications/LDAS_App/GEOSldas_LDAS.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc similarity index 100% rename from src/Applications/LDAS_App/GEOSldas_LDAS.rc rename to src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc diff --git a/src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_adapt.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml similarity index 100% rename from src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_adapt.nml rename to src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml diff --git a/src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_catbias.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml similarity index 100% rename from src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_catbias.nml rename to src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml diff --git a/src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_ensprop.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml similarity index 100% rename from src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_ensprop.nml rename to src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml diff --git a/src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_ensupd.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml similarity index 100% rename from src/Applications/LDAS_App/LDASsa_DEFAULT_inputs_ensupd.nml rename to src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml diff --git a/src/Applications/LDAS_App/README_LDAS_App b/src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App similarity index 56% rename from src/Applications/LDAS_App/README_LDAS_App rename to src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App index d36a506d..3cc60e01 100644 --- a/src/Applications/LDAS_App/README_LDAS_App +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App @@ -1,36 +1,36 @@ -README_LDAS_App: README file for GEOSldas/src/Applications/LDAS_App +README_GEOSldas_App: README file for GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App rreichle, 8 July 2022: Initial version This directory contains a collection of programs, scripts, and config files, specifically: -[..]/LDAS_App/ +[..]/GEOSldas_App/ - Config files and programs/scripts needed by ldas_setup or lenkf.j (GEOSldas job script). -[..]/LDAS_App/ens_forcing/ +[..]/GEOSldas_App/ens_forcing/ - Scripts needed by lenkf.j to process ensemble-based forcing (primarily for LADAS). -[..]/LDAS_App/sample_config_files/ +[..]/GEOSldas_App/sample_config_files/ -- Sample config files for ldas_setup and HISTORY. +- Sample config files for ldas_setup and HISTORY. -[..]/LDAS_App/util/config/ +[..]/GEOSldas_App/util/config/ - Miscellaneous scripts to (manually) create/modify config files. -[..]/LDAS_App/util/inputs/ +[..]/GEOSldas_App/util/inputs/ - Miscellaneous scripts to (manually) create/modify input files. -[..]/LDAS_App/util/postproc/ +[..]/GEOSldas_App/util/postproc/ -- Miscellaneous scripts for post-processing GEOSldas output. +- Miscellaneous scripts for post-processing GEOSldas output. -[..]/LDAS_App/util/shared/ +[..]/GEOSldas_App/util/shared/ - Miscellaneous shared reader and helper scripts (primarily matlab). -=============== EOF =============================================================== \ No newline at end of file +=============== EOF =============================================================== diff --git a/src/Applications/LDAS_App/ens_forcing/average_ensemble_forcing.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py similarity index 100% rename from src/Applications/LDAS_App/ens_forcing/average_ensemble_forcing.py rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py diff --git a/src/Applications/LDAS_App/ens_forcing/enpert_forc.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh similarity index 100% rename from src/Applications/LDAS_App/ens_forcing/enpert_forc.csh rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh diff --git a/src/Applications/LDAS_App/ens_forcing/ensemble_forc.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py similarity index 100% rename from src/Applications/LDAS_App/ens_forcing/ensemble_forc.py rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py diff --git a/src/Applications/LDAS_App/ens_forcing/regrid_forc.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh similarity index 100% rename from src/Applications/LDAS_App/ens_forcing/regrid_forc.csh rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh diff --git a/src/Applications/LDAS_App/ens_forcing/test_enpert_forc.j b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j similarity index 100% rename from src/Applications/LDAS_App/ens_forcing/test_enpert_forc.j rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j diff --git a/src/Applications/LDAS_App/ldas_setup b/src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup similarity index 100% rename from src/Applications/LDAS_App/ldas_setup rename to src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup diff --git a/src/Applications/LDAS_App/lenkf.j.template b/src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template similarity index 100% rename from src/Applications/LDAS_App/lenkf.j.template rename to src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template diff --git a/src/Applications/LDAS_App/preprocess_ldas.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 similarity index 100% rename from src/Applications/LDAS_App/preprocess_ldas.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 diff --git a/src/Applications/LDAS_App/preprocess_ldas_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 similarity index 100% rename from src/Applications/LDAS_App/preprocess_ldas_routines.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 diff --git a/src/Applications/LDAS_App/process_hist.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh similarity index 100% rename from src/Applications/LDAS_App/process_hist.csh rename to src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh diff --git a/src/Applications/LDAS_App/remap_config_ldas.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/remap_config_ldas.py similarity index 100% rename from src/Applications/LDAS_App/remap_config_ldas.py rename to src/Components/GEOSldas_GridComp/GEOSldas_App/remap_config_ldas.py diff --git a/src/Applications/LDAS_App/sample_config_files/LADAS/HISTORY.rc.atmens b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.atmens similarity index 99% rename from src/Applications/LDAS_App/sample_config_files/LADAS/HISTORY.rc.atmens rename to src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.atmens index 0f3e7f1e..5b24ddf9 100644 --- a/src/Applications/LDAS_App/sample_config_files/LADAS/HISTORY.rc.atmens +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.atmens @@ -2,19 +2,19 @@ # # Sample GEOSldas HISTORY.rc file for LADAS (atm ensemble) # -# - This sample HISTORY.rc is for the GEOSldas instance that is weakly coupled with the +# - This sample HISTORY.rc is for the GEOSldas instance that is weakly coupled with the # atmospheric ensemble component of the Hybrid-4DEnVar ADAS (ADASens). # -# - The sample file was generated with the utility script -# "GEOSldas/src/Applications/LDAS_App/util/config/generate_catchincr_hist.py". +# - The sample file was generated with the utility script +# "GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py". # -# - The sample file triggers output of the GEOSldas "catch_progn_incr" collection in +# - The sample file triggers output of the GEOSldas "catch_progn_incr" collection in # ensemble space, which is needed by ADASens. # # - The IDs of the ensemble members and their total number in GEOSldas must match # those of ADASens. # -# - The "catch_progn_incr" output is in tile space, which must be the same for +# - The "catch_progn_incr" output is in tile space, which must be the same for # GEOSldas and ADASens. # # diff --git a/src/Applications/LDAS_App/sample_config_files/LADAS/HISTORY.rc.central b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.central similarity index 100% rename from src/Applications/LDAS_App/sample_config_files/LADAS/HISTORY.rc.central rename to src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.central diff --git a/src/Applications/LDAS_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens similarity index 100% rename from src/Applications/LDAS_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens rename to src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens diff --git a/src/Applications/LDAS_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central similarity index 100% rename from src/Applications/LDAS_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central rename to src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central diff --git a/src/Applications/LDAS_App/tile_bin2nc4.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 similarity index 100% rename from src/Applications/LDAS_App/tile_bin2nc4.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 diff --git a/src/Applications/LDAS_App/util/config/Create_ccorr_cat_progn_default.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m similarity index 100% rename from src/Applications/LDAS_App/util/config/Create_ccorr_cat_progn_default.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m diff --git a/src/Applications/LDAS_App/util/config/generate_catchincr_hist.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py similarity index 89% rename from src/Applications/LDAS_App/util/config/generate_catchincr_hist.py rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py index ce15d61f..a6926450 100755 --- a/src/Applications/LDAS_App/util/config/generate_catchincr_hist.py +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py @@ -1,7 +1,7 @@ #!/usr/bin/env python # -# This code works with the python version loaded by g5_modules associated with GEOSldas v17.13.1: -# python/GEOSpyD/Min4.11.0_py3.9_AND_Min4.8.3_py2.7 +# This code works with the python version loaded by g5_modules associated with GEOSldas v17.13.1: +# python/GEOSpyD/Min4.11.0_py3.9_AND_Min4.8.3_py2.7 # # This script generates a sample HISTORY.rc file for GEOSldas to write Catchment # model analysis increments in ensemble space, as needed in the weakly-coupled @@ -25,19 +25,19 @@ # # Sample GEOSldas HISTORY.rc file for LADAS (atm ensemble) # -# - This sample HISTORY.rc is for the GEOSldas instance that is weakly coupled with the +# - This sample HISTORY.rc is for the GEOSldas instance that is weakly coupled with the # atmospheric ensemble component of the Hybrid-4DEnVar ADAS (ADASens). # -# - The sample file was generated with the utility script -# "GEOSldas/src/Applications/LDAS_App/util/config/generate_catchincr_hist.py". +# - The sample file was generated with the utility script +# "GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py". # -# - The sample file triggers output of the GEOSldas "catch_progn_incr" collection in +# - The sample file triggers output of the GEOSldas "catch_progn_incr" collection in # ensemble space, which is needed by ADASens. # # - The IDs of the ensemble members and their total number in GEOSldas must match # those of ADASens. # -# - The "catch_progn_incr" output is in tile space, which must be the same for +# - The "catch_progn_incr" output is in tile space, which must be the same for # GEOSldas and ADASens. # # @@ -89,15 +89,15 @@ # ------------------------------------------------------------------ # -# write file "HISTORY.rc" with nens "catch_progn_incrXXXX" collections, +# write file "HISTORY.rc" with nens "catch_progn_incrXXXX" collections, # one for each ensemble member with open('HISTORY.rc', 'w') as f: f.write(heads) collection, body = hist_template.split('::\n') - collection = collection.strip('\n').strip("'") + collection = collection.strip('\n').strip("'") for i in range(nens): - i = i +1 + i = i +1 sfx = '%04d'%(i) ids = "'"+collection+sfx+"'" f.write(ids+'\n') @@ -112,10 +112,10 @@ if ":" in line : newline = collect+line if "CATCHINCR_e" in newline: - sfx = '%04d'%(i) + sfx = '%04d'%(i) frep = 'CATCHINCR_e'+sfx newline = newline.replace('CATCHINCR_e',frep) f.write(newline+'\n') - f.write('::\n') + f.write('::\n') # ====================== EOF ===================================== diff --git a/src/Applications/LDAS_App/util/config/rewind_GEOSldas.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh similarity index 100% rename from src/Applications/LDAS_App/util/config/rewind_GEOSldas.csh rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh diff --git a/src/Applications/LDAS_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt similarity index 100% rename from src/Applications/LDAS_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt diff --git a/src/Applications/LDAS_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 similarity index 100% rename from src/Applications/LDAS_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m similarity index 93% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m index 6a9859ce..a478214b 100644 --- a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m @@ -1,33 +1,33 @@ % --------------------------------------------------------------------------- -% This script is to generate the mwRTM_param.nc4 file for the GEOSldas mwRTM. -% All constant mwRTM parameters are in this file. They come from 3 different +% This script is to generate the mwRTM_param.nc4 file for the GEOSldas mwRTM. +% All constant mwRTM parameters are in this file. They come from 3 different % sources: cat_param, vegcls lookup table and preprocessed L2DCA daily mat files. -% Therefore, need to run Preprocess_L2DCA_mwRTM_into_dailymat.m before running -% this script. +% Therefore, need to run Preprocess_L2DCA_mwRTM_into_dailymat.m before running +% this script. % qliu + rreichle, 29 Jul 2022 % ---------------------------------------------------------------------------- -clear +clear -% add path to matlab functions in src/Applications/LDAS_App/util/shared/matlab/ +% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ addpath('../../shared/matlab/'); -% option to fill small gaps based on neighboring grids, 1 is recommended. -fill_small_gaps = 1; +% option to fill small gaps based on neighboring grids, 1 is recommended. +fill_small_gaps = 1; % fill value in output file fillValue = single(1.e15); % resolution of output parameters: only works with "M09" or "M36". -EASEv2_grid = 'M09'; +EASEv2_grid = 'M09'; % older version mwRTM_param.nc4 file for parameter names and attributes -fname_in = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_SMAP_L4SM_v004/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param.nc4']; +fname_in = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_SMAP_L4SM_v004/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param.nc4']; % target mwRTM_param file name -fname_out = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_L2_omega_H_tmp/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param_L2_omega_H_fillValue_bhbvlewt.nc4']; +fname_out = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_L2_omega_H_tmp/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param_L2_omega_H_fillValue_bhbvlewt.nc4']; % get inputs for fill_gaps_in_tiledata() below if fill_small_gaps @@ -41,18 +41,18 @@ else error('invalid resolution, use ''M09'' or ''M36'' only') end - + tmpstr = num2str(N_cells); fname_out = strrep(fname_out,'.nc4','_',tmpstr,'gx',tmpstr,'gfilled.nc4'); end -% Do not overwrite if file exists +% Do not overwrite if file exists if exist(fname_out,'file') - + disp(['file exist ',fname_out]) return - + end % GEOSldas experiment for tilecoord and cat_params @@ -104,7 +104,7 @@ L2_param = get_L2_RTM_constants_tile_data(tc,L2_file_tag,... L2_version,L2_start_time, L2_end_time); omega = L2_param.Albedo; -hparam = L2_param.Roughness; +hparam = L2_param.Roughness; clear L2_param % cat_param based parameters @@ -137,39 +137,39 @@ nvar_in_file = length(finfo.Variables); for i=1: nvar_in_file - + data_name = finfo.Variables(i).Name; data_type = finfo.Variables(i).Datatype; - + data_type = 'float'; - + data_size = finfo.Variables(i).Size; - + varid(i) = netcdf.defVar(fout_id, data_name, data_type, Dim_id ); - + netcdf.defVarFill(fout_id, varid(i), false, fillValue); - + n_attr = length(finfo.Variables(i).Attributes); - + for iv = 1:n_attr att_name = finfo.Variables(i).Attributes(iv).Name; att_value = finfo.Variables(i).Attributes(iv).Value; - + netcdf.putAtt(fout_id, varid(i), att_name, att_value); end - + netcdf.endDef(fout_id); - + startVAR = repmat([0], 1, length(data_size)); countVAR = data_size; - + % get parameter values from their respective sources % Total of 18 mwRTM parameters: % 8 from cat_param: SOILCLS, SOIL, CLAY, POROS, WANGWT, WANTWP, RGHWMIN, RGHWMAX % 4 from vegcls lookup table : VEGCLS, RGHNRH, RGHNRV,POLMIX % 3 from L2RTM: RGHHMIN, RGHHMAX, OMEGA % 3 are set to fillValue: BH,BV, OMEGA - + if strcmp(data_name,'MWRTM_OMEGA') if fill_small_gaps omega_filled = fill_gaps_in_tiledata(tc, tg, transpose(omega), N_cells, iscube ); @@ -187,7 +187,7 @@ elseif strcmp(data_name,'MWRTM_SOILCLS') data = mwRTMparam.soilcls; elseif strcmp(data_name,'MWRTM_SAND') - data = mwRTMparam.sand; + data = mwRTMparam.sand; elseif strcmp(data_name,'MWRTM_CLAY') data = mwRTMparam.clay; elseif strcmp(data_name,'MWRTM_POROS') @@ -217,7 +217,7 @@ data = tmp_rtm.vegcls; elseif strcmp(data_name,'MWRTM_RGHPOLMIX') data = tmp_rtm.rgh_polmix; - end + end end % earlier fillValue was -9999. replace with new fillValue (1.e15) @@ -226,9 +226,9 @@ data(isnan(data)) = fillValue; netcdf.putVar(fout_id, varid(i), startVAR, countVAR, data); clear data - + netcdf.reDef(fout_id); - + end netcdf.endDef(fout_id); diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m similarity index 93% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m index 13272941..19eb1336 100644 --- a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m @@ -1,18 +1,18 @@ -% script to create 8-day climatology of vegetation opacity for L-band microwave +% script to create 8-day climatology of vegetation opacity for L-band microwave % radiative transfer model (mwRTM) % % requires pre-processing of SMAP L2 data into daily *.mat files using % Preprocess_L2DCA_mwRTM_params_to_dailymat.m -% +% % output files written in MAPL_ReadForcing format % % qliu + rreichle, 29 Jul 2022 % % ------------------------------------------------------------------------------------- -clear +clear -% add path to matlab functions in src/Applications/LDAS_App/util/shared/matlab/ +% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ addpath('../../shared/matlab/'); L2_Ascdes_all = {'_A_','_D_'}; @@ -64,31 +64,31 @@ float_precision = 'float32'; for iAD = 1:2 - + L2_Ascdes = L2_Ascdes_all{iAD}; L2_qc_yes = 1; - + dtstep = 10800; - + % time period for computing climatology start_time.year = 2015; start_time.month = 4; start_time.day = 1; - + start_time.hour = 1; start_time.min = 30; start_time.sec = 0; - + end_time.year = 2022; end_time.month = 4; end_time.day = 1; end_time.hour = start_time.hour; end_time.min = start_time.min; end_time.sec = start_time.sec; - + start_time = get_dofyr_pentad(start_time); end_time = get_dofyr_pentad(end_time); - + % lookup table of month and day of first day in 8-day average (non-leap year) clim_8d_m1 = [ 1 1 1 1 2 2 2 2 ... @@ -104,12 +104,12 @@ 4 12 20 28 5 13 21 29 ... 6 14 22 30 8 16 24 ... 1 9 17 25 3 11 19 27 ]; - + clim_8d_m2 = [clim_8d_m1(2:46) 1]; clim_8d_d2 = [clim_8d_d1(2:46) 1]; - + % ----------------------------------------------------------------------- - % read from preprocessed daily mat file + % read from preprocessed daily mat file if end_time.month ==1 time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... '_',num2str(end_time.year-1,'%4.4d'),'12']; @@ -117,36 +117,36 @@ time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... '_',num2str(end_time.year,'%4.4d'),num2str(end_time.month-1,'%2.2d')]; end - + fname_clim = [out_path,'/',out_Para,'_clim_L2_',L2_version,L2_Ascdes,'8d_',resolution,'tile_',time_tag,'_w24d.bin']; - + L2_tau_clim_sum = zeros(46,out_Nlon,out_Nlat); N_L2_clim_sum = zeros(46,out_Nlon,out_Nlat); - + if exist(fname_clim,'file') - + disp(['found preprocessed climatology file ',fname_clim]) - + else - + date_time = start_time; - + while 1 - + if (date_time.year ==end_time.year && ... date_time.month==end_time.month && ... date_time.day ==end_time.day ) break end - + outfile_tag = [num2str(date_time.year,'%4.4d'), ... num2str(date_time.month,'%2.2d'), ... num2str(date_time.day,'%2.2d')]; - + mat_fname = [out_path,'L2DCA_RTM_',L2_file_tag,'_',L2_version,L2_Ascdes, outfile_tag,'.mat']; - + if exist(mat_fname,'file') - + disp(['loading ', mat_fname]) if contains(fname_clim,'VOD_') load(mat_fname,'L2_tau') @@ -159,7 +159,7 @@ else error(['unknown clim fname ',fname_clim]) end - + d_idx = find(date_time.month == clim_8d_m1 & date_time.day >= clim_8d_d1); if ~isempty(d_idx) d_idx = d_idx(end); @@ -167,44 +167,44 @@ d_idx = find(date_time.month == clim_8d_m2 & date_time.day < clim_8d_d2); d_idx = d_idx(1); end - + % compute climatology tmp = max(L2_tau,0); % make sure no negative values in tau tmp(isnan(tmp)) = 0; - + L2_tau_clim_sum(d_idx,:,:) = squeeze(L2_tau_clim_sum(d_idx,:,:)) + tmp; clear tmp tmp = ~isnan(L2_tau); N_L2_clim_sum(d_idx,:,:) = squeeze(N_L2_clim_sum(d_idx,:,:)) + tmp; clear tmp - + clear L2_tau - + else - + error('daily mat file not found') - + end - + date_time = augment_date_time(86400, date_time); - + end - + L2_tau_clim = L2_tau_clim_sum ./N_L2_clim_sum; - - + + % regrid to til grid - + L2_tau_tile = NaN + ones(46, tc.N_tile); for k = 1:tc.N_tile L2_tau_tile(:,k) = L2_tau_clim(:,tc.i_indg(k)+1, tc.j_indg(k)+1); end - + ifp = fopen(fname_clim,'w','l'); - + for n = 1: 48 if n == 1 y1 = 0; y2 = 1; - + nidx = 46; nidx_pre = 45; nidx_nxt = 1; @@ -217,7 +217,7 @@ elseif n == 47 y1 = 1; y2 = 2; - + nidx = n-1; nidx_pre = n-2; nidx_nxt = 1; @@ -238,25 +238,25 @@ m2 = clim_8d_m2(nidx); d1 = clim_8d_d1(nidx); d2 = clim_8d_d2(nidx); - + header = [y1 m1 d1 0 0 0 y2 m2 d2 0 0 0 tc.N_tile 1]; - + tile_data = mean(L2_tau_tile([nidx_pre nidx nidx_nxt],:),1,"omitnan"); tile_data(isnan(tile_data)) = 1.e15; - + fwrite( ifp, 14*4, int_precision ); % fortran_tag fwrite( ifp, header, float_precision ); fwrite( ifp, 14*4, int_precision ); % fortran_tag - + fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag fwrite( ifp, tile_data(:), float_precision ); fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag - + clear header tile_data end fclose(ifp) end - + end % ======================== @@ -265,29 +265,29 @@ % time constant with maximum spatial coverage data_clim_tile = NaN + ones(48, tc.N_tile,2); for iAD = 1:2 - + L2_Ascdes = L2_Ascdes_all{iAD}; - + fname = [out_path,'/',out_Para,'_clim_L2_',L2_version,L2_Ascdes,'8d_',resolution,'tile_',time_tag,'_w24d.bin']; - + disp(['read ',fname]) ifp = fopen(fname,'r','l'); - + for n = 1:48 - + fortran_tag = fread( ifp, 1, int_precision ); tmp = fread( ifp, 14, float_precision ); header(n,:) = tmp; fortran_tag = fread( ifp, 1, int_precision ); - + fortran_tag = fread( ifp, 1, int_precision ); tmp = fread( ifp, tc.N_tile, float_precision ); fortran_tag = fread( ifp, 1, int_precision ); - + data_clim_tile(n,:,iAD) = tmp; - + end - + fclose(ifp); end @@ -298,7 +298,7 @@ tile_data = mean(data_clim_tile,3,"omitnan"); fname_out = strrep(fname, L2_Ascdes,'_AD_'); if fill_small_gaps - + if strcmp(resolution,'M09') N_cells = 5; iscube = 0; @@ -308,9 +308,9 @@ else error('invalid resolution, use ''M09'' or ''M36'' only') end - + tmpstr = num2str(N_cells); - + fname_out = [fname_out(1:end-4),'_',tmpstr,'gx',tmpstr,'gfilled_test.bin']; tile_data = fill_gaps_in_tiledata(tc, tg, tile_data, N_cells, iscube ); @@ -329,7 +329,7 @@ fwrite( ifp, 14*4, int_precision ); fwrite( ifp, header(n,:), float_precision ); fwrite( ifp, 14*4, int_precision ); - + % write science data fwrite( ifp, tc.N_tile*4, int_precision ); diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m similarity index 89% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m index 6e2d9fdf..061229b4 100644 --- a/src/Applications/LDAS_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m @@ -1,18 +1,18 @@ -% Script to read SMAP L2 files and extract RTM variables (albedo, vegopacity, roughness) +% Script to read SMAP L2 files and extract RTM variables (albedo, vegopacity, roughness) % to store in global EASEv2 grid daily composite (Asc and Desc separately) mat files for future use. % Q. Liu 18 Jul 2022 - -clear -% add path to matlab functions in src/Applications/LDAS_App/util/shared/matlab/ +clear + +% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ addpath('../../shared/matlab/'); -L2_Ascdes = {'_A_','_D_'}; +L2_Ascdes = {'_A_','_D_'}; L2_qc_yes = 1; % L2 file information. Use 'L2_SM_P' for M36 resolution and 'L2_SM_P_E' for M09 -SMAP_product = 'L2_SM_P'; %'L2_SM_P'; +SMAP_product = 'L2_SM_P'; %'L2_SM_P'; L2_path = ['/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/OPS/',SMAP_product,'/'] ; L2_version = 'R18290'; %'R17000'; @@ -25,7 +25,7 @@ start_time.month = 4; start_time.day = 1; -end_time.year = 2022; +end_time.year = 2022; end_time.month = 4; end_time.day = 1; @@ -51,43 +51,43 @@ date_time.hour = 0; date_time.min = 0; date_time.sec = 0; - + fname_L2_pre = []; - + while 1 - + if (date_time.year ==end_time.year && ... date_time.month==end_time.month && ... date_time.day ==end_time.day ) break end - + outfile_tag = [num2str(date_time.year,'%4.4d'), ... num2str(date_time.month,'%2.2d'), ... num2str(date_time.day,'%2.2d')]; - + mat_fname = [out_path,'L2DCA_RTM_',SMAP_product,'_',L2_version,L2_Ascdes{iorb}, outfile_tag,'.mat']; - + if exist(mat_fname,'file') - + disp(['mat file exist ',mat_fname]) - + else - + L2_tau = NaN + ones(out_Nlon,out_Nlat); L2_omg = NaN + ones(out_Nlon,out_Nlat); L2_h = NaN + ones(out_Nlon,out_Nlat); - + L2_data_path = [L2_path, '/Y', num2str(date_time.year,'%4.4d'), ... '/M', num2str(date_time.month, '%2.2d'), ... '/D', num2str(date_time.day, '%2.2d')]; - + % get list of all files in subdirectory of given date L2_files_all = dir([L2_data_path, '/SMAP_',SMAP_product,'*',L2_Ascdes{iorb},'*_',L2_version,'_*.h5']); - + % check if multiple versions of the same half orbit file % only keep the data with the highest version id - + L2_files = {}; kk = 0; % counter of the final file list % Remove duplicate files from the list when multiple versions exist @@ -105,65 +105,65 @@ L2_files{kk} = L2_files_all(ff).name; end end - + clear L2_fiels_all L2_fname if ~isempty(L2_files) - + for ifile = 1:length(L2_files) L2_fname{ifile} = [L2_data_path,'/', L2_files{ifile}]; end - + if ~isempty(fname_L2_pre) L2_fname((ifile+1):(ifile+length(fname_L2_pre))) = fname_L2_pre; end - + fname_L2_pre = []; - + ii = 0; for ifile = 1: length(L2_fname) - + fname = L2_fname{ifile}; - + disp(fname) - + L2_row = h5read(fname,'/Soil_Moisture_Retrieval_Data/EASE_row_index'); %zero-based L2_row = L2_row + 1; L2_col = h5read(fname,'/Soil_Moisture_Retrieval_Data/EASE_column_index'); L2_col = L2_col + 1; - + L2_utc_seconds = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_time_seconds'); - + L2_vod = h5read(fname,'/Soil_Moisture_Retrieval_Data/vegetation_opacity_option3'); fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/vegetation_opacity_option3','_FillValue'); L2_vod(L2_vod == fill_value) = NaN; - + L2_alb = h5read(fname,'/Soil_Moisture_Retrieval_Data/albedo_option3'); fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/albedo_option3','_FillValue'); L2_alb(L2_alb == fill_value) = NaN; - + L2_rough = h5read(fname,'/Soil_Moisture_Retrieval_Data/roughness_coefficient_option3'); fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/roughness_coefficient_option3','_FillValue'); L2_rough(L2_rough == fill_value) = NaN; - + % quality flag L2_qf = h5read(fname,'/Soil_Moisture_Retrieval_Data/retrieval_qual_flag_option3'); - + % surface status land = 0, nonland = 1 L2_ss = h5read(fname,'/Soil_Moisture_Retrieval_Data/grid_surface_status'); - + % surface flag L2_sf = h5read(fname,'/Soil_Moisture_Retrieval_Data/surface_flag'); - + L2_rfi_h = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_qual_flag_h'); L2_rfi_v = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_qual_flag_v'); - + % exclude points according to quality flag if L2_qc_yes - + % QC based on retrieval quality flag %L2_rt = bitget(L2_qf, 1); % only use retrieval_recommended L2_rt = bitget(L2_qf, 3); % use retrieval_succeeded - + % QC b ased on surface flag L2_frozen_model = bitget(L2_sf, 9); % model frozen ground L2_snow = bitget(L2_sf,6); % snow and ice @@ -173,7 +173,7 @@ idx = find(L2_rt == 0 & L2_frozen_model ==0 & ... L2_snow == 0 & L2_pice ==0 & L2_ss == 0 & ... L2_rfi_h_qf == 0 & L2_rfi_v_qf == 0); - + % only keep data/coord that pass QC L2_vod = L2_vod(idx); L2_alb = L2_alb(idx); @@ -183,25 +183,25 @@ L2_utc_seconds = L2_utc_seconds(idx); clear idx end - + if ~isempty(L2_vod) - + % round date_time to nearest 3 hourly UTC utc_t2k = round(double(L2_utc_seconds)/L2_dtstep)*L2_dtstep; - + [yr, doy, mm, dd, hr, mn] = J2000_to_DateTime( utc_t2k ); - + % use points for current UTC day only idx = find(yr == date_time.year & mm == date_time.month & ... dd == date_time.day); - + % points across UTC days will be saved in next daily file if length(idx) < length(L2_utc_seconds) && ifile <= length(L2_files) disp('L2 across UTC days') ii = ii + 1; fname_L2_pre{ii} = fname; end - + L2_vod = L2_vod(idx); L2_alb = L2_alb(idx); L2_rough = L2_rough(idx); @@ -210,30 +210,30 @@ L2_utc_seconds = L2_utc_seconds(idx); hr = hr(idx); clear idx - + % Map L2 to 2d grid for k = 1:length(L2_vod) this_col = L2_col(k); this_row = L2_row(k); - + L2_tau(this_col, this_row) = L2_vod(k); L2_omg(this_col, this_row) = L2_alb(k); L2_h(this_col, this_row) = L2_rough(k); end end end - + else - + disp(['no L2 data found in', L2_data_path]) pause end - + save(mat_fname,'L2_tau','L2_omg','L2_h') clear L2_tau L2_omg L2_h - + end - + date_time = augment_date_time(86400, date_time); end end diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m diff --git a/src/Applications/LDAS_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 similarity index 100% rename from src/Applications/LDAS_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m similarity index 90% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m index 62f54caa..b7e914fc 100644 --- a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m @@ -6,7 +6,7 @@ clear -% add path to matlab functions in src/Applications/LDAS_App/util/shared/matlab/ +% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ addpath('../../shared/matlab/'); %====== @@ -35,8 +35,8 @@ dt_assim = 3*60*60; % [seconds] land analysis time step, % same as LANDASSIM_DT in GEOSldas) -t0_assim = 0; % [seconds] land analysis "reference" time (offset from 0z), - % same as LANDASSIM_T0 in GEOSldas (except for units), +t0_assim = 0; % [seconds] land analysis "reference" time (offset from 0z), + % same as LANDASSIM_T0 in GEOSldas (except for units), % typically 0 in offline runs and 1.5*60*60 in LADAS %====== @@ -66,7 +66,7 @@ hscale = 0.0; % degrees lat/lon % Temporal sampling window(days), current hard coded and need to be divisive by 5 and be an odd number -w_days = 75; +w_days = 75; Ndata_min = 20; @@ -93,15 +93,15 @@ for oo=1:length(orbit) for pp=1:length(pol) for aa=1:length(inc_ang) - + add_species = obs_param(strcmp(var_name,{obs_param.varname}) & ... orbit(oo) == [obs_param.orbit] & ... inc_ang(aa) == [obs_param.ang] & ... pol(pp) == [obs_param.pol] & ... ~cellfun(@isempty, strfind({obs_param.descr},descr))).species; - + species = union(species,add_species); - + end end end @@ -110,65 +110,65 @@ % ------------------ for n=1:length(exp_run) - + if (exist('convert_grid','var')) - + if exist('time_of_day_in_hours','var') - - + + for j=1:length(time_of_day_in_hours) - + for k=1:length(run_months) - + get_model_and_obs_clim_stats( var_name, ... run_months{k}, exp_path, exp_run{n}, domain, ... start_year, end_year, ... dt_assim, t0_assim, species, obs_param, ... hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... convert_grid, time_of_day_in_hours(j) ); - + end - + end - + else - + get_model_and_obs_clim_stats( var_name, ... run_months, exp_path, exp_run{n}, domain, start_year, end_year, ... dt_assim, t0_assim, species, obs_param, ... hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... convert_grid ); - + end else - + if exist('time_of_day_in_hours','var') - - + + for j=1:length(time_of_day_in_hours) - + for k=1:length(run_months) - + get_model_and_obs_clim_stats( var_name, ... run_months{k}, exp_path, exp_run{n}, domain, ... start_year, end_year, ... dt_assim, t0_assim, species, obs_param, ... hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... time_of_day_in_hours(j) ); - + end - + end - + else - + get_model_and_obs_clim_stats( var_name, ... run_months, exp_path, exp_run{n}, domain, start_year, end_year, ... dt_assim, t0_assim, species, obs_param, ... hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out); - + end - + end end diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m similarity index 98% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m index 015f6762..20fc3832 100644 --- a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m @@ -5,7 +5,7 @@ % ------------------------------------------------------------------- % addpath('../../shared/matlab/'); -addpath('/discover/nobackup/amfox/current_GEOSldas/GEOSldas/src/Applications/LDAS_App/util/shared/matlab') +addpath('/discover/nobackup/amfox/current_GEOSldas/GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab') % Define the Open Loop experiment path, run name, domain, and output prefix @@ -33,7 +33,7 @@ grid_resolution = 0.25; -% Define moving window size over which statistics are calculated, +% Define moving window size over which statistics are calculated, % and minimum number of data points required to calculate statistics w_days = 75; @@ -68,20 +68,20 @@ for month = run_months % Initialize the earliest and latest year variables cnt = cnt + 1; - + % Check if the current year/month combination is earlier than the earliest if datenum(start_year, month, 1) < datenum(start_year, start_month, 1) earliest_year(cnt) = start_year+1; else earliest_year(cnt) = start_year; end - + % Check if the current year/month combination is later than the latest if datenum(end_year, month, 1) > datenum(end_year, end_month,1) latest_year(cnt) = end_year-1; else latest_year(cnt) = end_year; - end + end end % assume "ldas_obsparam" file is available at 0z on first day of start_month/start_year diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/dist_km2deg.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/dist_km2deg.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m diff --git a/src/Applications/LDAS_App/util/inputs/obs_scaling_params/write_seqbin_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m similarity index 100% rename from src/Applications/LDAS_App/util/inputs/obs_scaling_params/write_seqbin_file.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m diff --git a/src/Applications/LDAS_App/util/postproc/climatology/README b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/README rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README diff --git a/src/Applications/LDAS_App/util/postproc/climatology/Run_L4_sm_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/Run_L4_sm_clim_stats.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m diff --git a/src/Applications/LDAS_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m diff --git a/src/Applications/LDAS_App/util/postproc/climatology/get_model_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/get_model_clim_stats.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m diff --git a/src/Applications/LDAS_App/util/postproc/climatology/read_seqbin_clim_pctl_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/read_seqbin_clim_pctl_file.m similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/read_seqbin_clim_pctl_file.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/read_seqbin_clim_pctl_file.m diff --git a/src/Applications/LDAS_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m similarity index 100% rename from src/Applications/LDAS_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m diff --git a/src/Applications/LDAS_App/util/postproc/compress_bit-shaved_nc4.sh b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh similarity index 100% rename from src/Applications/LDAS_App/util/postproc/compress_bit-shaved_nc4.sh rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh diff --git a/src/Applications/LDAS_App/util/postproc/write_smapL4SMqa.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m similarity index 95% rename from src/Applications/LDAS_App/util/postproc/write_smapL4SMqa.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m index 7f510450..55be8d47 100644 --- a/src/Applications/LDAS_App/util/postproc/write_smapL4SMqa.m +++ b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m @@ -1,7 +1,7 @@ -function [] = write_smapL4SMqa( gph_aup_lmc_fnames, tilecoord_fname, tilegrids_fname ) +function [] = write_smapL4SMqa( gph_aup_lmc_fnames, tilecoord_fname, tilegrids_fname ) % THE FOLLOWING PATH SHOULD BE ADDED IN MATLAB SCRIPT THAT CALLS THIS FUNCTION -% add path to matlab functions in src/Applications/LDAS_App/util/shared/matlab/ +% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ addpath('../shared/matlab/'); % Generate *.qa files from SMAP L4_SM "gph" or "aup" granules. @@ -47,7 +47,7 @@ % % lmcpath = [exppath, '/', expid, '/', expdom, '/rc_out/', ... % '/Y', yyyymm(1:4), '/M', yyyymm(5:6), '/']; -% +% % tcpath = [exppath, '/', expid, '/', expdom, '/rc_out/']; % % tc_fname = [tcpath, expid, '.ldas_tilecoord.bin']; @@ -82,7 +82,7 @@ % for ii=1:length(gphnames) % % fnames{ii} = [gphpath, gphnames{ii}]; -% +% % end % % ii_off = length(gphnames); @@ -90,13 +90,13 @@ % for ii=1:length(aupnames) % % fnames{ii+ii_off} = [auppath, aupnames{ii}]; -% +% % end % % ii_off = ii_off + length(aupnames); -% +% % fnames{ii_off+1} = [lmcpath, lmcname]; -% +% % write_smapL4SMqa( fnames, tc_fname, tg_fname ); % % ##################### END SAMPLE DRIVER SCRIPT ##################################### @@ -106,9 +106,9 @@ % make sure that list of input file names is a cell array if ~iscell(gph_aup_lmc_fnames) - + error('write_smapL4SMqa.m: input list of file names must be a cell array') - + end % ---------------------------------------------- @@ -130,33 +130,33 @@ % process each file in list of input files for ii=1:length(gph_aup_lmc_fnames) - + this_fname = gph_aup_lmc_fnames{ii}; - + disp(['processing: ', this_fname]) - + % parse input string name to decide whether a "gph" or "aup" granule is to be converted - - if any( findstr( this_fname , 'ldas_tile_xhourly_out' )) + + if any( findstr( this_fname , 'ldas_tile_xhourly_out' )) get_gph_qa( this_fname, tile_coord ); - + elseif any( findstr( this_fname , 'ldas_tile_inst_smapL4SMaup' )) - + get_aup_qa( this_fname, tile_coord ); - + elseif any( findstr( this_fname , 'ldas_smapL4SMlmc' )) - + get_lmc_qa( this_fname, tile_coord ); - + else - - error('write_smapL4SMqa.m: something wrong with input file name') - + + error('write_smapL4SMqa.m: something wrong with input file name') + end disp(['---------------------------------------------------------']) - + end @@ -184,10 +184,10 @@ % [QA] -- SMAP_L4_SM_PSD p.29: % % "... -% The QA file contains statistical information that will enable users -% to better assess the quality of the associated granule. +% The QA file contains statistical information that will enable users +% to better assess the quality of the associated granule. % QA products bear exactly the same name as the products [(.h5)] -% that they represent. The only difference in names is the extension. +% that they represent. The only difference in names is the extension. % The extension for all QA products is *.qa. % ..." % @@ -238,7 +238,7 @@ out_collection_ID = 6; -%N_out_fields = 40; % for raw LDASsa output (EXCL. sm in pctl units) +%N_out_fields = 40; % for raw LDASsa output (EXCL. sm in pctl units) N_out_fields = 42; % for post-processed LDASsa output (INCL. sm in pctl units) %==================================================================== @@ -268,7 +268,7 @@ % assemble placeholder h5 file name %%ind = findstr(gph_fname,'/'); - + %%h5_fname = [gph_fname(ind(end)+1:end-4), '.h5']; h5_fname = ''; @@ -288,7 +288,7 @@ fprintf(ofp, ['%s%8d\n\n'],... ['Number of L4_SM EASEv2 9 km land grid cells = '], N_gridcells_M09); -% comma-delimited table: +% comma-delimited table: % - 4 header lines (observation space) % - X variable lines % - footnotes @@ -307,7 +307,7 @@ end fprintf(ofp, '\n'); -for f = 1:Nstat+2 +for f = 1:Nstat+2 if f==1 fprintf(ofp, ['%-',str_f,'s',delim,''], [tablefields{f},'' ]); end if f==2 fprintf(ofp, ['%-',unt_f,'s',delim,''], [tablefields{f},' (*1)']); end if f==3 || f==4 fprintf(ofp, ['%', num_f,'s',delim,''], [tablefields{f},' (*2)']); end @@ -329,7 +329,7 @@ fprintf(ofp, tableformat_sc, ... fn{f}, units{f}, ... stats_array(tile_data(f,:)',weights, Nstat)); - + else fprintf(ofp, tableformat, ... @@ -344,17 +344,17 @@ for f = 1:str_l+1+unt_l+Nstat+(Nstat-1)*num_l+num_s_l fprintf(ofp, '%s','-' ); -end +end fprintf(ofp, '\n%s\n\n', ... 'See SMAP L4_SM Data Products Specification Document for additional information.'); fprintf(ofp, '%s\n', ... '(*1) Units are valid for all statistics except N [dimensionless].'); - + fprintf(ofp, '%s\n',... '(*2) Mean and std-dev statistics are weighted by the land fraction of each grid cell.'); - + fprintf(ofp, '%s\n', ... '(*3) N is the number of 9 km EASEv2 grid cells that contribute to the statistics.'); @@ -379,7 +379,7 @@ % - text edits, formatting % 4feb14: Gabrielle De Lannoy - new aup structure % 7feb14: Gabrielle De Lannoy - edits -% +% % - currently operates on binary LDASsa aup files % - TBD: file name change from "bin" to official "h5" granule name % @@ -388,10 +388,10 @@ % [QA] -- SMAP_L4_SM_PSD p.29: % % "... -% The QA file contains statistical information that will enable users -% to better assess the quality of the associated granule. +% The QA file contains statistical information that will enable users +% to better assess the quality of the associated granule. % QA products bear exactly the same name as the products [(.h5)] -% that they represent. The only difference in names is the extension. +% that they represent. The only difference in names is the extension. % The extension for all QA products is *.qa. % ..." % @@ -420,7 +420,7 @@ 'Mean','Std-dev','Min','Max','N'}; Nstat = length(tablefields)-2; - + str_l = 51; unt_l = 16; num_l = 13; @@ -445,7 +445,7 @@ tableformat_sc = [tableformat_sc, delim,'%',num_s_f,'d\n']; end end - + AmF_threshold(17:19) = 1E-5; % soil moisture AmF_threshold(20:21) = 1E-3; % temperature @@ -490,7 +490,7 @@ % assemble placeholder h5 file name %%ind = findstr(aup_fname,'/'); - + %%h5_fname = [aup_fname(ind(end)+1:end-4), '.h5']; h5_fname = ''; @@ -511,7 +511,7 @@ ['Number of L4_SM EASEv2 9 km land grid cells = '], N_gridcells_M09,... ['Number of L4_SM EASEv2 36 km land grid cells = '], N_gridcells_M36); -% comma-delimited table: +% comma-delimited table: % - 4 header lines (observation space) % - X variable lines % - footnotes @@ -533,7 +533,7 @@ end fprintf(ofp, '\n'); -for f = 1:Nstat+2 +for f = 1:Nstat+2 if f==1 fprintf(ofp, ['%-',str_f,'s',delim,''], [tablefields{f},' (*1)']); end if f==2 fprintf(ofp, ['%-',unt_f,'s',delim,''], [tablefields{f},' (*2)']); end if f==3 || f==4 fprintf(ofp, ['%', num_f,'s',delim,''], [tablefields{f},' (*3)']); end @@ -549,23 +549,23 @@ %-----Raw aup-fields---------------------------------------------- for f = 7:16 - + var = getfield(aup, fn{f}); var(abs(var-nodata_val) AmF_threshold(f); - + if f==17 subset_exclzero = tmp_subset; else - subset_exclzero = (subset_exclzero | tmp_subset); + subset_exclzero = (subset_exclzero | tmp_subset); end - + end %-----Raw aup-fields---------------------------------------------- for f = 17:length(fn) - + var = getfield(aup, fn{f}); var(abs(var-nodata_val) 0 || return_mean) - if return_mean + if return_mean array_out = NaN*zeros(length(ia),1); end @@ -1214,7 +1214,7 @@ if (std(array( ... M36_row_col(:,1) == unique_rc(i,1) & ... M36_row_col(:,2) == unique_rc(i,2) ))... - > stdv_Tbobs_tol) + > stdv_Tbobs_tol) N_bad = N_bad+1; end end @@ -1247,9 +1247,9 @@ % ********************************************************************************************* -function [ stats_out ] = stats_array( array_in, weights, Nstat ) +function [ stats_out ] = stats_array( array_in, weights, Nstat ) -% calculate elementary summary statistics for array_in +% calculate elementary summary statistics for array_in % % input: array_in = numerical array (1-dimensional) % weights = weight for each element in array_in (1-dimensional) @@ -1259,9 +1259,9 @@ % GDL, 16 Jan 2014 % GDL, 30 Jan 2014: remove NaN prior to the calculation of stats % GDL, 1 Feb 2014: - weighted statistics for mean and stdv -% - add 6th statistic (frac): +% - add 6th statistic (frac): % the actual used fraction of N_data (based on weights) -% GDL, 7 Feb 2014: added Nstat as input, to limit the returned output. +% GDL, 7 Feb 2014: added Nstat as input, to limit the returned output. % should be revised in the future to select specific output, % rather than to limit the output fields % --------------------------------------------------------------------- diff --git a/src/Applications/LDAS_App/util/shared/matlab/EASEv2_ind2latlon.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_ind2latlon.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/EASEv2_ind2latlon.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_ind2latlon.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/EASEv2_latlon2ind.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/EASEv2_latlon2ind.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/J2000_to_DateTime.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/J2000_to_DateTime.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/augment_date_time.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/augment_date_time.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/days_in_month.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/days_in_month.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/get_dofyr_pentad.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/get_dofyr_pentad.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/is_leap_year.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/is_leap_year.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/pentad_of_year.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/pentad_of_year.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_ObsFcstAna.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_ObsFcstAna.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_catparam.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_catparam.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_obslog.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_obslog.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_obsparam.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_obsparam.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_smapL4SMaup.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_smapL4SMaup.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_smapL4SMlmc.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_smapL4SMlmc.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_tilecoord.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_tilecoord.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/read_tilegrids.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/read_tilegrids.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m diff --git a/src/Applications/LDAS_App/util/shared/matlab/tile2grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m similarity index 100% rename from src/Applications/LDAS_App/util/shared/matlab/tile2grid.m rename to src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m From 843f23e394ed1d29c808bcec33ba51c53f8b459b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 25 Mar 2024 16:22:23 -0400 Subject: [PATCH 04/10] Extract GEOSldas_GridComp into new repo This is a work-in-progress PR for extracting out the `GEOSldas_GridComp` into its own components (for work with @saraqzhang and @rtodling in integrating LDAS into the ADAS). Using RepoExtractor, the repo was extracted with: ``` ./extract_repo.bash -r "GEOSldas" -d "GEOSldas_GridComp" --newrepo "GEOSldas_GridComp" --develop --create-repo --push ``` After that these branches were also pushed to the new repo: * `release/MAPL-v3` * `BRIDGE` * `feature/wjiang/add_landice` * `feature/stefanocasirati/irrigation` --- components.yaml | 8 +++++++- src/Components/.gitignore | 3 +++ src/Components/CMakeLists.txt | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 src/Components/.gitignore diff --git a/components.yaml b/components.yaml index 36d4d1e6..35f02de8 100644 --- a/components.yaml +++ b/components.yaml @@ -46,8 +46,14 @@ MAPL: tag: v2.44.1 develop: develop +GEOSldas_GridComp: + local: ./src/Components/@GEOSldas_GridComp + remote: ../GEOSldas_GridComp.git + branch: develop + develop: develop + GEOSgcm_GridComp: - local: ./src/Components/GEOSldas_GridComp/@GEOSgcm_GridComp + local: ./src/Components/@GEOSldas_GridComp/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git branch: develop sparse: ./config/GEOSgcm_GridComp_ldas.sparse diff --git a/src/Components/.gitignore b/src/Components/.gitignore new file mode 100644 index 00000000..afe16bcd --- /dev/null +++ b/src/Components/.gitignore @@ -0,0 +1,3 @@ +/@GEOSldas_GridComp +/GEOSldas_GridComp +/GEOSldas_GridComp@ diff --git a/src/Components/CMakeLists.txt b/src/Components/CMakeLists.txt index f3130832..4ad9bf41 100644 --- a/src/Components/CMakeLists.txt +++ b/src/Components/CMakeLists.txt @@ -1 +1 @@ -add_subdirectory (GEOSldas_GridComp) +esma_add_subdirectory (GEOSldas_GridComp) From 8c0f53764ebaa2531f372a40007be4cca1a4613c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 25 Mar 2024 16:23:45 -0400 Subject: [PATCH 05/10] Remove GEOSldas_GridComp --- src/Components/GEOSldas_GridComp/.gitignore | 3 - .../GEOSldas_GridComp/CMakeLists.txt | 19 - .../GEOSldas_GridComp/GEOS_LdasGridComp.F90 | 1053 -- .../GEOSens_GridComp/CMakeLists.txt | 6 - .../GEOSens_GridComp/GEOS_EnsGridComp.F90 | 4074 ------ .../GEOSlandassim_GridComp/CMakeLists.txt | 22 - .../GEOS_LandAssimGridComp.F90 | 2979 ----- .../CMakeLists.txt | 12 - .../GEOS_ExportCatchIncrGridComp.F90 | 391 - .../GEOSlandassim_GridComp/adapt_types.F90 | 51 - .../catch_bias_types.F90 | 107 - .../clsm_adapt_routines.F90 | 1054 -- .../clsm_bias_routines.F90 | 1713 --- .../clsm_ensdrv_drv_routines.F90 | 398 - .../clsm_ensdrv_out_routines.F90 | 293 - .../clsm_ensupd_enkf_update.F90 | 2883 ----- .../clsm_ensupd_glob_param.F90 | 176 - .../clsm_ensupd_read_obs.F90 | 10448 ---------------- .../clsm_ensupd_upd_routines.F90 | 5690 --------- .../GEOSlandassim_GridComp/enkf_general.F90 | 487 - .../GEOSlandassim_GridComp/io_hdf5.F90 | 463 - .../GEOSlandassim_GridComp/mwRTM_routines.F90 | 1067 -- .../GEOSlandassim_GridComp/mwRTM_types.F90 | 471 - .../GEOSlandpert_GridComp/CMakeLists.txt | 16 - .../GEOS_LandPertGridComp.F90 | 2933 ----- .../LDAS_PertRoutines.F90 | 2239 ---- .../force_and_cat_progn_pert_types.F90 | 644 - .../GEOSlandpert_GridComp/land_pert.F90 | 1663 --- .../GEOSlandpert_GridComp/nr_fft.F90 | 106 - .../GEOSlandpert_GridComp/nr_jacobi.F90 | 243 - .../GEOSlandpert_GridComp/nr_ran2_gasdev.F90 | 298 - .../GEOSlandpert_GridComp/random_fields.F90 | 782 -- .../GEOSldas_App/CMakeLists.txt | 49 - .../GEOSldas_App/GEOSldas.F90 | 34 - .../GEOSldas_App/GEOSldas_CAP.rc | 34 - .../GEOSldas_App/GEOSldas_ExtData.rc | 0 .../GEOSldas_App/GEOSldas_HIST.rc | 480 - .../GEOSldas_App/GEOSldas_LDAS.rc | 259 - .../LDASsa_DEFAULT_inputs_adapt.nml | 122 - .../LDASsa_DEFAULT_inputs_catbias.nml | 166 - .../LDASsa_DEFAULT_inputs_ensprop.nml | 511 - .../LDASsa_DEFAULT_inputs_ensupd.nml | 2361 ---- .../GEOSldas_App/README_LDAS_App | 36 - .../ens_forcing/average_ensemble_forcing.py | 71 - .../GEOSldas_App/ens_forcing/enpert_forc.csh | 55 - .../GEOSldas_App/ens_forcing/ensemble_forc.py | 192 - .../GEOSldas_App/ens_forcing/regrid_forc.csh | 63 - .../ens_forcing/test_enpert_forc.j | 40 - .../GEOSldas_GridComp/GEOSldas_App/ldas_setup | 1763 --- .../GEOSldas_App/lenkf.j.template | 849 -- .../GEOSldas_App/preprocess_ldas.F90 | 142 - .../GEOSldas_App/preprocess_ldas_routines.F90 | 3370 ----- .../GEOSldas_App/process_hist.csh | 78 - .../GEOSldas_App/remap_config_ldas.py | 103 - .../LADAS/HISTORY.rc.atmens | 1083 -- .../LADAS/HISTORY.rc.central | 98 - .../LADAS/exeinp.txt.Hy4dEnVar.atmens | 37 - .../LADAS/exeinp.txt.Hy4dEnVar.central | 39 - .../GEOSldas_App/tile_bin2nc4.F90 | 454 - .../config/Create_ccorr_cat_progn_default.m | 57 - .../util/config/generate_catchincr_hist.py | 121 - .../util/config/rewind_GEOSldas.csh | 117 - .../util/inputs/ASCAT_sm_mask/CMakeLists.txt | 4 - .../inputs/ASCAT_sm_mask/ascat_mask_maker.F90 | 242 - .../mwRTM_params/Create_mwRTM_param_file.m | 240 - .../Create_vegopacity_8day_clim.m | 341 - ...reprocess_L2DCA_mwRTM_params_to_dailymat.m | 241 - .../mwRTM_params/fill_gaps_in_tiledata.m | 94 - .../get_L2_RTM_constants_tile_data.m | 218 - .../inputs/mwRTM_params/get_mwRTM_lookup.m | 167 - .../mwRTM_params/get_mwRTM_vegcls_based.m | 129 - .../inputs/mwRTM_params/mwrtm_bin2nc4.F90 | 241 - .../Run_get_L4_Tb_scale_SMAP.m | 178 - ...get_model_and_obs_clim_stats_latlon_grid.m | 115 - .../inputs/obs_scaling_params/dist_km2deg.m | 26 - .../get_ij_ind_from_latlon.m | 24 - .../get_model_and_obs_clim_stats.m | 729 -- ...get_model_and_obs_clim_stats_latlon_grid.m | 352 - .../obs_scaling_params/get_tile_num_for_obs.m | 125 - .../get_tile_num_in_cell_ij.m | 42 - .../write_netcdf_latlon_grid.m | 232 - .../obs_scaling_params/write_seqbin_file.m | 305 - .../util/postproc/climatology/README | 24 - .../climatology/Run_L4_sm_clim_stats.m | 82 - .../Write_L4_sm_clim_stat_bin2nc4.m | 208 - .../climatology/get_model_clim_stats.m | 433 - .../climatology/read_seqbin_clim_pctl_file.m | 129 - .../climatology/write_seqbin_clim_pctl_file.m | 255 - .../util/postproc/compress_bit-shaved_nc4.sh | 36 - .../util/postproc/write_smapL4SMqa.m | 1315 -- .../util/shared/matlab/EASEv2_ind2latlon.m | 202 - .../util/shared/matlab/EASEv2_latlon2ind.m | 218 - .../util/shared/matlab/J2000_to_DateTime.m | 111 - .../shared/matlab/MAPL_ReadForcing_fullfile.m | 80 - .../util/shared/matlab/augment_date_time.m | 149 - .../util/shared/matlab/days_in_month.m | 16 - .../util/shared/matlab/get_dofyr_pentad.m | 19 - .../util/shared/matlab/is_leap_year.m | 30 - .../util/shared/matlab/pentad_of_year.m | 14 - .../util/shared/matlab/read_ObsFcstAna.m | 192 - .../util/shared/matlab/read_catparam.m | 298 - .../util/shared/matlab/read_obslog.m | 51 - .../util/shared/matlab/read_obsparam.m | 80 - .../util/shared/matlab/read_smapL4SMaup.m | 152 - .../util/shared/matlab/read_smapL4SMlmc.m | 139 - .../util/shared/matlab/read_tilecoord.m | 240 - .../util/shared/matlab/read_tilegrids.m | 136 - .../util/shared/matlab/tile2grid.m | 87 - .../GEOSmetforce_GridComp/CMakeLists.txt | 10 - .../GEOS_MetforceGridComp.F90 | 1306 -- .../GEOSmetforce_GridComp/LDAS_Forcing.F90 | 6427 ---------- .../GEOSmetforce_GridComp/LDAS_HashTable.F90 | 181 - .../GEOSmetforce_GridComp/LDAS_Interp.F90 | 283 - .../LDAS_Shared/CMakeLists.txt | 19 - .../LDAS_Shared/LDAS_Convert.F90 | 49 - .../LDAS_Shared/LDAS_DriverTypes.F90 | 691 - .../LDAS_Shared/LDAS_Exceptions.F90 | 104 - .../LDAS_Shared/LDAS_PertTypes.F90 | 186 - .../LDAS_Shared/LDAS_RepairForcing.F90 | 563 - .../LDAS_Shared/LDAS_TileCoordRoutines.F90 | 1532 --- .../LDAS_Shared/LDAS_TileCoordType.F90 | 488 - .../LDAS_Shared/LDAS_ensdrv_Globals.F90 | 176 - .../LDAS_Shared/LDAS_ensdrv_functions.F90 | 384 - .../LDAS_Shared/LDAS_ensdrv_mpi.F90 | 954 -- .../LDAS_Shared/catch_types.F90 | 1435 --- .../LDAS_Shared/enkf_types.F90 | 228 - .../LDAS_Shared/my_lu_decomp.f | 140 - .../LDAS_Shared/my_matrix_functions.F90 | 1269 -- .../GEOSldas_GridComp/LDAS_Shared/nr_indexx.f | 87 - 129 files changed, 80821 deletions(-) delete mode 100644 src/Components/GEOSldas_GridComp/.gitignore delete mode 100644 src/Components/GEOSldas_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOS_LdasGridComp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSens_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSens_GridComp/GEOS_EnsGridComp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOS_LandAssimGridComp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/GEOS_ExportCatchIncrGridComp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/adapt_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/catch_bias_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_adapt_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_bias_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_drv_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_out_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_enkf_update.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_glob_param.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_read_obs.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_upd_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/enkf_general.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/io_hdf5.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/GEOS_LandPertGridComp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/LDAS_PertRoutines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/force_and_cat_progn_pert_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/land_pert.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_fft.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_jacobi.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_ran2_gasdev.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/random_fields.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_ExtData.rc delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/remap_config_ldas.py delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.atmens delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/HISTORY.rc.central delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.atmens delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py delete mode 100755 src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/read_seqbin_clim_pctl_file.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_ind2latlon.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m delete mode 100644 src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/GEOS_MetforceGridComp.F90 delete mode 100755 src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Forcing.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_HashTable.F90 delete mode 100644 src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Interp.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/CMakeLists.txt delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Convert.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_DriverTypes.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Exceptions.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_PertTypes.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_RepairForcing.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordRoutines.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordType.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_Globals.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_functions.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_mpi.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/catch_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/enkf_types.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/my_lu_decomp.f delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/my_matrix_functions.F90 delete mode 100644 src/Components/GEOSldas_GridComp/LDAS_Shared/nr_indexx.f diff --git a/src/Components/GEOSldas_GridComp/.gitignore b/src/Components/GEOSldas_GridComp/.gitignore deleted file mode 100644 index 9ca58726..00000000 --- a/src/Components/GEOSldas_GridComp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -/@GEOSgcm_GridComp -/GEOSgcm_GridComp -/GEOSgcm_GridComp@ diff --git a/src/Components/GEOSldas_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/CMakeLists.txt deleted file mode 100644 index b4c0974e..00000000 --- a/src/Components/GEOSldas_GridComp/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -esma_set_this () - -esma_add_subdirectory(GEOSgcm_GridComp) - -set (alldirs - GEOSmetforce_GridComp - GEOSlandpert_GridComp - GEOSens_GridComp - GEOSlandassim_GridComp - ) - -esma_add_library(${this} - SRCS GEOS_LdasGridComp.F90 - SUBCOMPONENTS ${alldirs} - SUBDIRS LDAS_Shared - DEPENDENCIES GEOSland_GridComp makebcs MAPL - INCLUDES ${INC_ESMF}) - -esma_add_subdirectory(GEOSldas_App) diff --git a/src/Components/GEOSldas_GridComp/GEOS_LdasGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOS_LdasGridComp.F90 deleted file mode 100644 index 4c1b13ed..00000000 --- a/src/Components/GEOSldas_GridComp/GEOS_LdasGridComp.F90 +++ /dev/null @@ -1,1053 +0,0 @@ -#include "MAPL_Generic.h" - -!BOP -! !MODULE: GEOS_LdasGridCompMod - Module to combine children GridComps -module GEOS_LdasGridCompMod - - ! !USES - - use ESMF - use MAPL_Mod - - use GEOS_MetforceGridCompMod, only: MetforceSetServices => SetServices - use GEOS_LandGridCompMod, only: LandSetServices => SetServices - use GEOS_LandPertGridCompMod, only: LandPertSetServices => SetServices - use GEOS_EnsGridCompMod, only: EnsSetServices => SetServices - use GEOS_LandAssimGridCompMod, only: LandAssimSetServices => SetServices - - use EASE_conv, only: ease_inverse - use LDAS_TileCoordType, only: tile_coord_type , T_TILECOORD_STATE, TILECOORD_WRAP - use LDAS_TileCoordType, only: grid_def_type, io_grid_def_type, operator (==) - use LDAS_TileCoordRoutines, only: get_minExtent_grid, get_ij_ind_from_latlon, io_domain_files - use LDAS_ConvertMod, only: esmf2ldas - use LDAS_PertRoutinesMod, only: get_pert_grid - use LDAS_ensdrv_functions,ONLY: get_io_filename - use LDAS_DateTimeMod,ONLY: date_time_type - use LDAS_ensdrv_mpi, only: MPI_tile_coord_type, MPI_grid_def_type - use LDAS_ensdrv_mpi, only: init_MPI_types,mpicomm,numprocs,myid - use LDAS_ensdrv_mpi, only: root_proc - use LDAS_ensdrv_Globals, only: logunit,logit,root_logit,echo_clsm_ensdrv_glob_param, get_ensid_string - use catch_constants, only: echo_catch_constants - use StieglitzSnow, only: StieglitzSnow_echo_constants - use SurfParams, only: SurfParams_init - - implicit none - - private - - ! !PUBLIC MEMBER FUNCTIONS: - - public SetServices - - ! !DESCRIPTION: This gridded component (GC) combines the GridComps: - ! METFORCE, LAND, LANDPERT, ENSAVG, and LANDASSIM - ! into a new composite LDAS GricComp. - ! Include later: LAKE, LANDICE(?), SALTWATER(?) - - !EOP - - include 'mpif.h' - - ! All children - integer,allocatable :: LAND(:) - integer,allocatable :: LANDPERT(:) - integer,allocatable :: METFORCE(:) - integer :: ENSAVG, LANDASSIM - - ! other global variables - integer :: NUM_ENSEMBLE ! number of land ensemble members - logical :: land_assim - logical :: mwRTM - logical :: ensemble_forcing ! switch between deterministic and ensemble forcing - -contains - - !BOP - - ! !IROTUINE: SetServices -- Set ESMF services for this component - - ! !INTERFACE: - - subroutine SetServices(gc, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, optional :: rc ! return code - - ! ensemble set up: - - integer :: i, k - integer :: ens_id - type(MAPL_MetaComp), pointer :: MAPL=>null() - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: ensid_string,childname - character(len=ESMF_MAXSTR) :: LAND_ASSIM_STR, mwRTM_file, ENS_FORCING_STR - integer :: ens_id_width - ! Local variables - type(T_TILECOORD_STATE), pointer :: tcinternal - type(TILECOORD_WRAP) :: tcwrap - - type(ESMF_Config) :: CF - integer :: LSM_CHOICE - integer :: FIRST_ENS_ID - - ! Begin... - - ! Get my name and setup traceback handle - Iam = 'SetServices' - call ESMF_GridCompGet(gc, name=comp_name,CONFIG=CF, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::" // Iam - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - VERIFY_(status) - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Run, & - rc=status & - ) - VERIFY_(status) - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - VERIFY_(status) - - - ! Save the tile_coord variable as an internal state of the GridComp - ! memory for tcwrap%tile_coord is allocated in Initialize() - allocate(tcinternal, stat=status) - VERIFY_(status) - tcwrap%ptr => tcinternal - call ESMF_UserCompSetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - - !create ensemble children - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, ens_id_width, Label="ENS_ID_WIDTH:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, FIRST_ENS_ID, Label="FIRST_ENS_ID:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, ENS_FORCING_STR, Label="ENSEMBLE_FORCING:", DEFAULT="NO", RC=STATUS) - VERIFY_(STATUS) - ENS_FORCING_STR = ESMF_UtilStringUpperCase(ENS_FORCING_STR, rc=STATUS) - VERIFY_(STATUS) - ensemble_forcing = (trim(ENS_FORCING_STR) == 'YES') - - call MAPL_GetResource ( MAPL, LAND_ASSIM_STR, Label="LAND_ASSIM:", DEFAULT="NO", RC=STATUS) - VERIFY_(STATUS) - LAND_ASSIM_STR = ESMF_UtilStringUpperCase(LAND_ASSIM_STR, rc=STATUS) - VERIFY_(STATUS) - land_assim = (trim(LAND_ASSIM_STR) /= 'NO') - - call MAPL_GetResource ( MAPL, mwRTM_file, Label="LANDASSIM_INTERNAL_RESTART_FILE:", DEFAULT='', RC=STATUS) - VERIFY_(STATUS) - mwRTM = ( len_trim(mwRTM_file) /= 0 ) - - call MAPL_GetResource ( MAPL, LSM_CHOICE, Label="LSM_CHOICE:", DEFAULT=1, RC=STATUS) - if (LSM_CHOICE /=1 ) then - _ASSERT( .not. (mwRTM .or. land_assim), "CatchCN is Not Ready for assimilation or mwRTM") - endif - - if (ensemble_forcing) then - allocate(METFORCE(NUM_ENSEMBLE)) - else - allocate(METFORCE(1)) - endif - - allocate(LAND(NUM_ENSEMBLE),LANDPERT(NUM_ENSEMBLE)) - - ! ens_id_with = 2 + number of digits = total number of chars in ensid_string ("_eXXXX") - ! - ! Assert ens_id_width<=2+9 so number of digits remains single-digit and "I1" can be - ! hardwired when assembling a format string. - ! Assert ens_id_width>=2+3 to avoid user configuration errors when LDAS is coupled into ADAS. - ! (Met forcing from the atm ensemble uses hardwired, 3-character ensemble IDs.) - - if (NUM_ENSEMBLE > 1) then - _ASSERT( ens_id_width < 12, "Must use ens_id_width <= 11 (2 for '_e' + 9 digits max)") - _ASSERT( ens_id_width >= 5, "Must use ens_id_width >= 5 (2 for '_e' + 3 digits min)") - endif - - do i=1,NUM_ENSEMBLE - ens_id = i-1 + FIRST_ENS_ID ! id start form FIRST_ENS_ID - - call get_ensid_string(ensid_string, ens_id, ens_id_width, NUM_ENSEMBLE) ! "_eXXXX" - - ! allow for Catchment ensemble simulation to be forced with single-member met inputs - if (.not. ensemble_forcing ) ensid_string = '' - - childname='METFORCE'//trim(ensid_string) - METFORCE(i) = MAPL_AddChild(gc, name=trim(childname), ss=MetforceSetServices, rc=status) - VERIFY_(status) - ! exit after i=1 if using deterministic forcing - if (.not. ensemble_forcing ) exit - enddo - - do i=1,NUM_ENSEMBLE - ens_id = i-1 + FIRST_ENS_ID ! id start form FIRST_ENS_ID - - call get_ensid_string(ensid_string, ens_id, ens_id_width, NUM_ENSEMBLE) - - childname='LANDPERT'//trim(ensid_string) - LANDPERT(i) = MAPL_AddChild(gc, name=childname, ss=LandPertSetServices, rc=status) - VERIFY_(status) - - childname='LAND'//trim(ensid_string) - LAND(i) = MAPL_AddChild(gc, name=childname, ss=LandSetServices, rc=status) - VERIFY_(status) - enddo - - ENSAVG = MAPL_AddChild(gc, name='ENSAVG', ss=EnsSetServices, rc=status) - VERIFY_(status) - - if(land_assim .or. mwRTM ) then - LANDASSIM = MAPL_AddChild(gc, name='LANDASSIM', ss=LandAssimSetServices, rc=status) - VERIFY_(status) - endif - - ! Connections - do i=1,NUM_ENSEMBLE - ! -METFORCE-feeds-LANDPERT's-imports- - k = 1 - if ( ensemble_forcing ) k = i - call MAPL_AddConnectivity( & - gc, & - SHORT_NAME = ['Tair ', 'Qair ', 'Psurf ', 'Rainf_C', 'Rainf ', & - 'Snowf ', 'LWdown ', 'SWdown ', 'PARdrct', 'PARdffs', & - 'Wind ', 'RefH '], & - SRC_ID = METFORCE(k), & - DST_ID = LANDPERT(i), & - rc = status & - ) - VERIFY_(status) - ! -LANDPERT-feeds-LAND's-imports- - call MAPL_AddConnectivity( & - gc, & - SRC_NAME = ['TApert ', 'QApert ', 'UUpert ', & - 'UWINDLMTILEpert', 'VWINDLMTILEpert', 'PCUpert ', & - 'PLSpert ', 'SNOpert ', 'DRPARpert ', & - 'DFPARpert ', 'DRNIRpert ', 'DFNIRpert ', & - 'DRUVRpert ', 'DFUVRpert ', 'LWDNSRFpert '], & - SRC_ID = LANDPERT(i), & - DST_NAME = ['TA ', 'QA ', 'UU ', 'UWINDLMTILE',& - 'VWINDLMTILE', 'PCU ', 'PLS ', 'SNO ',& - 'DRPAR ', 'DFPAR ', 'DRNIR ', 'DFNIR ',& - 'DRUVR ', 'DFUVR ', 'LWDNSRF '], & - DST_ID = LAND(i), & - rc = status & - ) - VERIFY_(status) - ! -METFORCE-feeds-LAND's-imports- - call MAPL_AddConnectivity( & - gc, & - SRC_NAME = ['Psurf', 'RefH ', & - 'DUDP ', 'DUSV ', 'DUWT ', 'DUSD ', 'BCDP ', 'BCSV ', & - 'BCWT ', 'BCSD ', 'OCDP ', 'OCSV ', 'OCWT ', 'OCSD ', & - 'SUDP ', 'SUSV ', 'SUWT ', 'SUSD ', 'SSDP ', 'SSSV ' ], & - SRC_ID = METFORCE(k), & - DST_NAME = ['PS ', 'DZ ', & - 'DUDP', 'DUSV', 'DUWT', 'DUSD', 'BCDP', 'BCSV', & - 'BCWT', 'BCSD', 'OCDP', 'OCSV', 'OCWT', 'OCSD', & - 'SUDP', 'SUSV', 'SUWT', 'SUSD', 'SSDP', 'SSSV' ], & - DST_ID = LAND(i), & - rc = status & - ) - VERIFY_(status) - ! -LAND-feeds-LANDPERT's-imports- - call MAPL_AddConnectivity( & - gc, & - SRC_NAME = ['TC ','CATDEF ','RZEXC ','SRFEXC ','WESNN1 ','WESNN2 ','WESNN3 ', & - 'GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4','GHTCNT5','GHTCNT6', & - 'HTSNNN1','HTSNNN2','HTSNNN3','SNDZN1 ','SNDZN2 ','SNDZN3 '], & - SRC_ID = LAND(i), & - DST_NAME = ['TCPert ','CATDEFPert ','RZEXCPert ','SRFEXCPert ','WESNN1Pert ', & - 'WESNN2Pert ','WESNN3Pert ','GHTCNT1Pert','GHTCNT2Pert', & - 'GHTCNT3Pert','GHTCNT4Pert','GHTCNT5Pert','GHTCNT6Pert', & - 'HTSNNN1Pert','HTSNNN2Pert','HTSNNN3Pert','SNDZN1Pert ', & - 'SNDZN2Pert ','SNDZN3Pert '], & - DST_ID = LANDPERT(i), & - rc = status & - ) - VERIFY_(status) - enddo - - if(land_assim .or. mwRTM) then - ! -LAND-feeds-LANDASSIM's-imports- - ! Catchment model parameters from first LAND ens member, assumes no parameter perturbations! - call MAPL_AddConnectivity( & - gc, & - SHORT_NAME = ['POROS ', 'COND ','PSIS ','BEE ','WPWET ','GNU ','VGWMAX', & - 'BF1 ', 'BF2 ','BF3 ','CDCR1 ','CDCR2 ','ARS1 ', & - 'ARS2 ', 'ARS3 ','ARA1 ','ARA2 ','ARA3 ','ARA4 ', & - 'ARW1 ', 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ','TSB1 ', & - 'TSB2 ', 'ATAU ','BTAU ','ITY ','Z2CH ' ], & - SRC_ID = LAND(1), & ! Note (1) ! - DST_ID = LANDASSIM, & - rc = status & - ) - VERIFY_(status) - endif - - call MAPL_TimerAdd(gc, name="Initialize", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="-LocStreamCreate", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name='Run', rc=status) - VERIFY_(status) - - ! Terminate all imports - call MAPL_TerminateImport(gc, ALL=.true., rc=status) - VERIFY_(status) - ! Call SetServices for children - call MAPL_GenericSetServices(gc, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - - !BOP - - ! !IROTUINE: Initialize -- initialize method for LDAS GC - - ! !INTERFACE: - - subroutine Initialize(gc, import, export, clock, rc) - !use MAPL_LatLonToCubeRegridderMod - !use MAPL_CubeToLatLonRegridderMod - !use MAPL_CubeToCubeRegridderMod - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! The Initialize routine creates the grid, locstream for all surface - ! (surf\_locstream). It then splits this 'Surface' locstream based on mask - ! (land, lake etc.) and attaches the sub-locstream to the corresponding - ! child's GridComp. - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: gridname - - ! ESMF variables - type(ESMF_Grid) :: agrid ! atospheric grid - type(ESMF_GridComp), pointer :: gcs(:)=>null() ! Children gridcomps - character(len=ESMF_MAXSTR), pointer :: gcnames(:)=>null() ! Children's names - type(ESMF_DELayout) :: layout - type(ESMF_DistGrid) :: distgrid - - ! MAPL variables - type(MAPL_LocStream) :: surf_locstream - type(MAPL_LocStream) :: land_locstream - type(MAPL_MetaComp), pointer :: MAPL=>null() ! GC's MAPL obj - type(MAPL_MetaComp), pointer :: CHILD_MAPL=>null() ! Child's MAPL obj - - ! LDAS' tile_coord variable - type(T_TILECOORD_STATE), pointer :: tcinternal - type(TILECOORD_WRAP) :: tcwrap - - ! Misc variables - character(len=ESMF_MAXSTR) :: tilingfile - character(len=300) :: out_path,decomf - character(len=ESMF_MAXSTR) :: exp_id - character(len=ESMF_MAXSTR) :: LDAS_logit - character(len=ESMF_MAXSTR) :: LAND_PARAMS - character(len=ESMF_MAXSTR) :: grid_type - - integer :: total_nt,land_nt_local,i,j - real, pointer :: LandTileLats(:) - real, pointer :: LandTileLons(:) - integer, pointer :: local_id(:) - real(ESMF_KIND_R8), pointer :: centerX(:,:) - real(ESMF_KIND_R8), pointer :: centerY(:,:) - - logical :: isEASEv1 - logical :: isEASEv2 - integer :: I1,IN,J1,JN - real :: lat,lon - type(ESMF_VM) :: vm - integer :: mpierr - logical :: IamRoot - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f => null() - - integer,dimension(:),pointer :: f2g - integer :: N_catf - integer :: LSM_CHOICE - - type(grid_def_type) :: tile_grid_g, pert_grid_g - type(grid_def_type) :: tile_grid_f, pert_grid_f - type(grid_def_type) :: pert_grid_l - - type(date_time_type):: start_time - type(ESMF_Time) :: CurrentTime - !type(CubedSphereGridFactory) :: cubed_sphere_factory - !type (CubeToLatLonRegridder) :: cube_to_latlon_prototype - !type (LatLonToCubeRegridder) :: latlon_to_cube_prototype - !type (CubeToCubeRegridder) :: cube_to_cube_prototype - real :: DT, DT_Solar - type(ESMF_Alarm) :: SolarAlarm - type(ESMF_TimeInterval) :: Solar_DT - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Initialize" - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - call ESMF_VmGet(vm, mpicommunicator=mpicomm, rc=status) - VERIFY_(status) - call MPI_COMM_RANK(mpicomm, myid,mpierr) - call MPI_COMM_SIZE(mpicomm, numprocs, mpierr ) - root_proc = IAmRoot - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Initialize") - - call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) - VERIFY_(status) - call esmf2ldas(CurrentTime, start_time, rc=status) - VERIFY_(status) - - call MAPL_GetResource(MAPL,LDAS_logit,'LDAS_logit:',default = "NO",rc = status) - VERIFY_(status) - - logit = (trim(LDAS_logit) /= 'NO') - root_logit = (IamRoot .and. logit) - - ! Init catchment constants, currently different in GCM and GEOSldas - call MAPL_GetResource(MAPL, LAND_PARAMS,Label="LAND_PARAMS:",DEFAULT="Icarus",RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, LSM_CHOICE, Label="LSM_CHOICE:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - - call SurfParams_init(LAND_PARAMS,LSM_CHOICE,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource(MAPL, grid_type,Label="GEOSldas.GRID_TYPE:",RC=STATUS) - VERIFY_(STATUS) - - ! if (trim(grid_type) == "Cubed-Sphere") then - ! call grid_manager%add_prototype("Cubed-Sphere", cubed_sphere_factory) - ! associate (method => REGRID_METHOD_BILINEAR, mgr => regridder_manager) - ! call mgr%add_prototype('Cubed-Sphere', 'LatLon', method, cube_to_latlon_prototype) - ! call mgr%add_prototype('LatLon', 'Cubed-Sphere', method, latlon_to_cube_prototype) - ! call mgr%add_prototype('Cubed-Sphere', 'Cubed-Sphere', method, cube_to_cube_prototype) - ! end associate - ! endif - - ! Create atmospheric (single level atm grid covers all of surface) grid - call MAPL_GridCreate(gc, rc=status) - VERIFY_(status) - - ! Get grid info from the gridcomp - call ESMF_GridCompGet(gc, grid=agrid, rc=status) - VERIFY_(status) - - ! Get distgrid info from grid - call ESMF_GridGet(agrid, distgrid=distgrid, rc=status) - VERIFY_(status) - - ! Get DElayout info from distgrid - call ESMF_DistGridGet(distgrid, delayout=layout, rc=status) - VERIFY_(status) - - ! get grid name - call ESMF_GridGet(agrid, name=gridname, rc=status) - VERIFY_(STATUS) - isEASEv1 =.false. - isEASEv2 =.false. - - if (index(gridname,'EASEv2') /=0) then - isEASEv2 = .true. - else if (index(gridname,'EASE') /=0) then - isEASEv1 = .true. - endif - if( isEASEv1) then - ! To be implemented - endif - if( isEASEv2) then -! Retrieve the coordinates so we can set them - call ESMF_GridGetCoord(agrid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerX, rc=status) - VERIFY_(STATUS) - - call ESMF_GridGetCoord(agrid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerY, rc=status) - VERIFY_(STATUS) - - call ESMF_GRID_INTERIOR(agrid,I1,IN,J1,JN) - - do I = 1,size(centerX,1) - call ease_inverse(gridname,1.0*(I+I1-2),0.0,lat,lon) - centerX(I,:) = lon * MAPL_DEGREES_TO_RADIANS - enddo - - do J = 1,size(centerY,2) - call ease_inverse(gridname,0.0,1.0*(J+J1-2),lat,lon) - centerY(:,J) = lat * MAPL_DEGREES_TO_RADIANS - enddo - - endif - - ! Get tile file location - call MAPL_GetResource( & - MAPL, & - tilingfile, & - 'TILING_FILE:', & - default = "tile.data", & - rc = status & - ) - VERIFY_(status) - - - !print*," Create LocStream for all surface (land, lake, landice, saltwater)" - call MAPL_TimerOn(MAPL, "-LocStreamCreate") - call MAPL_LocStreamCreate( & - surf_locstream, & - layout = layout, & - filename = tilingfile, & - name = "Surface", & - grid = agrid, & - rc = status & - ) - VERIFY_(status) - - call MAPL_TimerOff(MAPL, "-LocStreamCreate") - - ! Get children and their im/ex states from MAPL obj - call MAPL_Get(MAPL, GCS=gcs, GCNAMES=gcnames, rc=status) - VERIFY_(status) - - ! Create LAND's locstreams as subset of Surface locstream - ! and add it to the children's MAPL objects - - call MAPL_TimerOn(MAPL, "-LocStreamCreate") - call MAPL_LocStreamCreate( & - land_locstream, & - surf_locstream, & - name=gcnames(LAND(1)), & - mask=[MAPL_LAND], & - rc=status & - ) - VERIFY_(status) - call MAPL_TimerOff(MAPL, "-LocStreamCreate") - ! Convert LAND's LocStream to LDAS' tile_coord and save it in the GridComp - ! -get-tile-information-from-land's-locstream- - call MAPL_LocStreamGet( & - land_locstream, & - NT_LOCAL=land_nt_local, & - TILELATS=LandTileLats, & - TILELONS=LandTileLons, & - LOCAL_ID=local_id , & - rc=status & - ) - VERIFY_(status) - - ! -get-component's-internal-state- - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - ! -allocate-memory-for-tile-coord- - allocate(tcinternal%tile_coord(land_nt_local), stat=status) - VERIFY_(status) - allocate(tcinternal%l2f(land_nt_local)) - VERIFY_(status) - - - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="./", RC=STATUS) - - call init_MPI_types() - - call MPI_Reduce(land_nt_local,total_nt,1,MPI_INT,MPI_SUM,0,mpicomm,mpierr); - - decomf = get_io_filename(trim(out_path), trim(exp_id), 'ldas_domdecomp', date_time=start_time, & - dir_name='rc_out', file_ext='.txt') - - if (IamRoot) then - call io_domain_files('r',trim(out_path), trim(exp_id),N_catf,f2g,tile_coord_f,tile_grid_g,tile_grid_f,RC) - ! WY notes: f2g == tile_coord_f%tile_id - deallocate(f2g) - print*, "Number of tiles: ", N_catf - if(N_catf /= total_nt) then - print*, "total_nt = ", total_nt - stop "tiles number not equal" - endif - open(10,file= trim(decomf), action='write') - write(10,*) N_catf - close(10) - call io_grid_def_type('w', logunit, tile_grid_f, 'tile_grid_f') - - ! get a grid for perturbations and EnKF: - ! - ! tile grid ! pert grid - ! (defines tile space) ! (used for perturbations and as "hash" grid in EnKF analysis) - ! =========================================================================================================== - ! lat/lon ! same as tile_grid (i.e., lat/lon) - ! ----------------------------------------------------------------------------------------------------------- - ! EASEv[X] ! same as tile_grid (i.e., EASE) - ! ----------------------------------------------------------------------------------------------------------- - ! cube-sphere ! lat/lon grid of resolution similar to that of (cube-sphere) tile_grid - - pert_grid_g = get_pert_grid(tile_grid_g) - - if ( .not. (pert_grid_g==tile_grid_g) ) then - - ! arrive here when tile_grid_g is cube-sphere and pert_grid_g is lat/lon after call to get_pert_grid() above - - !1) get pert_i_indg, pert_j_indg for tiles in (full) domain relative to pert_grid_g - do i = 1, N_catf - call get_ij_ind_from_latlon(pert_grid_g,tile_coord_f(i)%com_lat,tile_coord_f(i)%com_lon, & - tile_coord_f(i)%pert_i_indg,tile_coord_f(i)%pert_j_indg) - enddo - !2) determine pert_grid_f - pert_grid_f = get_minExtent_grid(N_catf, tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, & - tile_coord_f%min_lon, tile_coord_f%min_lat, tile_coord_f%max_lon, tile_coord_f%max_lat, & - pert_grid_g) - - else - - pert_grid_f = tile_grid_f - - ! note that %pert_i_indg and %pert_j_indg were initialized to %i_indg and %j_indg - ! in io_tile_coord_type() when tile_coord was read via io_domain_files() - - endif - endif - - call MPI_BCAST(N_catf,1,MPI_INTEGER,0,mpicomm,mpierr) - if (.not. IamRoot) allocate(tile_coord_f(N_catf)) - - call MPI_BCAST(tile_coord_f,N_catf, MPI_tile_coord_type,0,mpicomm, mpierr) - call MPI_BCAST(pert_grid_g, 1, MPI_grid_def_type, 0,mpicomm, mpierr) - call MPI_BCAST(pert_grid_f, 1, MPI_grid_def_type, 0,mpicomm, mpierr) - call MPI_BCAST(tile_grid_g, 1, MPI_grid_def_type, 0,mpicomm, mpierr) - - block - integer, allocatable :: f2tile_id(:), tile_id2f(:) - integer :: max_id - allocate(f2tile_id(N_catf)) - f2tile_id = tile_coord_f%tile_id - - max_id = maxval(f2tile_id) - allocate(tile_id2f(max_id),source = 0) - do i = 1, N_catf - tile_id2f(f2tile_id(i)) = i - enddo - tcinternal%l2f = tile_id2f(local_id) - tcinternal%tile_coord = tile_coord_f(tcinternal%l2f) - deallocate(f2tile_id, tile_id2f) - end block - - do i = 0, numprocs-1 - if( i == myid) then - open(10,file= trim(decomf), action='write',position='append') - do j = 1, land_nt_local - write(10,*) local_id(j), myid - enddo - close(10) - endif - call MPI_Barrier(mpicomm,mpierr) - enddo - - allocate(tcinternal%tile_coord_f,source = tile_coord_f) - - pert_grid_l = get_minExtent_grid(land_nt_local, & - tcinternal%tile_coord%pert_i_indg, tcinternal%tile_coord%pert_j_indg, & - tcinternal%tile_coord%min_lon, tcinternal%tile_coord%min_lat, & - tcinternal%tile_coord%max_lon, tcinternal%tile_coord%max_lat, & - pert_grid_g) - - tcinternal%pgrid_g = pert_grid_g - tcinternal%pgrid_f = pert_grid_f - tcinternal%pgrid_l = pert_grid_l - tcinternal%tgrid_g = tile_grid_g - - do i = 1, NUM_ENSEMBLE - call MAPL_GetObjectFromGC(gcs(METFORCE(i)), CHILD_MAPL, rc=status) - VERIFY_(status) ! CHILD = METFORCE - call MAPL_Set(CHILD_MAPL, LocStream=land_locstream, rc=status) - VERIFY_(status) - call ESMF_UserCompSetInternalState(gcs(METFORCE(i)), 'TILE_COORD', tcwrap, status) - VERIFY_(status) - ! exit after i=1 if using deterministic forcing - if (.not. ensemble_forcing) exit - enddo - - call MAPL_GetObjectFromGC(gcs(ENSAVG), CHILD_MAPL, rc=status) - VERIFY_(status) ! CHILD = ens_avg - call MAPL_Set(CHILD_MAPL, LocStream=land_locstream, rc=status) - VERIFY_(status) - - do i = 1,NUM_ENSEMBLE - call MAPL_GetObjectFromGC(gcs(LAND(i)), CHILD_MAPL, rc=status) - VERIFY_(status) - call MAPL_Set(CHILD_MAPL, LocStream=land_locstream, rc=status) - VERIFY_(status) - call MAPL_GetObjectFromGC(gcs(LANDPERT(i)), CHILD_MAPL, rc=status) - VERIFY_(status) ! CHILD = LANDPERT - call MAPL_Set(CHILD_MAPL, LocStream=land_locstream, rc=status) - VERIFY_(status) - ! Add LAND's tile_coord to children's GridComps - call ESMF_UserCompSetInternalState(gcs(LAND(i)), 'TILE_COORD', tcwrap, status) - VERIFY_(status) - call ESMF_UserCompSetInternalState(gcs(LANDPERT(i)), 'TILE_COORD', tcwrap, status) - VERIFY_(status) - enddo - - if (land_assim .or. mwRTM) then - call MAPL_GetObjectFromGC(gcs(LANDASSIM), CHILD_MAPL, rc=status) - VERIFY_(status) - call MAPL_Set(CHILD_MAPL, LocStream=land_locstream, rc=status) - VERIFY_(status) - - call ESMF_UserCompSetInternalState(gcs(LANDASSIM), 'TILE_COORD', tcwrap, status) - VERIFY_(status) - endif - - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! solar alarm is created in solar gridcomp. Since GEOSldas doesnot have that gridcomp, it is created here - ! -create-nonsticky-alarm- - call MAPL_Get(MAPL, HEARTBEAT = DT, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, DT_Solar, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS) - VERIFY_(STATUS) - call ESMF_TimeIntervalSet(SOLAR_DT, s=NINT(DT_Solar), rc=status) - VERIFY_(status) - - SolarAlarm = ESMF_AlarmCreate( & - clock, & - name='SOLAR_Alarm', & - ringTime=CurrentTime, & - ringInterval=SOLAR_DT, & - sticky=.false., & - rc=status & - ) - VERIFY_(status) - - - if ( IamRoot) call echo_clsm_ensdrv_glob_param() - if ( IamRoot) call echo_catch_constants(logunit) - if ( IamRoot) call StieglitzSnow_echo_constants(logunit) - - - ! Turn timer off - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - RETURN_(ESMF_SUCCESS) - - end subroutine Initialize - - - !BOP - - ! !IROTUINE: Run -- Run method for the composite Ldas GridComp - - ! !INTERFACE: - - subroutine Run(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Calls children's Run methods. - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_GridComp), pointer :: gcs(:) - type(ESMF_State), pointer :: gim(:) - type(ESMF_State), pointer :: gex(:) - type(ESMF_State) :: member_export - - character(len=ESMF_MAXSTR), pointer :: gcnames(:) - type(ESMF_Time) :: ModelTimeCur - character(len=ESMF_MAXSTR) :: member_name - character(len=ESMF_MAXSTR) :: ensid_string - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL - - ! Misc variables - integer :: igc,i, ens_id, FIRST_ENS_ID, ens_id_width - logical :: IAmRoot - integer :: LSM_CHOICE - type (ESMF_Field) :: field - - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Run") - - ! Get information about children - call MAPL_Get(MAPL, GCS=gcs, GIM=gim, GEX=gex, GCNAMES=gcnames, rc=status) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, ens_id_width, Label="ENS_ID_WIDTH:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, FIRST_ENS_ID, Label="FIRST_ENS_ID:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - !call ESMF_VmGet(vm, mpicommunicator=mpicomm, rc=status) - !VERIFY_(status) - - call MAPL_GetResource ( MAPL, LSM_CHOICE, Label="LSM_CHOICE:", DEFAULT=1, RC=STATUS) - - ! Get current time - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - VERIFY_(status) - if (IAmRoot) then - call ESMF_TimePrint(ModelTimeCur, options='string', rc=status) - VERIFY_(status) - end if - - !phase2 initialization ( executed once) - !adjust mean of perturbed forcing or Progn - do i = 1,NUM_ENSEMBLE - igc = LANDPERT(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=1, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - enddo - - ! Run children GridComps (in order) - ! Generate raw perturbed force and progn - do i = 1,NUM_ENSEMBLE - igc = LANDPERT(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=2, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - enddo - - - do i = 1, NUM_ENSEMBLE - igc = METFORCE(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - ! exit after i=1 if using deterministic forcing - if (.not. ensemble_forcing) exit - enddo - - - do i = 1,NUM_ENSEMBLE - - !ApplyForcePert - igc = LANDPERT(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=3, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - - ! Use landpert's output as the input to calculate the ensemble average forcing - ! W.J note: So far it is only for the Catchment model. - ! To make CatchmentCN work with assim, the export from landgrid and catchmentCN grid need to be modified. - if ( LSM_CHOICE == 1 ) then - call ESMF_GridCompRun(gcs(ENSAVG), importState=gex(igc), exportState=gex(ENSAVG), clock=clock,phase=1, userRC=status) - VERIFY_(status) - endif - - ! Run the land model - igc = LAND(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=1, userRC=status) - VERIFY_(status) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=2, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - - ! ApplyPrognPert - moved: now before calculating ensemble average that is picked up by land analysis and HISTORY; reichle 28 May 2020 - igc = LANDPERT(i) - call MAPL_TimerOn(MAPL, gcnames(igc)) - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(igc), clock=clock, phase=4, userRC=status) - VERIFY_(status) - call MAPL_TimerOff(MAPL, gcnames(igc)) - - ! Use LAND's output as the input to calculate the ensemble average - igc = LAND(i) - if (LSM_CHOICE == 1) then - ! collect cat_param - ens_id = i-1 + FIRST_ENS_ID ! id start form FIRST_ENS_ID - call get_ensid_string(ensid_string, ens_id, ens_id_width, NUM_ENSEMBLE) - - member_name = 'CATCH'//trim(ensid_string)//"_Exports" - - call ESMF_StateGet(gex(igc), trim(member_name), member_export, _RC) - call ESMF_StateGet(gex(igc), "Z2CH", field, _RC) - call ESMF_StateAddReplace(member_export, [field],_RC) - call ESMF_StateGet(gex(igc), "LAI", field, _RC) - call ESMF_StateAddReplace(member_export, [field],_RC) - - call ESMF_GridCompRun(gcs(ENSAVG), importState=member_export, exportState=gex(ENSAVG), clock=clock,phase=3, userRC=status) - VERIFY_(status) - call ESMF_GridCompRun(gcs(ENSAVG), importState=member_export, exportState=gex(ENSAVG), clock=clock,phase=2, userRC=status) - VERIFY_(status) - - if( mwRTM ) then - ! Calculate ensemble-average L-band Tb using LAND's output (add up and normalize after last member has been added) - call ESMF_GridCompRun(gcs(LANDASSIM), importState=member_export, exportState=gex(LANDASSIM), clock=clock,phase=3, userRC=status) - VERIFY_(status) - endif - endif - - enddo - - if ( mwRTM .and. LSM_CHOICE == 1 ) then - ! output_smapl4smlmc - call ESMF_GridCompRun(gcs(LANDASSIM), importState=gim(LANDASSIM), exportState=gex(LANDASSIM), clock=clock,phase=4, userRC=status) - VERIFY_(status) - endif - - ! Run land analysis - if (land_assim) then - igc = LANDASSIM - call MAPL_TimerOn(MAPL, gcnames(igc)) - ! Get EnKF increments and apply to "cat_progn" (imported from ENSAVG via "use" statement!); otherwise import state is export from ENSAVG - call ESMF_GridCompRun(gcs(igc), importState=gex(ENSAVG), exportState=gex(igc), clock=clock, phase=1, userRC=status) - VERIFY_(status) - - do i = 1, NUM_ENSEMBLE - ! Extract updated exports from "cat_progn" - call ESMF_GridCompRun(gcs(igc), importState=gim(igc), exportState=gex(LAND(i)), clock=clock, phase=2, userRC=status) - VERIFY_(status) - - enddo - call MAPL_TimerOff(MAPL, gcnames(igc)) - endif - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Run") - call MAPL_TimerOff(MAPL, "TOTAL") - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Run - - - !BOP - - ! !IROTUINE: Finalize -- finalize method for LDAS GC - - ! !INTERFACE: - - subroutine Finalize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Clean-up. - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! Internal state variables - type(T_TILECOORD_STATE), pointer :: tcinternal - type(TILECOORD_WRAP) :: tcwrap - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Finalize" - - ! Get component's internal state - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - - ! ! Clean up internal state's tile_coord variable - ! if (associated(tcinternal%tile_coord)) deallocate(tcinternal%tile_coord) - - ! Call Finalize for every child - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - -end module GEOS_LdasGridCompMod diff --git a/src/Components/GEOSldas_GridComp/GEOSens_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSens_GridComp/CMakeLists.txt deleted file mode 100644 index 220d5ee9..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSens_GridComp/CMakeLists.txt +++ /dev/null @@ -1,6 +0,0 @@ -esma_set_this () - -esma_add_library(${this} - SRCS GEOS_EnsGridComp.F90 - DEPENDENCIES GEOSland_GridComp GEOS_LdasShared MAPL - INCLUDES ${INC_ESMF}) diff --git a/src/Components/GEOSldas_GridComp/GEOSens_GridComp/GEOS_EnsGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOSens_GridComp/GEOS_EnsGridComp.F90 deleted file mode 100644 index 40f8170d..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSens_GridComp/GEOS_EnsGridComp.F90 +++ /dev/null @@ -1,4074 +0,0 @@ -#include "MAPL_Generic.h" - -!BOP -module GEOS_EnsGridCompMod - - ! !USES - !! This grid comp behaves like a coupler. The set service, initialization are compliant with MAPL grid comp concept. - use ESMF - use MAPL_Mod - use catch_constants, only: DZGT => CATCH_DZGT - use catch_types, only: cat_progn_type - use catch_types, only: cat_param_type - - use, intrinsic :: ieee_arithmetic - - implicit none - - private - - public :: SetServices - public :: catch_progn - public :: catch_param - - ! !DESCRIPTION: This GridComp collects ensemble members and then averages the variables from Catchment. - ! For select variables, the ensemble standard deviation is also computed. - - !EOP - integer :: NUM_ENSEMBLE - integer :: collect_land_counter - integer :: collect_force_counter - integer, parameter :: NUM_SUBTILES=4 - real :: enavg_nodata_threshold - - type(cat_progn_type),dimension(:,:), allocatable :: catch_progn - type(cat_param_type),dimension(: ), allocatable :: catch_param - - -contains - - !BOP - - ! !IROTUINE: SetServices -- Set ESMF services for this component - - ! !INTERFACE: - - subroutine SetServices(gc, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, optional :: rc ! return code - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - - ! Get my name and setup traceback handle - Iam = 'SetServices' - call ESMF_GridCompGet(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::" // Iam - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - VERIFY_(status) - - ! phase one: collect forcing ensemble - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Collect_force_ens, & - rc=status & - ) - VERIFY_(status) - - ! phase two : collect ensemble out from land - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Collect_land_ens, & - rc=status & - ) - VERIFY_(status) - - !phase 3 : get cat_param - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - GET_CATCH_PARAM , & - rc=status & - ) - VERIFY_(status) - - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - VERIFY_(status) - - ! Set the state variable specs - !BOS - - ! !IMPORT STATE: - - ! this grid comp will take the other's export as import - - ! !EXPORT STATE: - ! relay LAI to landassim - call MAPL_AddExportSpec(GC ,& - SHORT_NAME = 'LAI' ,& - LONG_NAME = 'leaf_area_index' ,& - UNITS = '1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - VERIFY_(STATUS) - -!! exports for ens average (and, for a few variables, the ens std) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'canopy_temperature' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TC' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileTile ,& - NUM_SUBTILES = NUM_SUBTILES ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'canopy_specific_humidity' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QC' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileTile ,& - NUM_SUBTILES = NUM_SUBTILES ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'interception_reservoir_capac',& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CAPAC' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'catchment_deficit' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CATDEF' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'root_zone_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'RZEXC' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'surface_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'SRFEXC' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT1' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_2' ,& - UNITS = 'J_m-2' ,& - SHORT_NAME = 'GHTCNT2' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT3' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_4' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT4' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_5' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT5' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_heat_content_layer_6' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT6' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC ,& -! LONG_NAME = 'mean_catchment_temp_incl_snw',& -! UNITS = 'K' ,& -! SHORT_NAME = 'TSURF' ,& -! DIMS = MAPL_DimsTileOnly ,& -! VLOCATION = MAPL_VLocationNone ,& -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_mass_layer_1' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN1' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_mass_layer_2' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN2' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_mass_layer_3' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN3' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'heat_content_snow_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN1' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'heat_content_snow_layer_2' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN2' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'heat_content_snow_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN3' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_depth_layer_1' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN1' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_depth_layer_2' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN2' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_depth_layer_3' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN3' ,& -! FRIENDLYTO = trim(COMP_NAME) ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC ,& -! LONG_NAME = 'surface_heat_exchange_coefficient',& -! UNITS = 'kg m-2 s-1' ,& -! SHORT_NAME = 'CH' ,& -! DIMS = MAPL_DimsTileTile ,& -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone ,& -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC ,& -! LONG_NAME = 'surface_momentum_exchange_coefficient',& -! UNITS = 'kg m-2 s-1' ,& -! SHORT_NAME = 'CM' ,& -! DIMS = MAPL_DimsTileTile ,& -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone ,& -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) -! -! call MAPL_AddExportSpec(GC ,& -! LONG_NAME = 'surface_moisture_exchange_coffiecient',& -! UNITS = 'kg m-2 s-1' ,& -! SHORT_NAME = 'CQ' ,& -! DIMS = MAPL_DimsTileTile ,& -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone ,& -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC ,& -! LONG_NAME = 'subtile_fractions' ,& -! UNITS = '1' ,& -! SHORT_NAME = 'FR' ,& -! DIMS = MAPL_DimsTileTile ,& -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone ,& -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! SHORT_NAME = 'WW', & -! LONG_NAME = 'vertical_velocity_scale_squared', & -! UNITS = 'm+2 s-2', & -! DIMS = MAPL_DimsTileTile, & -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone, & -! RESTART = RESTART_IN_FILE ,& -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! SHORT_NAME = 'DCH', & -! LONG_NAME = 'ch difference, optional in louissurface', & -! UNITS = '1', & -! DIMS = MAPL_DimsTileTile, & -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone, & -! RESTART = .false. ,& -! RC=STATUS ) -! VERIFY_(STATUS) -! -! call MAPL_AddExportSpec(GC, & -! SHORT_NAME = 'DCQ', & -! LONG_NAME = 'cq difference, optional in louissurface', & -! UNITS = '1', & -! DIMS = MAPL_DimsTileTile, & -! NUM_SUBTILES = NUM_SUBTILES ,& -! VLOCATION = MAPL_VLocationNone, & -! RESTART = .false. ,& -! RC=STATUS ) -! VERIFY_(STATUS) - - -! !EXPORT STATE: - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'evaporation' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'EVAPOUT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sublimation' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'SUBLIM' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'upward_sensible_heat_flux' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'SHOUT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'RUNOFF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'interception_loss_energy_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'EVPINT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baresoil_evap_energy_flux' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'EVPSOI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transpiration_energy_flux' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'EVPVEG' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_ice_evaporation_energy_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'EVPICE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil moisture in Upper 10cm' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WAT10CM' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'totoal soil moisture' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WATSOI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil frozen water content' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'ICESOI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snowpack_evaporation_energy_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'EVPSNO' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baseflow_flux' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'BASEFLOW' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'overland_runoff_including_throughflow' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'RUNSURF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snowmelt_flux' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'SMELT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_outgoing_longwave_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'HLWUP' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'surface_net_downward_longwave_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'LWNDSRF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'surface_net_downward_shortwave_flux',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'SWNDSRF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_latent_energy_flux' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'HLATN' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'rainwater_infiltration_flux',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'QINFIL' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - !call MAPL_AddExportSpec(GC, & - ! LONG_NAME = 'areal_fraction_saturated_zone',& - ! UNITS = '1' ,& - ! SHORT_NAME = 'AR1' ,& - ! DIMS = MAPL_DimsTileOnly ,& - ! VLOCATION = MAPL_VLocationNone ,& - ! RC=STATUS ) - !VERIFY_(STATUS) - - !call MAPL_AddExportSpec(GC, & - ! LONG_NAME = 'areal_fraction_transpiration_zone',& - ! UNITS = '1' ,& - ! SHORT_NAME = 'AR2' ,& - ! DIMS = MAPL_DimsTileOnly ,& - ! VLOCATION = MAPL_VLocationNone ,& - ! RC=STATUS ) - !VERIFY_(STATUS) - - !call MAPL_AddExportSpec(GC, & - ! LONG_NAME = 'root_zone_equilibrium_moisture',& - ! UNITS = 'kg m-2' ,& - ! SHORT_NAME = 'RZEQ' ,& - ! DIMS = MAPL_DimsTileOnly ,& - ! VLOCATION = MAPL_VLocationNone ,& - ! RC=STATUS ) - !VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ground_energy_flux' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'GHFLX' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_catchment_temp_incl_snw',& - UNITS = 'K' ,& - SHORT_NAME = 'TPSURF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_catchment_temp_incl_snw_ensstd',& - UNITS = 'K' ,& - SHORT_NAME = 'TPSURF_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_top_snow_layer',& - UNITS = 'K' ,& - SHORT_NAME = 'TPSNOW' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_unsaturated_zone',& - UNITS = 'K' ,& - SHORT_NAME = 'TPUNST' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_saturated_zone',& - UNITS = 'K' ,& - SHORT_NAME = 'TPSAT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_wilted_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TPWLT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_land_snowcover',& - UNITS = '1' ,& - SHORT_NAME = 'ASNOW' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'downward_heat_flux_into_snow',& - UNITS = 'W m-2' ,& - SHORT_NAME = 'SHSNOW' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'averaged_snow_temperature' ,& - UNITS = 'K' ,& - SHORT_NAME = 'AVETSNOW' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_saturated_zone',& - UNITS = '1' ,& - SHORT_NAME = 'FRSAT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_unsaturated_zone',& - UNITS = '1' ,& - SHORT_NAME = 'FRUST' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_wilting_zone',& - UNITS = '1' ,& - SHORT_NAME = 'FRWLT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_mass' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'SNOWMASS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_depth' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNOWDP' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_soil_wetness' ,& - UNITS = '1' ,& - SHORT_NAME = 'WET1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'root_zone_soil_wetness' ,& - UNITS = '1' ,& - SHORT_NAME = 'WET2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_prof_soil__moisture' ,& - UNITS = '1' ,& - SHORT_NAME = 'WET3' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_surface_layer' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCSF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_surface_layer_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCSF_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_root_zone' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCRZ' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_root_zone_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCRZ_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_ave_prof' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCPR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_ave_prof_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCPR_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_1' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL1TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_1_ensstd' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL1TILE_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_2' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL2TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_3' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL3TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_4' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL4TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_5' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL5TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_6' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL6TILE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_emissivity' ,& - UNITS = '1' ,& - SHORT_NAME = 'EMIS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_beam',& - UNITS = '1' ,& - SHORT_NAME = 'ALBVR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_diffuse',& - UNITS = '1' ,& - SHORT_NAME = 'ALBVF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_beam',& - UNITS = '1' ,& - SHORT_NAME = 'ALBNR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_diffuse',& - UNITS = '1' ,& - SHORT_NAME = 'ALBNF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'change_surface_skin_temperature',& - UNITS = 'K' ,& - SHORT_NAME = 'DELTS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'change_surface_specific_humidity',& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'DELQS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - !call MAPL_AddExportSpec(GC, & - ! LONG_NAME = 'change_evaporation' ,& - ! UNITS = 'kg m-2 s-1' ,& - ! SHORT_NAME = 'DELEVAP' ,& - ! DIMS = MAPL_DimsTileOnly ,& - ! VLOCATION = MAPL_VLocationNone ,& - ! RC=STATUS ) - !VERIFY_(STATUS) - - !call MAPL_AddExportSpec(GC, & - ! LONG_NAME = 'change_upward_sensible_energy_flux',& - ! UNITS = 'W m-2' ,& - ! SHORT_NAME = 'DELSH' ,& - ! DIMS = MAPL_DimsTileOnly ,& - ! VLOCATION = MAPL_VLocationNone ,& - ! RC=STATUS ) - !VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_skin_temperature' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TST' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'land_surface_skin_temperature' ,& - UNITS = 'K' ,& - SHORT_NAME = 'LST' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_specific_humidity' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QST' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulence_surface_skin_temperature',& - UNITS = 'K' ,& - SHORT_NAME = 'TH' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulence_surface_skin_specific_hum',& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QH' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_heat_exchange_coefficient',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CHT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_momentum_exchange_coefficient',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CMT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_moisture_exchange_coefficient',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CQT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'neutral_drag_coefficient' ,& - UNITS = '1' ,& - SHORT_NAME = 'CNT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_bulk_richardson_number',& - UNITS = '1' ,& - SHORT_NAME = 'RIT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_roughness' ,& - UNITS = 'm' ,& - SHORT_NAME = 'Z0' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOT2M', & - LONG_NAME = 'temperature 2m wind from MO sfc', & - UNITS = 'K', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOQ2M', & - LONG_NAME = 'humidity 2m wind from MO sfc', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOU2M', & - LONG_NAME = 'zonal 2m wind from MO sfc',& - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOV2M', & - LONG_NAME = 'meridional 2m wind from MO sfc', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOT10M', & - LONG_NAME = 'temperature 10m wind from MO sfc', & - UNITS = 'K', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOQ10M', & - LONG_NAME = 'humidity 10m wind from MO sfc', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOU10M', & - LONG_NAME = 'zonal 10m wind from MO sfc',& - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOV10M', & - LONG_NAME = 'meridional 10m wind from MO sfc', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOU50M', & - LONG_NAME = 'zonal 50m wind from MO sfc',& - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MOV50M', & - LONG_NAME = 'meridional 50m wind from MO sfc', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_roughness_for_heat',& - UNITS = 'm' ,& - SHORT_NAME = 'Z0H' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'zero_plane_displacement_height',& - UNITS = 'm' ,& - SHORT_NAME = 'D0' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'GUST', & - LONG_NAME = 'gustiness', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'VENT', & - LONG_NAME = 'surface_ventilation_velocity',& - UNITS = 'm s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'ACCUM', & - LONG_NAME = 'net_ice_accumulation_rate', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'EVLAND', & - LONG_NAME = 'Evaporation_land', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'PRLAND', & - LONG_NAME = 'Total_precipitation_land', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SNOLAND', & - LONG_NAME = 'snowfall_land', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DRPARLAND', & - LONG_NAME = 'surface_downwelling_par_beam_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DFPARLAND', & - LONG_NAME = 'surface_downwelling_par_diffuse_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LHSNOW', & - LONG_NAME = 'Latent_heat_flux_snow', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SWNETSNOW', & - LONG_NAME = 'Net_shortwave_snow', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWUPSNOW', & - LONG_NAME = 'Net_longwave_snow', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWDNSNOW', & - LONG_NAME = 'Net_longwave_snow', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TCSORIG', & - LONG_NAME = 'Input_tc_for_snow', & - UNITS = 'K', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TPSN1IN', & - LONG_NAME = 'Input_temp_of_top_snow_lev',& - UNITS = 'K', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TPSN1OUT', & - LONG_NAME = 'Output_temp_of_top_snow_lev',& - UNITS = 'K', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'GHSNOW', & - LONG_NAME = 'Ground_heating_snow', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LHLAND', & - LONG_NAME = 'Latent_heat_flux_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SHLAND', & - LONG_NAME = 'Sensible_heat_flux_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SWLAND', & - LONG_NAME = 'Net_shortwave_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SWDOWNLAND', & - LONG_NAME = 'Incident_shortwave_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWLAND', & - LONG_NAME = 'Net_longwave_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'GHLAND', & - LONG_NAME = 'Ground_heating_land', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'GHTSKIN', & - LONG_NAME = 'Ground_heating_skin_temp', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SMLAND', & - LONG_NAME = 'Snowmelt_flux_land', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TWLAND', & - LONG_NAME = 'Avail_water_storage_land', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TELAND', & - LONG_NAME = 'Total_energy_storage_land', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TSLAND', & - LONG_NAME = 'Total_snow_storage_land', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DWLAND', & - LONG_NAME = 'rate_of_change_of_total_land_water',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DHLAND', & - LONG_NAME = 'rate_of_change_of_total_land_energy',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SPLAND', & - LONG_NAME = 'rate_of_spurious_land_energy_source',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SPWATR', & - LONG_NAME = 'rate_of_spurious_land_water_source',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SPSNOW', & - LONG_NAME = 'rate_of_spurious_snow_energy',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& - UNITS = 'm' ,& - SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_exposed_leaf-area_index',& - UNITS = '1' ,& - SHORT_NAME = 'CNLAI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_total_leaf-area_index' ,& - UNITS = '1' ,& - SHORT_NAME = 'CNTLAI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_exposed_stem-area_index',& - UNITS = '1' ,& - SHORT_NAME = 'CNSAI' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_total_carbon' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CNTOTC' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_total_vegetation_carbon',& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CNVEGC' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_net_primary_production' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNNPP' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_gross_primary_production',& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNGPP' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_total_soil_respiration' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNSR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_net_ecosystem_exchange' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNNEE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'abstract_C_pool_to_meet_excess_MR_demand' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CNXSMR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_added_to_maintain_positive_C' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNADD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_carbon_loss_to_fire' ,& - UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'CNLOSS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_fractional_area_burn_rate' ,& - UNITS = 's-1' ,& - SHORT_NAME = 'CNBURN' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_total_root_C' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CNROOT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'CN_fine_root_carbon' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CNFROOTC' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'fire season length' ,& - UNITS = 'days' ,& - SHORT_NAME = 'CNFSEL' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'absorbed_PAR' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'PARABS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'incident_PAR' ,& - UNITS = 'W m-2' ,& - SHORT_NAME = 'PARINC' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'saturated_stomatal_conductance' ,& - UNITS = 'm s-1' ,& - SHORT_NAME = 'SCSAT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'unstressed_stomatal_conductance' ,& - UNITS = 'm s-1' ,& - SHORT_NAME = 'SCUNS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'transpiration coefficient' ,& - UNITS = '1' ,& - SHORT_NAME = 'BTRANT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'solar induced fluorescence',& - UNITS = 'umol m-2 sm s-1' ,& - SHORT_NAME = 'SIF' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - - ! !EXPORT FORCING STATE: - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "TA", & - LONG_NAME = "perturbed_surface_air_temperature", & - UNITS = "K", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "QA", & - LONG_NAME = "perturbed_surface_air_specific_humidity", & - UNITS = "kg kg-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PS", & - LONG_NAME = "surface_pressure", & - UNITS = "Pa", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "UU", & - LONG_NAME = "perturbed_surface_wind_speed", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "UWINDLMTILE", & - LONG_NAME = "perturbed_levellm_uwind", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "VWINDLMTILE", & - LONG_NAME = "perturbed_levellm_vwind", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PCU", & - LONG_NAME = "perturbed_liquid_water_convective_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PLS", & - LONG_NAME = "perturbed_liquid_water_large_scale_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "RainfSnowf", & - LONG_NAME = "rainf+snowf", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "SNO", & - LONG_NAME = "perturbed_snowfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRPAR", & - LONG_NAME = "surface_downwelling_par_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFPAR", & - LONG_NAME = "surface_downwelling_par_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRNIR", & - LONG_NAME = "surface_downwelling_nir_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFNIR", & - LONG_NAME = "surface_downwelling_nir_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRUVR", & - LONG_NAME = "surface_downwelling_uvr_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFUVR", & - LONG_NAME = "surface_downwelling_uvr_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "LWDNSRF", & - LONG_NAME = "perturbed_surface_downwelling_longwave_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DZ", & - LONG_NAME = "reference_height_for_Tair_Qair_Wind", & - UNITS = "m", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - !EOS - - ! Set profiling timers - call MAPL_TimerAdd(gc, name="Initialize", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Collect_force", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Collect_land", rc=status) - VERIFY_(status) - - ! Call SetServices for children - call MAPL_GenericSetServices(gc, rc=status) - VERIFY_(status) - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - - !BOP - - ! !IROTUINE: Initialize -- initialize method for LDAS GC - - ! !INTERFACE: - - subroutine Initialize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - integer :: land_nt_local - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Initialize" - - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Initialize") - - call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - - ! nodata handling for ensemble average - _ASSERT( (MAPL_UNDEF>.9999*1.e15), Iam // ': nodata handling for ensemble average requires MAPL_UNDEF to be a very large number') - enavg_nodata_threshold = MAPL_UNDEF/(NUM_ENSEMBLE+1) - - collect_land_counter = 0 - collect_force_counter = 0 - - ! Get number of land tiles - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - allocate(catch_progn(land_nt_local, NUM_ENSEMBLE)) - allocate(catch_param(land_nt_local)) - - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - VERIFY_(status) - - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - - RETURN_(ESMF_SUCCESS) - - end subroutine Initialize - - - !BOP - - ! !IROTUINE: collecting and averaging - - subroutine Collect_force_ens(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_VM) :: vm - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - - ! Pointers to imports - real, pointer :: TApert(:)=>null() - real, pointer :: QApert(:)=>null() - real, pointer :: PSpert(:)=>null() - real, pointer :: UUpert(:)=>null() - real, pointer :: PCUpert(:)=>null() - real, pointer :: PLSpert(:)=>null() - real, pointer :: SNOpert(:)=>null() - real, pointer :: DRPARpert(:)=>null() - real, pointer :: DFPARpert(:)=>null() - real, pointer :: DRNIRpert(:)=>null() - real, pointer :: DFNIRpert(:)=>null() - real, pointer :: DRUVRpert(:)=>null() - real, pointer :: DFUVRpert(:)=>null() - real, pointer :: LWDNSRFpert(:)=>null() - real, pointer :: DZpert(:)=>null() - - real, pointer :: TA_enavg(:)=>null() - real, pointer :: QA_enavg(:)=>null() - real, pointer :: PS_enavg(:)=>null() - real, pointer :: UU_enavg(:)=>null() - real, pointer :: PCU_enavg(:)=>null() - real, pointer :: PLS_enavg(:)=>null() - real, pointer :: SNO_enavg(:)=>null() - real, pointer :: DRPAR_enavg(:)=>null() - real, pointer :: DFPAR_enavg(:)=>null() - real, pointer :: DRNIR_enavg(:)=>null() - real, pointer :: DFNIR_enavg(:)=>null() - real, pointer :: DRUVR_enavg(:)=>null() - real, pointer :: DFUVR_enavg(:)=>null() - real, pointer :: LWDNSRF_enavg(:)=>null() - real, pointer :: DZ_enavg(:)=>null() - real, pointer :: RainfSnowf(:)=>null() - - - ! Get my name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run_collect_force_ens" - - if(NUM_ENSEMBLE ==1) then - ! RETURN_(ESMF_SUCCESS) - endif - - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Collect_force") - - - call MAPL_GetPointer(import, TApert, 'TApert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, QApert, 'QApert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PSpert, 'PSpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, UUpert, 'UUpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PCUpert, 'PCUpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PLSpert, 'PLSpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNOpert, 'SNOpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DRPARpert, 'DRPARpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DFPARpert, 'DFPARpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DRNIRpert, 'DRNIRpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DFNIRpert, 'DFNIRpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DRUVRpert, 'DRUVRpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DFUVRpert, 'DFUVRpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWDNSRFpert, 'LWDNSRFpert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DZpert, 'DZpert', rc=status) - VERIFY_(status) - - ! Pointers to exports (allocate memory) - call MAPL_GetPointer(export, TA_enavg, 'TA', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QA_enavg, 'QA', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PS_enavg, 'PS', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, UU_enavg, 'UU', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PCU_enavg, 'PCU',alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PLS_enavg, 'PLS', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNO_enavg, 'SNO', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRPAR_enavg, 'DRPAR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFPAR_enavg, 'DFPAR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRNIR_enavg, 'DRNIR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFNIR_enavg, 'DFNIR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRUVR_enavg, 'DRUVR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFUVR_enavg, 'DFUVR', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWDNSRF_enavg, 'LWDNSRF', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DZ_enavg, 'DZ', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RainfSnowf, 'RainfSnowf', alloc=.true., rc=status) - VERIFY_(status) - - if(collect_force_counter ==0) then - if(associated(TA_enavg)) TA_enavg = 0.0 - if(associated(QA_enavg)) QA_enavg = 0.0 - if(associated(PS_enavg)) PS_enavg = 0.0 - if(associated(UU_enavg)) UU_enavg = 0.0 - if(associated(PCU_enavg)) PCU_enavg = 0.0 - if(associated(PLS_enavg)) PLS_enavg = 0.0 - if(associated(SNO_enavg)) SNO_enavg = 0.0 - if(associated(DRPAR_enavg)) DRPAR_enavg = 0.0 - if(associated(DFPAR_enavg)) DFPAR_enavg = 0.0 - if(associated(DRNIR_enavg)) DRNIR_enavg = 0.0 - if(associated(DFNIR_enavg)) DFNIR_enavg = 0.0 - if(associated(DRUVR_enavg)) DRUVR_enavg = 0.0 - if(associated(DFUVR_enavg)) DFUVR_enavg = 0.0 - if(associated(LWDNSRF_enavg)) LWDNSRF_enavg = 0.0 - if(associated(DZ_enavg)) DZ_enavg = 0.0 - endif - - if(associated(TA_enavg)) & - TA_enavg = TA_enavg + TApert - if(associated(QA_enavg)) & - QA_enavg = QA_enavg + QApert - if(associated(PS_enavg)) & - PS_enavg = PS_enavg + PSpert - if(associated(UU_enavg)) & - UU_enavg = UU_enavg + UUpert - if(associated(PCU_enavg)) & - PCU_enavg = PCU_enavg + PCUpert - if(associated(PLS_enavg)) & - PLS_enavg = PLS_enavg + PLSpert - if(associated(SNO_enavg)) & - SNO_enavg = SNO_enavg + SNOpert - if(associated(DRPAR_enavg)) & - DRPAR_enavg = DRPAR_enavg + DRPARpert - if(associated(DFPAR_enavg)) & - DFPAR_enavg = DFPAR_enavg + DFPARpert - if(associated(DRNIR_enavg)) & - DRNIR_enavg = DRNIR_enavg + DRNIRpert - if(associated(DFNIR_enavg)) & - DFNIR_enavg = DFNIR_enavg + DFNIRpert - if(associated(DRUVR_enavg)) & - DRUVR_enavg = DRUVR_enavg + DRUVRpert - if(associated(DFUVR_enavg)) & - DFUVR_enavg = DFUVR_enavg + DFUVRpert - if(associated(LWDNSRF_enavg)) & - LWDNSRF_enavg = LWDNSRF_enavg + LWDNSRFpert - if(associated(DZ_enavg)) & - DZ_enavg = DZ_enavg + DZpert - - collect_force_counter = collect_force_counter + 1 - if(collect_force_counter == NUM_ENSEMBLE) then - collect_force_counter = 0 - - if(associated(TA_enavg)) TA_enavg =TA_enavg /NUM_ENSEMBLE - if(associated(QA_enavg)) QA_enavg =QA_enavg /NUM_ENSEMBLE - if(associated(PS_enavg)) PS_enavg =PS_enavg /NUM_ENSEMBLE - if(associated(UU_enavg)) UU_enavg =UU_enavg /NUM_ENSEMBLE - if(associated(PCU_enavg)) PCU_enavg =PCU_enavg /NUM_ENSEMBLE - if(associated(PLS_enavg)) PLS_enavg =PLS_enavg /NUM_ENSEMBLE - if(associated(SNO_enavg)) SNO_enavg =SNO_enavg /NUM_ENSEMBLE - if(associated(DRPAR_enavg)) DRPAR_enavg =DRPAR_enavg /NUM_ENSEMBLE - if(associated(DFPAR_enavg)) DFPAR_enavg =DFPAR_enavg /NUM_ENSEMBLE - if(associated(DRNIR_enavg)) DRNIR_enavg =DRNIR_enavg /NUM_ENSEMBLE - if(associated(DFNIR_enavg)) DFNIR_enavg =DFNIR_enavg /NUM_ENSEMBLE - if(associated(DRUVR_enavg)) DRUVR_enavg =DRUVR_enavg /NUM_ENSEMBLE - if(associated(DFUVR_enavg)) DFUVR_enavg =DFUVR_enavg /NUM_ENSEMBLE - if(associated(LWDNSRF_enavg)) LWDNSRF_enavg =LWDNSRF_enavg /NUM_ENSEMBLE - if(associated(DZ_enavg)) DZ_enavg =DZ_enavg /NUM_ENSEMBLE - if(associated(RainfSnowf)) RainfSnowf =PLS_enavg + PCU_enavg + SNO_enavg - - endif - ! Turn timers off - call MAPL_TimerOff(MAPL, "Collect_force") - call MAPL_TimerOff(MAPL, "TOTAL") - - RETURN_(ESMF_SUCCESS) - - end subroutine Collect_force_ens - - subroutine Collect_land_ens(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_VM) :: vm - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - - real, pointer :: poros(:) =>null() - real, pointer :: cond(:) =>null() - real, pointer :: psis(:) =>null() - real, pointer :: bee(:) =>null() - real, pointer :: wpwet(:) =>null() - real, pointer :: gnu(:) =>null() - real, pointer :: vgwmax(:) =>null() - real, pointer :: bf1(:) =>null() - real, pointer :: bf2(:) =>null() - real, pointer :: bf3(:) =>null() - real, pointer :: cdcr1(:) =>null() - real, pointer :: cdcr2(:) =>null() - real, pointer :: ars1(:) =>null() - real, pointer :: ars2(:) =>null() - real, pointer :: ars3(:) =>null() - real, pointer :: ara1(:) =>null() - real, pointer :: ara2(:) =>null() - real, pointer :: ara3(:) =>null() - real, pointer :: ara4(:) =>null() - real, pointer :: arw1(:) =>null() - real, pointer :: arw2(:) =>null() - real, pointer :: arw3(:) =>null() - real, pointer :: arw4(:) =>null() - real, pointer :: tsa1(:) =>null() - real, pointer :: tsa2(:) =>null() - real, pointer :: tsb1(:) =>null() - real, pointer :: tsb2(:) =>null() - real, pointer :: atau(:) =>null() - real, pointer :: btau(:) =>null() - real, pointer :: ity(:) =>null() - - real, pointer :: in_lai(:) =>null() - real, pointer :: out_lai(:) =>null() - - - real, dimension(:,:),pointer :: TC,TC_enavg - real, dimension(:,:),pointer :: QC,QC_enavg - real, dimension(:),pointer :: CAPAC,CAPAC_enavg - real, dimension(:),pointer :: CATDEF,CATDEF_enavg - real, dimension(:),pointer :: RZEXC,RZEXC_enavg - real, dimension(:),pointer :: SRFEXC,SRFEXC_enavg - real, dimension(:),pointer :: GHTCNT1,GHTCNT1_enavg - real, dimension(:),pointer :: GHTCNT2,GHTCNT2_enavg - real, dimension(:),pointer :: GHTCNT3,GHTCNT3_enavg - real, dimension(:),pointer :: GHTCNT4,GHTCNT4_enavg - real, dimension(:),pointer :: GHTCNT5,GHTCNT5_enavg - real, dimension(:),pointer :: GHTCNT6,GHTCNT6_enavg - real, dimension(:),pointer :: WESNN1,WESNN1_enavg - real, dimension(:),pointer :: WESNN2,WESNN2_enavg - real, dimension(:),pointer :: WESNN3,WESNN3_enavg - real, dimension(:),pointer :: HTSNNN1,HTSNNN1_enavg - real, dimension(:),pointer :: HTSNNN2,HTSNNN2_enavg - real, dimension(:),pointer :: HTSNNN3,HTSNNN3_enavg - real, dimension(:),pointer :: SNDZN1,SNDZN1_enavg - real, dimension(:),pointer :: SNDZN2,SNDZN2_enavg - real, dimension(:),pointer :: SNDZN3,SNDZN3_enavg - real, dimension(:),pointer :: EVAPOUT,EVAPOUT_enavg - real, dimension(:),pointer :: SUBLIM,SUBLIM_enavg - real, dimension(:),pointer :: SHOUT,SHOUT_enavg - real, dimension(:),pointer :: RUNOFF,RUNOFF_enavg - real, dimension(:),pointer :: EVPINT,EVPINT_enavg - real, dimension(:),pointer :: EVPSOI,EVPSOI_enavg - real, dimension(:),pointer :: EVPVEG,EVPVEG_enavg - real, dimension(:),pointer :: EVPICE,EVPICE_enavg - real, dimension(:),pointer :: WAT10CM,WAT10CM_enavg - real, dimension(:),pointer :: WATSOI,WATSOI_enavg - real, dimension(:),pointer :: ICESOI,ICESOI_enavg - real, dimension(:),pointer :: EVPSNO,EVPSNO_enavg - real, dimension(:),pointer :: BASEFLOW,BASEFLOW_enavg - real, dimension(:),pointer :: RUNSURF,RUNSURF_enavg - real, dimension(:),pointer :: SMELT,SMELT_enavg - real, dimension(:),pointer :: HLWUP,HLWUP_enavg - real, dimension(:),pointer :: LWNDSRF,LWNDSRF_enavg - real, dimension(:),pointer :: SWNDSRF,SWNDSRF_enavg - real, dimension(:),pointer :: HLATN,HLATN_enavg - real, dimension(:),pointer :: QINFIL,QINFIL_enavg - real, dimension(:),pointer :: GHFLX,GHFLX_enavg - real, dimension(:),pointer :: TPSURF,TPSURF_enavg,TPSURF_enstd - real, dimension(:),pointer :: TPSNOW,TPSNOW_enavg - real, dimension(:),pointer :: TPUNST,TPUNST_enavg - real, dimension(:),pointer :: TPSAT,TPSAT_enavg - real, dimension(:),pointer :: TPWLT,TPWLT_enavg - !real, dimension(:),pointer :: ASNOW,ASNOW_enavg - real, dimension(:),pointer :: ASNOW_enavg - real, dimension(:),pointer :: SHSNOW,SHSNOW_enavg - real, dimension(:),pointer :: AVETSNOW,AVETSNOW_enavg - real, dimension(:),pointer :: FRSAT,FRSAT_enavg - real, dimension(:),pointer :: FRUST,FRUST_enavg - real, dimension(:),pointer :: FRWLT,FRWLT_enavg - real, dimension(:),pointer :: SNOWMASS,SNOWMASS_enavg - real, dimension(:),pointer :: SNOWDP,SNOWDP_enavg - real, dimension(:),pointer :: WET1,WET1_enavg - real, dimension(:),pointer :: WET2,WET2_enavg - real, dimension(:),pointer :: WET3,WET3_enavg - real, dimension(:),pointer :: WCSF,WCSF_enavg,WCSF_enstd - real, dimension(:),pointer :: WCRZ,WCRZ_enavg,WCRZ_enstd - real, dimension(:),pointer :: WCPR,WCPR_enavg,WCPR_enstd - real, dimension(:),pointer :: TP1,TP1_enavg,TP1_enstd - real, dimension(:),pointer :: TP2,TP2_enavg - real, dimension(:),pointer :: TP3,TP3_enavg - real, dimension(:),pointer :: TP4,TP4_enavg - real, dimension(:),pointer :: TP5,TP5_enavg - real, dimension(:),pointer :: TP6,TP6_enavg - real, dimension(:),pointer :: EMIS,EMIS_enavg - real, dimension(:),pointer :: ALBVR,ALBVR_enavg - real, dimension(:),pointer :: ALBVF,ALBVF_enavg - real, dimension(:),pointer :: ALBNR,ALBNR_enavg - real, dimension(:),pointer :: ALBNF,ALBNF_enavg - real, dimension(:),pointer :: DELTS,DELTS_enavg - real, dimension(:),pointer :: DELQS,DELQS_enavg - real, dimension(:),pointer :: TST,TST_enavg - real, dimension(:),pointer :: LST,LST_enavg - real, dimension(:),pointer :: QST,QST_enavg - real, dimension(:),pointer :: TH,TH_enavg - real, dimension(:),pointer :: QH,QH_enavg - real, dimension(:),pointer :: CHT,CHT_enavg - real, dimension(:),pointer :: CMT,CMT_enavg - real, dimension(:),pointer :: CQT,CQT_enavg - real, dimension(:),pointer :: CNT,CNT_enavg - real, dimension(:),pointer :: RIT,RIT_enavg - real, dimension(:),pointer :: Z0,Z0_enavg - real, dimension(:),pointer :: MOT2M,MOT2M_enavg - real, dimension(:),pointer :: MOQ2M,MOQ2M_enavg - real, dimension(:),pointer :: MOU2M,MOU2M_enavg - real, dimension(:),pointer :: MOV2M,MOV2M_enavg - real, dimension(:),pointer :: MOT10M,MOT10M_enavg - real, dimension(:),pointer :: MOQ10M,MOQ10M_enavg - real, dimension(:),pointer :: MOU10M,MOU10M_enavg - real, dimension(:),pointer :: MOV10M,MOV10M_enavg - real, dimension(:),pointer :: MOU50M,MOU50M_enavg - real, dimension(:),pointer :: MOV50M,MOV50M_enavg - real, dimension(:),pointer :: Z0H,Z0H_enavg - real, dimension(:),pointer :: D0,D0_enavg - real, dimension(:),pointer :: GUST,GUST_enavg - real, dimension(:),pointer :: VENT,VENT_enavg - real, dimension(:),pointer :: ACCUM,ACCUM_enavg - real, dimension(:),pointer :: EVLAND,EVLAND_enavg - real, dimension(:),pointer :: PRLAND,PRLAND_enavg - real, dimension(:),pointer :: SNOLAND,SNOLAND_enavg - real, dimension(:),pointer :: DRPARLAND,DRPARLAND_enavg - real, dimension(:),pointer :: DFPARLAND,DFPARLAND_enavg - real, dimension(:),pointer :: LHSNOW,LHSNOW_enavg - real, dimension(:),pointer :: SWNETSNOW,SWNETSNOW_enavg - real, dimension(:),pointer :: LWUPSNOW,LWUPSNOW_enavg - real, dimension(:),pointer :: LWDNSNOW,LWDNSNOW_enavg - real, dimension(:),pointer :: TCSORIG,TCSORIG_enavg - real, dimension(:),pointer :: TPSN1IN,TPSN1IN_enavg - real, dimension(:),pointer :: TPSN1OUT,TPSN1OUT_enavg - real, dimension(:),pointer :: GHSNOW,GHSNOW_enavg - real, dimension(:),pointer :: LHLAND,LHLAND_enavg - real, dimension(:),pointer :: SHLAND,SHLAND_enavg - real, dimension(:),pointer :: SWLAND,SWLAND_enavg - real, dimension(:),pointer :: SWDOWNLAND,SWDOWNLAND_enavg - real, dimension(:),pointer :: LWLAND,LWLAND_enavg - real, dimension(:),pointer :: GHLAND,GHLAND_enavg - real, dimension(:),pointer :: GHTSKIN,GHTSKIN_enavg - real, dimension(:),pointer :: SMLAND,SMLAND_enavg - real, dimension(:),pointer :: TWLAND,TWLAND_enavg - real, dimension(:),pointer :: TELAND,TELAND_enavg - real, dimension(:),pointer :: TSLAND,TSLAND_enavg - real, dimension(:),pointer :: DWLAND,DWLAND_enavg - real, dimension(:),pointer :: DHLAND,DHLAND_enavg - real, dimension(:),pointer :: SPLAND,SPLAND_enavg - real, dimension(:),pointer :: SPWATR,SPWATR_enavg - real, dimension(:),pointer :: SPSNOW,SPSNOW_enavg - real, dimension(:),pointer :: PEATCLSM_WATERLEVEL,PEATCLSM_WATERLEVEL_enavg - real, dimension(:),pointer :: PEATCLSM_FSWCHANGE, PEATCLSM_FSWCHANGE_enavg - - real, dimension(:), pointer :: CNLAI, CNLAI_enavg - real, dimension(:), pointer :: CNTLAI, CNTLAI_enavg - real, dimension(:), pointer :: CNSAI, CNSAI_enavg - real, dimension(:), pointer :: CNTOTC, CNTOTC_enavg - real, dimension(:), pointer :: CNVEGC, CNVEGC_enavg - real, dimension(:), pointer :: CNROOT, CNROOT_enavg - real, dimension(:), pointer :: CNFROOTC, CNFROOTC_enavg - real, dimension(:), pointer :: CNNPP, CNNPP_enavg - real, dimension(:), pointer :: CNGPP, CNGPP_enavg - real, dimension(:), pointer :: CNSR, CNSR_enavg - real, dimension(:), pointer :: CNNEE, CNNEE_enavg - real, dimension(:), pointer :: CNXSMR, CNXSMR_enavg - real, dimension(:), pointer :: CNADD, CNADD_enavg - real, dimension(:), pointer :: PARABS, PARABS_enavg - real, dimension(:), pointer :: PARINC, PARINC_enavg - real, dimension(:), pointer :: SCSAT, SCSAT_enavg - real, dimension(:), pointer :: SCUNS, SCUNS_enavg - real, dimension(:), pointer :: BTRANT, BTRANT_enavg - real, dimension(:), pointer :: SIF, SIF_enavg - real, dimension(:), pointer :: CNLOSS, CNLOSS_enavg - real, dimension(:), pointer :: CNBURN, CNBURN_enavg - real, dimension(:), pointer :: CNFSEL, CNFSEL_enavg - - real :: Nm1, NdivNm1 - - ! Get my name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run_ens_averaging" - - if(NUM_ENSEMBLE ==1) then - !RETURN_(ESMF_SUCCESS) - endif - - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Collect_land") - - call MAPL_GetPointer(import, poros, 'POROS' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cond, 'COND' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, psis, 'PSIS' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bee, 'BEE' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, wpwet, 'WPWET' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, gnu, 'GNU' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, vgwmax, 'VGWMAX' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf1, 'BF1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf2, 'BF2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf3, 'BF3' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cdcr1, 'CDCR1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cdcr2, 'CDCR2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars1, 'ARS1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars2, 'ARS2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars3, 'ARS3' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara1, 'ARA1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara2, 'ARA2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara3, 'ARA3' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara4, 'ARA4' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw1, 'ARW1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw2, 'ARW2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw3, 'ARW3' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw4, 'ARW4' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsa1, 'TSA1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsa2, 'TSA2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsb1, 'TSB1' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsb2, 'TSB2' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, atau, 'ATAU' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, btau, 'BTAU' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ity, 'ITY' , rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, in_lai, 'LAI' , rc=status) - VERIFY_(status) - - call MAPL_GetPointer(import, TC, 'TC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, QC, 'QC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CAPAC, 'CAPAC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CATDEF, 'CATDEF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, RZEXC, 'RZEXC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SRFEXC, 'SRFEXC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT1, 'GHTCNT1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT2, 'GHTCNT2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT3, 'GHTCNT3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT4, 'GHTCNT4' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT5, 'GHTCNT5' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTCNT6, 'GHTCNT6' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WESNN1, 'WESNN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WESNN2, 'WESNN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WESNN3, 'WESNN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, HTSNNN1, 'HTSNNN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, HTSNNN2, 'HTSNNN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, HTSNNN3, 'HTSNNN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNDZN1, 'SNDZN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNDZN2, 'SNDZN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNDZN3, 'SNDZN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVAPOUT, 'EVAPOUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SUBLIM, 'SUBLIM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SHOUT, 'SHOUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, RUNOFF, 'RUNOFF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVPINT, 'EVPINT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVPSOI, 'EVPSOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVPVEG, 'EVPVEG' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVPICE, 'EVPICE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WAT10CM, 'WAT10CM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WATSOI, 'WATSOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ICESOI, 'ICESOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVPSNO, 'EVPSNO' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, BASEFLOW, 'BASEFLOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, RUNSURF, 'RUNSURF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SMELT, 'SMELT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, HLWUP, 'HLWUP' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWNDSRF, 'LWNDSRF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SWNDSRF, 'SWNDSRF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, HLATN, 'HLATN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, QINFIL, 'QINFIL' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHFLX, 'GHFLX' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPSURF, 'TPSURF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPSNOW, 'TPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPUNST, 'TPUNST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPSAT, 'TPSAT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPWLT, 'TPWLT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SHSNOW, 'SHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, AVETSNOW, 'AVETSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, FRSAT, 'FRSAT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, FRUST, 'FRUST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, FRWLT, 'FRWLT' ,rc=status) - VERIFY_(status) - ! for offline model , there is no 'ASNOW', recompute - ! call MAPL_GetPointer(import, ASNOW, 'ASNOW' ,rc=status) - ! VERIFY_(status) - call MAPL_GetPointer(import, SNOWMASS, 'SNOWMASS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNOWDP, 'SNOWDP' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WET1, 'WET1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WET2, 'WET2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WET3, 'WET3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WCSF, 'WCSF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WCRZ, 'WCRZ' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, WCPR, 'WCPR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP1, 'TP1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP2, 'TP2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP3, 'TP3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP4, 'TP4' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP5, 'TP5' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TP6, 'TP6' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EMIS, 'EMIS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ALBVR, 'ALBVR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ALBVF, 'ALBVF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ALBNR, 'ALBNR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ALBNF, 'ALBNF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DELTS, 'DELTS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DELQS, 'DELQS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TST, 'TST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LST, 'LST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, QST, 'QST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TH, 'TH' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, QH, 'QH' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CHT, 'CHT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CMT, 'CMT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CQT, 'CQT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, CNT, 'CNT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, RIT, 'RIT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Z0, 'Z0' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOT2M, 'MOT2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOQ2M, 'MOQ2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOU2M, 'MOU2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOV2M, 'MOV2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOT10M, 'MOT10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOQ10M, 'MOQ10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOU10M, 'MOU10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOV10M, 'MOV10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOU50M, 'MOU50M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, MOV50M, 'MOV50M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Z0H, 'Z0H' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, D0, 'D0' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GUST, 'GUST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, VENT, 'VENT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ACCUM, 'ACCUM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, EVLAND, 'EVLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PRLAND, 'PRLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SNOLAND, 'SNOLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DRPARLAND, 'DRPARLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DFPARLAND, 'DFPARLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LHSNOW, 'LHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SWNETSNOW, 'SWNETSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWUPSNOW, 'LWUPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWDNSNOW, 'LWDNSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TCSORIG, 'TCSORIG' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPSN1IN, 'TPSN1IN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TPSN1OUT, 'TPSN1OUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHSNOW, 'GHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LHLAND, 'LHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SHLAND, 'SHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SWLAND, 'SWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SWDOWNLAND, 'SWDOWNLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWLAND, 'LWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHLAND, 'GHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, GHTSKIN, 'GHTSKIN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SMLAND, 'SMLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TWLAND, 'TWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TELAND, 'TELAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, TSLAND, 'TSLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DWLAND, 'DWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, DHLAND, 'DHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SPLAND, 'SPLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SPWATR, 'SPWATR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SPSNOW, 'SPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PEATCLSM_FSWCHANGE, 'PEATCLSM_FSWCHANGE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ITY, 'ITY' ,rc=status) - VERIFY_(status) - - ! CatchCN-specific variables (not available in standard Catch) - - call MAPL_GetPointer(import, CNLAI , 'CNLAI' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNTLAI , 'CNTLAI', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNSAI , 'CNSAI' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNTOTC , 'CNTOTC', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNVEGC , 'CNVEGC', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNROOT , 'CNROOT', notFoundOK=.true., _RC) ! CatchCNCLM45 only - call MAPL_GetPointer(import, CNFROOTC , 'CNFROOTC', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNNPP , 'CNNPP' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNGPP , 'CNGPP' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNSR , 'CNSR' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNNEE , 'CNNEE' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNXSMR , 'CNXSMR', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNADD , 'CNADD' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, PARABS , 'PARABS', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, PARINC , 'PARINC', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, SCSAT , 'SCSAT' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, SCUNS , 'SCUNS' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, BTRANT , 'BTRANT', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, SIF , 'SIF' , notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNLOSS , 'CNLOSS', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNBURN , 'CNBURN', notFoundOK=.true., _RC) - call MAPL_GetPointer(import, CNFSEL , 'CNFSEL', notFoundOK=.true., _RC) - - - - call MAPL_GetPointer(export, TC_enavg, 'TC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QC_enavg, 'QC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CAPAC_enavg, 'CAPAC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CATDEF_enavg, 'CATDEF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RZEXC_enavg, 'RZEXC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SRFEXC_enavg, 'SRFEXC' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT1_enavg, 'GHTCNT1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT2_enavg, 'GHTCNT2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT3_enavg, 'GHTCNT3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT4_enavg, 'GHTCNT4' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT5_enavg, 'GHTCNT5' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTCNT6_enavg, 'GHTCNT6' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WESNN1_enavg, 'WESNN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WESNN2_enavg, 'WESNN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WESNN3_enavg, 'WESNN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, HTSNNN1_enavg, 'HTSNNN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, HTSNNN2_enavg, 'HTSNNN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, HTSNNN3_enavg, 'HTSNNN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNDZN1_enavg, 'SNDZN1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNDZN2_enavg, 'SNDZN2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNDZN3_enavg, 'SNDZN3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVAPOUT_enavg, 'EVAPOUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SUBLIM_enavg, 'SUBLIM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SHOUT_enavg, 'SHOUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RUNOFF_enavg, 'RUNOFF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVPINT_enavg, 'EVPINT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVPSOI_enavg, 'EVPSOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVPVEG_enavg, 'EVPVEG' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVPICE_enavg, 'EVPICE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WAT10CM_enavg, 'WAT10CM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WATSOI_enavg, 'WATSOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ICESOI_enavg, 'ICESOI' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVPSNO_enavg, 'EVPSNO' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, BASEFLOW_enavg, 'BASEFLOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RUNSURF_enavg, 'RUNSURF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SMELT_enavg, 'SMELT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, HLWUP_enavg, 'HLWUP' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWNDSRF_enavg, 'LWNDSRF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SWNDSRF_enavg, 'SWNDSRF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, HLATN_enavg, 'HLATN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QINFIL_enavg, 'QINFIL' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHFLX_enavg, 'GHFLX' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSURF_enavg, 'TPSURF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSURF_enstd, 'TPSURF_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSNOW_enavg, 'TPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPUNST_enavg, 'TPUNST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSAT_enavg, 'TPSAT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPWLT_enavg, 'TPWLT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ASNOW_enavg, 'ASNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SHSNOW_enavg, 'SHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, AVETSNOW_enavg, 'AVETSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, FRSAT_enavg, 'FRSAT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, FRUST_enavg, 'FRUST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, FRWLT_enavg, 'FRWLT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNOWMASS_enavg, 'SNOWMASS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNOWDP_enavg, 'SNOWDP' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WET1_enavg, 'WET1' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WET2_enavg, 'WET2' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WET3_enavg, 'WET3' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCSF_enavg, 'WCSF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCSF_enstd, 'WCSF_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCRZ_enavg, 'WCRZ' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCRZ_enstd, 'WCRZ_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCPR_enavg, 'WCPR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, WCPR_enstd, 'WCPR_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP1_enavg, 'TSOIL1TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP1_enstd, 'TSOIL1TILE_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP2_enavg, 'TSOIL2TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP3_enavg, 'TSOIL3TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP4_enavg, 'TSOIL4TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP5_enavg, 'TSOIL5TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TP6_enavg, 'TSOIL6TILE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EMIS_enavg, 'EMIS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ALBVR_enavg, 'ALBVR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ALBVF_enavg, 'ALBVF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ALBNR_enavg, 'ALBNR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ALBNF_enavg, 'ALBNF' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DELTS_enavg, 'DELTS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DELQS_enavg, 'DELQS' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TST_enavg, 'TST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LST_enavg, 'LST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QST_enavg, 'QST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TH_enavg, 'TH' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QH_enavg, 'QH' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CHT_enavg, 'CHT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CMT_enavg, 'CMT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CQT_enavg, 'CQT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, CNT_enavg, 'CNT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RIT_enavg, 'RIT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Z0_enavg, 'Z0' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOT2M_enavg, 'MOT2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOQ2M_enavg, 'MOQ2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOU2M_enavg, 'MOU2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOV2M_enavg, 'MOV2M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOT10M_enavg, 'MOT10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOQ10M_enavg, 'MOQ10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOU10M_enavg, 'MOU10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOV10M_enavg, 'MOV10M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOU50M_enavg, 'MOU50M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, MOV50M_enavg, 'MOV50M' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Z0H_enavg, 'Z0H' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, D0_enavg, 'D0' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GUST_enavg, 'GUST' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, VENT_enavg, 'VENT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, ACCUM_enavg, 'ACCUM' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, EVLAND_enavg, 'EVLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PRLAND_enavg, 'PRLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNOLAND_enavg, 'SNOLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRPARLAND_enavg, 'DRPARLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFPARLAND_enavg, 'DFPARLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LHSNOW_enavg, 'LHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SWNETSNOW_enavg, 'SWNETSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWUPSNOW_enavg, 'LWUPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWDNSNOW_enavg, 'LWDNSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TCSORIG_enavg, 'TCSORIG' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSN1IN_enavg, 'TPSN1IN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSN1OUT_enavg, 'TPSN1OUT' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHSNOW_enavg, 'GHSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LHLAND_enavg, 'LHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SHLAND_enavg, 'SHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SWLAND_enavg, 'SWLAND',alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SWDOWNLAND_enavg, 'SWDOWNLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWLAND_enavg, 'LWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHLAND_enavg, 'GHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, GHTSKIN_enavg, 'GHTSKIN' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SMLAND_enavg, 'SMLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TWLAND_enavg, 'TWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TELAND_enavg, 'TELAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TSLAND_enavg, 'TSLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DWLAND_enavg, 'DWLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DHLAND_enavg, 'DHLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SPLAND_enavg, 'SPLAND' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SPWATR_enavg, 'SPWATR' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SPSNOW_enavg, 'SPSNOW' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PEATCLSM_WATERLEVEL_enavg,'PEATCLSM_WATERLEVEL' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PEATCLSM_FSWCHANGE_enavg, 'PEATCLSM_FSWCHANGE' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, out_lai, 'LAI' , alloc=.true., rc=status) - VERIFY_(status) - - call MAPL_GetPointer(export, CNLAI_enavg , 'CNLAI' , _RC) - call MAPL_GetPointer(export, CNTLAI_enavg , 'CNTLAI', _RC) - call MAPL_GetPointer(export, CNSAI_enavg , 'CNSAI' , _RC) - call MAPL_GetPointer(export, CNTOTC_enavg , 'CNTOTC', _RC) - call MAPL_GetPointer(export, CNVEGC_enavg , 'CNVEGC', _RC) - call MAPL_GetPointer(export, CNROOT_enavg , 'CNROOT', _RC) - call MAPL_GetPointer(export, CNFROOTC_enavg, 'CNFROOTC', _RC) - call MAPL_GetPointer(export, CNNPP_enavg , 'CNNPP' , _RC) - call MAPL_GetPointer(export, CNGPP_enavg , 'CNGPP' , _RC) - call MAPL_GetPointer(export, CNSR_enavg , 'CNSR' , _RC) - call MAPL_GetPointer(export, CNNEE_enavg , 'CNNEE' , _RC) - call MAPL_GetPointer(export, CNXSMR_enavg , 'CNXSMR', _RC) - call MAPL_GetPointer(export, CNADD_enavg , 'CNADD' , _RC) - call MAPL_GetPointer(export, PARABS_enavg , 'PARABS', _RC) - call MAPL_GetPointer(export, PARINC_enavg , 'PARINC', _RC) - call MAPL_GetPointer(export, SCSAT_enavg , 'SCSAT' , _RC) - call MAPL_GetPointer(export, SCUNS_enavg , 'SCUNS' , _RC) - call MAPL_GetPointer(export, BTRANT_enavg , 'BTRANT', _RC) - call MAPL_GetPointer(export, SIF_enavg , 'SIF' , _RC) - call MAPL_GetPointer(export, CNLOSS_enavg , 'CNLOSS', _RC) - call MAPL_GetPointer(export, CNBURN_enavg , 'CNBURN', _RC) - call MAPL_GetPointer(export, CNFSEL_enavg , 'CNFSEL', _RC) - - out_lai = in_lai - if (collect_land_counter == 0) then - - if(associated(TC_enavg)) TC_enavg = 0.0 - if(associated(QC_enavg)) QC_enavg = 0.0 - if(associated(CAPAC_enavg)) CAPAC_enavg = 0.0 - if(associated(CATDEF_enavg)) CATDEF_enavg = 0.0 - if(associated(RZEXC_enavg)) RZEXC_enavg = 0.0 - if(associated(SRFEXC_enavg)) SRFEXC_enavg = 0.0 - if(associated(GHTCNT1_enavg)) GHTCNT1_enavg = 0.0 - if(associated(GHTCNT2_enavg)) GHTCNT2_enavg = 0.0 - if(associated(GHTCNT3_enavg)) GHTCNT3_enavg = 0.0 - if(associated(GHTCNT4_enavg)) GHTCNT4_enavg = 0.0 - if(associated(GHTCNT5_enavg)) GHTCNT5_enavg = 0.0 - if(associated(GHTCNT6_enavg)) GHTCNT6_enavg = 0.0 - if(associated(WESNN1_enavg)) WESNN1_enavg = 0.0 - if(associated(WESNN2_enavg)) WESNN2_enavg = 0.0 - if(associated(WESNN3_enavg)) WESNN3_enavg = 0.0 - if(associated(HTSNNN1_enavg)) HTSNNN1_enavg = 0.0 - if(associated(HTSNNN2_enavg)) HTSNNN2_enavg = 0.0 - if(associated(HTSNNN3_enavg)) HTSNNN3_enavg = 0.0 - if(associated(SNDZN1_enavg)) SNDZN1_enavg = 0.0 - if(associated(SNDZN2_enavg)) SNDZN2_enavg = 0.0 - if(associated(SNDZN3_enavg)) SNDZN3_enavg = 0.0 - if(associated(EVAPOUT_enavg)) EVAPOUT_enavg = 0.0 - if(associated(SUBLIM_enavg)) SUBLIM_enavg = 0.0 - if(associated(SHOUT_enavg)) SHOUT_enavg = 0.0 - if(associated(RUNOFF_enavg)) RUNOFF_enavg = 0.0 - if(associated(EVPINT_enavg)) EVPINT_enavg = 0.0 - if(associated(EVPSOI_enavg)) EVPSOI_enavg = 0.0 - if(associated(EVPVEG_enavg)) EVPVEG_enavg = 0.0 - if(associated(EVPICE_enavg)) EVPICE_enavg = 0.0 - if(associated(WAT10CM_enavg)) WAT10CM_enavg = 0.0 - if(associated(WATSOI_enavg)) WATSOI_enavg = 0.0 - if(associated(ICESOI_enavg)) ICESOI_enavg = 0.0 - if(associated(EVPSNO_enavg)) EVPSNO_enavg = 0.0 - if(associated(BASEFLOW_enavg)) BASEFLOW_enavg = 0.0 - if(associated(RUNSURF_enavg)) RUNSURF_enavg = 0.0 - if(associated(SMELT_enavg)) SMELT_enavg = 0.0 - if(associated(HLWUP_enavg)) HLWUP_enavg = 0.0 - if(associated(LWNDSRF_enavg)) LWNDSRF_enavg = 0.0 - if(associated(SWNDSRF_enavg)) SWNDSRF_enavg = 0.0 - if(associated(HLATN_enavg)) HLATN_enavg = 0.0 - if(associated(QINFIL_enavg)) QINFIL_enavg = 0.0 - if(associated(GHFLX_enavg)) GHFLX_enavg = 0.0 - if(associated(TPSURF_enavg)) TPSURF_enavg = 0.0 - if(associated(TPSURF_enstd)) TPSURF_enstd = 0.0 - if(associated(TPSNOW_enavg)) TPSNOW_enavg = 0.0 - if(associated(TPUNST_enavg)) TPUNST_enavg = 0.0 - if(associated(TPSAT_enavg)) TPSAT_enavg = 0.0 - if(associated(TPWLT_enavg)) TPWLT_enavg = 0.0 - if(associated(ASNOW_enavg)) ASNOW_enavg = 0.0 - if(associated(SHSNOW_enavg)) SHSNOW_enavg = 0.0 - if(associated(AVETSNOW_enavg)) AVETSNOW_enavg = 0.0 - if(associated(FRSAT_enavg)) FRSAT_enavg = 0.0 - if(associated(FRUST_enavg)) FRUST_enavg = 0.0 - if(associated(FRWLT_enavg)) FRWLT_enavg = 0.0 - if(associated(SNOWMASS_enavg)) SNOWMASS_enavg = 0.0 - if(associated(SNOWDP_enavg)) SNOWDP_enavg = 0.0 - if(associated(WET1_enavg)) WET1_enavg = 0.0 - if(associated(WET2_enavg)) WET2_enavg = 0.0 - if(associated(WET3_enavg)) WET3_enavg = 0.0 - if(associated(WCSF_enavg)) WCSF_enavg = 0.0 - if(associated(WCSF_enstd)) WCSF_enstd = 0.0 - if(associated(WCRZ_enavg)) WCRZ_enavg = 0.0 - if(associated(WCRZ_enstd)) WCRZ_enstd = 0.0 - if(associated(WCPR_enavg)) WCPR_enavg = 0.0 - if(associated(WCPR_enstd)) WCPR_enstd = 0.0 - if(associated(TP1_enavg)) TP1_enavg = 0.0 - if(associated(TP1_enstd)) TP1_enstd = 0.0 - if(associated(TP2_enavg)) TP2_enavg = 0.0 - if(associated(TP3_enavg)) TP3_enavg = 0.0 - if(associated(TP4_enavg)) TP4_enavg = 0.0 - if(associated(TP5_enavg)) TP5_enavg = 0.0 - if(associated(TP6_enavg)) TP6_enavg = 0.0 - if(associated(EMIS_enavg)) EMIS_enavg = 0.0 - if(associated(ALBVR_enavg)) ALBVR_enavg = 0.0 - if(associated(ALBVF_enavg)) ALBVF_enavg = 0.0 - if(associated(ALBNR_enavg)) ALBNR_enavg = 0.0 - if(associated(ALBNF_enavg)) ALBNF_enavg = 0.0 - if(associated(DELTS_enavg)) DELTS_enavg = 0.0 - if(associated(DELQS_enavg)) DELQS_enavg = 0.0 - if(associated(TST_enavg)) TST_enavg = 0.0 - if(associated(LST_enavg)) LST_enavg = 0.0 - if(associated(QST_enavg)) QST_enavg = 0.0 - if(associated(TH_enavg)) TH_enavg = 0.0 - if(associated(QH_enavg)) QH_enavg = 0.0 - if(associated(CHT_enavg)) CHT_enavg = 0.0 - if(associated(CMT_enavg)) CMT_enavg = 0.0 - if(associated(CQT_enavg)) CQT_enavg = 0.0 - if(associated(CNT_enavg)) CNT_enavg = 0.0 - if(associated(RIT_enavg)) RIT_enavg = 0.0 - if(associated(Z0_enavg)) Z0_enavg = 0.0 - if(associated(MOT2M_enavg)) MOT2M_enavg = 0.0 - if(associated(MOQ2M_enavg)) MOQ2M_enavg = 0.0 - if(associated(MOU2M_enavg)) MOU2M_enavg = 0.0 - if(associated(MOV2M_enavg)) MOV2M_enavg = 0.0 - if(associated(MOT10M_enavg)) MOT10M_enavg = 0.0 - if(associated(MOQ10M_enavg)) MOQ10M_enavg = 0.0 - if(associated(MOU10M_enavg)) MOU10M_enavg = 0.0 - if(associated(MOV10M_enavg)) MOV10M_enavg = 0.0 - if(associated(MOU50M_enavg)) MOU50M_enavg = 0.0 - if(associated(MOV50M_enavg)) MOV50M_enavg = 0.0 - if(associated(Z0H_enavg)) Z0H_enavg = 0.0 - if(associated(D0_enavg)) D0_enavg = 0.0 - if(associated(GUST_enavg)) GUST_enavg = 0.0 - if(associated(VENT_enavg)) VENT_enavg = 0.0 - if(associated(ACCUM_enavg)) ACCUM_enavg = 0.0 - if(associated(EVLAND_enavg)) EVLAND_enavg = 0.0 - if(associated(PRLAND_enavg)) PRLAND_enavg = 0.0 - if(associated(SNOLAND_enavg)) SNOLAND_enavg = 0.0 - if(associated(DRPARLAND_enavg)) DRPARLAND_enavg = 0.0 - if(associated(DFPARLAND_enavg)) DFPARLAND_enavg = 0.0 - if(associated(LHSNOW_enavg)) LHSNOW_enavg = 0.0 - if(associated(SWNETSNOW_enavg)) SWNETSNOW_enavg = 0.0 - if(associated(LWUPSNOW_enavg)) LWUPSNOW_enavg = 0.0 - if(associated(LWDNSNOW_enavg)) LWDNSNOW_enavg = 0.0 - if(associated(TCSORIG_enavg)) TCSORIG_enavg = 0.0 - if(associated(TPSN1IN_enavg)) TPSN1IN_enavg = 0.0 - if(associated(TPSN1OUT_enavg)) TPSN1OUT_enavg = 0.0 - if(associated(GHSNOW_enavg)) GHSNOW_enavg = 0.0 - if(associated(LHLAND_enavg)) LHLAND_enavg = 0.0 - if(associated(SHLAND_enavg)) SHLAND_enavg = 0.0 - if(associated(SWLAND_enavg)) SWLAND_enavg = 0.0 - if(associated(SWDOWNLAND_enavg)) SWDOWNLAND_enavg = 0.0 - if(associated(LWLAND_enavg)) LWLAND_enavg = 0.0 - if(associated(GHLAND_enavg)) GHLAND_enavg = 0.0 - if(associated(GHTSKIN_enavg)) GHTSKIN_enavg = 0.0 - if(associated(SMLAND_enavg)) SMLAND_enavg = 0.0 - if(associated(TWLAND_enavg)) TWLAND_enavg = 0.0 - if(associated(TELAND_enavg)) TELAND_enavg = 0.0 - if(associated(TSLAND_enavg)) TSLAND_enavg = 0.0 - if(associated(DWLAND_enavg)) DWLAND_enavg = 0.0 - if(associated(DHLAND_enavg)) DHLAND_enavg = 0.0 - if(associated(SPLAND_enavg)) SPLAND_enavg = 0.0 - if(associated(SPWATR_enavg)) SPWATR_enavg = 0.0 - if(associated(SPSNOW_enavg)) SPSNOW_enavg = 0.0 - if(associated(PEATCLSM_WATERLEVEL_enavg)) PEATCLSM_WATERLEVEL_enavg = 0.0 - if(associated(PEATCLSM_FSWCHANGE_enavg)) PEATCLSM_FSWCHANGE_enavg = 0.0 - - if(associated( CNLAI_enavg)) CNLAI_enavg = 0.0 - if(associated( CNTLAI_enavg)) CNTLAI_enavg = 0.0 - if(associated( CNSAI_enavg)) CNSAI_enavg = 0.0 - if(associated( CNTOTC_enavg)) CNTOTC_enavg = 0.0 - if(associated( CNVEGC_enavg)) CNVEGC_enavg = 0.0 - if(associated( CNROOT_enavg)) CNROOT_enavg = 0.0 - if(associated( CNFROOTC_enavg)) CNFROOTC_enavg = 0.0 - if(associated( CNNPP_enavg)) CNNPP_enavg = 0.0 - if(associated( CNGPP_enavg)) CNGPP_enavg = 0.0 - if(associated( CNSR_enavg)) CNSR_enavg = 0.0 - if(associated( CNNEE_enavg)) CNNEE_enavg = 0.0 - if(associated( CNXSMR_enavg)) CNXSMR_enavg = 0.0 - if(associated( CNADD_enavg)) CNADD_enavg = 0.0 - if(associated( PARABS_enavg)) PARABS_enavg = 0.0 - if(associated( PARINC_enavg)) PARINC_enavg = 0.0 - if(associated( SCSAT_enavg)) SCSAT_enavg = 0.0 - if(associated( SCUNS_enavg)) SCUNS_enavg = 0.0 - if(associated( BTRANT_enavg)) BTRANT_enavg = 0.0 - if(associated( SIF_enavg)) SIF_enavg = 0.0 - if(associated( CNLOSS_enavg)) CNLOSS_enavg = 0.0 - if(associated( CNBURN_enavg)) CNBURN_enavg = 0.0 - if(associated( CNFSEL_enavg)) CNFSEL_enavg = 0.0 - endif - - if(associated(TC_enavg) .and. associated(TC)) & - TC_enavg = TC_enavg + TC - if(associated(QC_enavg) .and. associated(QC)) & - QC_enavg = QC_enavg + QC - if(associated(CAPAC_enavg) .and. associated(CAPAC)) & - CAPAC_enavg = CAPAC_enavg + CAPAC - if(associated(CATDEF_enavg) .and. associated(CATDEF)) & - CATDEF_enavg = CATDEF_enavg + CATDEF - if(associated(RZEXC_enavg) .and. associated(RZEXC)) & - RZEXC_enavg = RZEXC_enavg + RZEXC - if(associated(SRFEXC_enavg) .and. associated(SRFEXC)) & - SRFEXC_enavg = SRFEXC_enavg + SRFEXC - if(associated(GHTCNT1_enavg) .and. associated(GHTCNT1)) & - GHTCNT1_enavg = GHTCNT1_enavg + GHTCNT1 - if(associated(GHTCNT2_enavg) .and. associated(GHTCNT2)) & - GHTCNT2_enavg = GHTCNT2_enavg + GHTCNT2 - if(associated(GHTCNT3_enavg) .and. associated(GHTCNT3)) & - GHTCNT3_enavg = GHTCNT3_enavg + GHTCNT3 - if(associated(GHTCNT4_enavg) .and. associated(GHTCNT4)) & - GHTCNT4_enavg = GHTCNT4_enavg + GHTCNT4 - if(associated(GHTCNT5_enavg) .and. associated(GHTCNT5)) & - GHTCNT5_enavg = GHTCNT5_enavg + GHTCNT5 - if(associated(GHTCNT6_enavg) .and. associated(GHTCNT6)) & - GHTCNT6_enavg = GHTCNT6_enavg + GHTCNT6 - if(associated(WESNN1_enavg) .and. associated(WESNN1)) & - WESNN1_enavg = WESNN1_enavg + WESNN1 - if(associated(WESNN2_enavg) .and. associated(WESNN2)) & - WESNN2_enavg = WESNN2_enavg + WESNN2 - if(associated(WESNN3_enavg) .and. associated(WESNN3)) & - WESNN3_enavg = WESNN3_enavg + WESNN3 - if(associated(HTSNNN1_enavg) .and. associated(HTSNNN1)) & - HTSNNN1_enavg = HTSNNN1_enavg + HTSNNN1 - if(associated(HTSNNN2_enavg) .and. associated(HTSNNN2)) & - HTSNNN2_enavg = HTSNNN2_enavg + HTSNNN2 - if(associated(HTSNNN3_enavg) .and. associated(HTSNNN3)) & - HTSNNN3_enavg = HTSNNN3_enavg + HTSNNN3 - if(associated(SNDZN1_enavg) .and. associated(SNDZN1)) & - SNDZN1_enavg = SNDZN1_enavg + SNDZN1 - if(associated(SNDZN2_enavg) .and. associated(SNDZN2)) & - SNDZN2_enavg = SNDZN2_enavg + SNDZN2 - if(associated(SNDZN3_enavg) .and. associated(SNDZN3)) & - SNDZN3_enavg = SNDZN3_enavg + SNDZN3 - if(associated(EVAPOUT_enavg) .and. associated(EVAPOUT)) & - EVAPOUT_enavg = EVAPOUT_enavg + EVAPOUT - if(associated(SUBLIM_enavg) .and. associated(SUBLIM)) & - SUBLIM_enavg = SUBLIM_enavg + SUBLIM - if(associated(SHOUT_enavg) .and. associated(SHOUT)) & - SHOUT_enavg = SHOUT_enavg + SHOUT - if(associated(RUNOFF_enavg) .and. associated(RUNOFF)) & - RUNOFF_enavg = RUNOFF_enavg + RUNOFF - if(associated(EVPINT_enavg) .and. associated(EVPINT)) & - EVPINT_enavg = EVPINT_enavg + EVPINT - if(associated(EVPSOI_enavg) .and. associated(EVPSOI)) & - EVPSOI_enavg = EVPSOI_enavg + EVPSOI - if(associated(EVPVEG_enavg) .and. associated(EVPVEG)) & - EVPVEG_enavg = EVPVEG_enavg + EVPVEG - if(associated(EVPICE_enavg) .and. associated(EVPICE)) & - EVPICE_enavg = EVPICE_enavg + EVPICE - if(associated(WAT10CM_enavg) .and. associated(WAT10CM)) & - WAT10CM_enavg = WAT10CM_enavg + WAT10CM - if(associated(WATSOI_enavg) .and. associated(WATSOI)) & - WATSOI_enavg = WATSOI_enavg + WATSOI - if(associated(ICESOI_enavg) .and. associated(ICESOI)) & - ICESOI_enavg = ICESOI_enavg + ICESOI - if(associated(EVPSNO_enavg) .and. associated(EVPSNO)) & - EVPSNO_enavg = EVPSNO_enavg + EVPSNO - if(associated(BASEFLOW_enavg) .and. associated(BASEFLOW)) & - BASEFLOW_enavg = BASEFLOW_enavg + BASEFLOW - if(associated(RUNSURF_enavg) .and. associated(RUNSURF)) & - RUNSURF_enavg = RUNSURF_enavg + RUNSURF - if(associated(SMELT_enavg) .and. associated(SMELT)) & - SMELT_enavg = SMELT_enavg + SMELT - if(associated(HLWUP_enavg) .and. associated(HLWUP)) & - HLWUP_enavg = HLWUP_enavg + HLWUP - if(associated(LWNDSRF_enavg) .and. associated(LWNDSRF)) & - LWNDSRF_enavg = LWNDSRF_enavg + LWNDSRF - if(associated(SWNDSRF_enavg) .and. associated(SWNDSRF)) & - SWNDSRF_enavg = SWNDSRF_enavg + SWNDSRF - if(associated(HLATN_enavg) .and. associated(HLATN)) & - HLATN_enavg = HLATN_enavg + HLATN - if(associated(QINFIL_enavg) .and. associated(QINFIL)) & - QINFIL_enavg = QINFIL_enavg + QINFIL - if(associated(GHFLX_enavg) .and. associated(GHFLX)) & - GHFLX_enavg = GHFLX_enavg + GHFLX - if(associated(TPSURF_enavg) .and. associated(TPSURF)) & - TPSURF_enavg = TPSURF_enavg + TPSURF - if(associated(TPSURF_enstd) .and. associated(TPSURF)) & - TPSURF_enstd = TPSURF_enstd + TPSURF*TPSURF - if(associated(TPSNOW_enavg) .and. associated(TPSNOW)) & - TPSNOW_enavg = TPSNOW_enavg + TPSNOW - if(associated(TPUNST_enavg) .and. associated(TPUNST)) & - TPUNST_enavg = TPUNST_enavg + TPUNST - if(associated(TPSAT_enavg) .and. associated(TPSAT)) & - TPSAT_enavg = TPSAT_enavg + TPSAT - if(associated(TPWLT_enavg) .and. associated(TPWLT)) & - TPWLT_enavg = TPWLT_enavg + TPWLT - !if(associated(ASNOW_enavg) .and. associated(ASNOW)) & - ! ASNOW_enavg = ASNOW_enavg + ASNOW - if(associated(SHSNOW_enavg) .and. associated(SHSNOW)) & - SHSNOW_enavg = SHSNOW_enavg + SHSNOW - if(associated(AVETSNOW_enavg) .and. associated(AVETSNOW)) & - AVETSNOW_enavg = AVETSNOW_enavg + AVETSNOW - if(associated(FRSAT_enavg) .and. associated(FRSAT)) & - FRSAT_enavg = FRSAT_enavg + FRSAT - if(associated(FRUST_enavg) .and. associated(FRUST)) & - FRUST_enavg = FRUST_enavg + FRUST - if(associated(FRWLT_enavg) .and. associated(FRWLT)) & - FRWLT_enavg = FRWLT_enavg + FRWLT - if(associated(SNOWMASS_enavg) .and. associated(SNOWMASS)) & - SNOWMASS_enavg = SNOWMASS_enavg + SNOWMASS - if(associated(SNOWDP_enavg) .and. associated(SNOWDP)) & - SNOWDP_enavg = SNOWDP_enavg + SNOWDP - if(associated(WET1_enavg) .and. associated(WET1)) & - WET1_enavg = WET1_enavg + WET1 - if(associated(WET2_enavg) .and. associated(WET2)) & - WET2_enavg = WET2_enavg + WET2 - if(associated(WET3_enavg) .and. associated(WET3)) & - WET3_enavg = WET3_enavg + WET3 - if(associated(WCSF_enavg) .and. associated(WCSF)) & - WCSF_enavg = WCSF_enavg + WCSF - if(associated(WCSF_enstd) .and. associated(WCSF)) & - WCSF_enstd = WCSF_enstd + WCSF*WCSF - if(associated(WCRZ_enavg) .and. associated(WCRZ)) & - WCRZ_enavg = WCRZ_enavg + WCRZ - if(associated(WCRZ_enstd) .and. associated(WCRZ)) & - WCRZ_enstd = WCRZ_enstd + WCRZ*WCRZ - if(associated(WCPR_enavg) .and. associated(WCPR)) & - WCPR_enavg = WCPR_enavg + WCPR - if(associated(WCPR_enstd) .and. associated(WCPR)) & - WCPR_enstd = WCPR_enstd + WCPR*WCPR - if(associated(TP1_enavg) .and. associated(TP1)) & - TP1_enavg = TP1_enavg + TP1 - if(associated(TP1_enstd) .and. associated(TP1)) & - TP1_enstd = TP1_enstd + TP1*TP1 - if(associated(TP2_enavg) .and. associated(TP2)) & - TP2_enavg = TP2_enavg + TP2 - if(associated(TP3_enavg) .and. associated(TP3)) & - TP3_enavg = TP3_enavg + TP3 - if(associated(TP4_enavg) .and. associated(TP4)) & - TP4_enavg = TP4_enavg + TP4 - if(associated(TP5_enavg) .and. associated(TP5)) & - TP5_enavg = TP5_enavg + TP5 - if(associated(TP6_enavg) .and. associated(TP6)) & - TP6_enavg = TP6_enavg + TP6 - if(associated(EMIS_enavg) .and. associated(EMIS)) & - EMIS_enavg = EMIS_enavg + EMIS - if(associated(ALBVR_enavg) .and. associated(ALBVR)) & - ALBVR_enavg = ALBVR_enavg + ALBVR - if(associated(ALBVF_enavg) .and. associated(ALBVF)) & - ALBVF_enavg = ALBVF_enavg + ALBVF - if(associated(ALBNR_enavg) .and. associated(ALBNR)) & - ALBNR_enavg = ALBNR_enavg + ALBNR - if(associated(ALBNF_enavg) .and. associated(ALBNF)) & - ALBNF_enavg = ALBNF_enavg + ALBNF - if(associated(DELTS_enavg) .and. associated(DELTS)) & - DELTS_enavg = DELTS_enavg + DELTS - if(associated(DELQS_enavg) .and. associated(DELQS)) & - DELQS_enavg = DELQS_enavg + DELQS - if(associated(TST_enavg) .and. associated(TST)) & - TST_enavg = TST_enavg + TST - if(associated(LST_enavg) .and. associated(LST)) & - LST_enavg = LST_enavg + LST - if(associated(QST_enavg) .and. associated(QST)) & - QST_enavg = QST_enavg + QST - if(associated(TH_enavg) .and. associated(TH)) & - TH_enavg = TH_enavg + TH - if(associated(QH_enavg) .and. associated(QH)) & - QH_enavg = QH_enavg + QH - if(associated(CHT_enavg) .and. associated(CHT)) & - CHT_enavg = CHT_enavg + CHT - if(associated(CMT_enavg) .and. associated(CMT)) & - CMT_enavg = CMT_enavg + CMT - if(associated(CQT_enavg) .and. associated(CQT)) & - CQT_enavg = CQT_enavg + CQT - if(associated(CNT_enavg) .and. associated(CNT)) & - CNT_enavg = CNT_enavg + CNT - if(associated(RIT_enavg) .and. associated(RIT)) & - RIT_enavg = RIT_enavg + RIT - if(associated(Z0_enavg) .and. associated(Z0)) & - Z0_enavg = Z0_enavg + Z0 - if(associated(MOT2M_enavg) .and. associated(MOT2M)) & - MOT2M_enavg = MOT2M_enavg + MOT2M - if(associated(MOQ2M_enavg) .and. associated(MOQ2M)) & - MOQ2M_enavg = MOQ2M_enavg + MOQ2M - if(associated(MOU2M_enavg) .and. associated(MOU2M)) & - MOU2M_enavg = MOU2M_enavg + MOU2M - if(associated(MOV2M_enavg) .and. associated(MOV2M)) & - MOV2M_enavg = MOV2M_enavg + MOV2M - if(associated(MOT10M_enavg) .and. associated(MOT10M)) & - MOT10M_enavg = MOT10M_enavg + MOT10M - if(associated(MOQ10M_enavg) .and. associated(MOQ10M)) & - MOQ10M_enavg = MOQ10M_enavg + MOQ10M - if(associated(MOU10M_enavg) .and. associated(MOU10M)) & - MOU10M_enavg = MOU10M_enavg + MOU10M - if(associated(MOV10M_enavg) .and. associated(MOV10M)) & - MOV10M_enavg = MOV10M_enavg + MOV10M - if(associated(MOU50M_enavg) .and. associated(MOU50M)) & - MOU50M_enavg = MOU50M_enavg + MOU50M - if(associated(MOV50M_enavg) .and. associated(MOV50M)) & - MOV50M_enavg = MOV50M_enavg + MOV50M - if(associated(Z0H_enavg) .and. associated(Z0H)) & - Z0H_enavg = Z0H_enavg + Z0H - if(associated(D0_enavg) .and. associated(D0)) & - D0_enavg = D0_enavg + D0 - if(associated(GUST_enavg) .and. associated(GUST)) & - GUST_enavg = GUST_enavg + GUST - if(associated(VENT_enavg) .and. associated(VENT)) & - VENT_enavg = VENT_enavg + VENT - if(associated(ACCUM_enavg) .and. associated(ACCUM)) & - ACCUM_enavg = ACCUM_enavg + ACCUM - if(associated(EVLAND_enavg) .and. associated(EVLAND)) & - EVLAND_enavg = EVLAND_enavg + EVLAND - if(associated(PRLAND_enavg) .and. associated(PRLAND)) & - PRLAND_enavg = PRLAND_enavg + PRLAND - if(associated(SNOLAND_enavg) .and. associated(SNOLAND)) & - SNOLAND_enavg = SNOLAND_enavg + SNOLAND - if(associated(DRPARLAND_enavg) .and. associated(DRPARLAND)) & - DRPARLAND_enavg = DRPARLAND_enavg + DRPARLAND - if(associated(DFPARLAND_enavg) .and. associated(DFPARLAND)) & - DFPARLAND_enavg = DFPARLAND_enavg + DFPARLAND - if(associated(LHSNOW_enavg) .and. associated(LHSNOW)) & - LHSNOW_enavg = LHSNOW_enavg + LHSNOW - if(associated(SWNETSNOW_enavg) .and. associated(SWNETSNOW)) & - SWNETSNOW_enavg = SWNETSNOW_enavg + SWNETSNOW - if(associated(LWUPSNOW_enavg) .and. associated(LWUPSNOW)) & - LWUPSNOW_enavg = LWUPSNOW_enavg + LWUPSNOW - if(associated(LWDNSNOW_enavg) .and. associated(LWDNSNOW)) & - LWDNSNOW_enavg = LWDNSNOW_enavg + LWDNSNOW - if(associated(TCSORIG_enavg) .and. associated(TCSORIG)) & - TCSORIG_enavg = TCSORIG_enavg + TCSORIG - if(associated(TPSN1IN_enavg) .and. associated(TPSN1IN)) & - TPSN1IN_enavg = TPSN1IN_enavg + TPSN1IN - if(associated(TPSN1OUT_enavg) .and. associated(TPSN1OUT)) & - TPSN1OUT_enavg = TPSN1OUT_enavg + TPSN1OUT - if(associated(GHSNOW_enavg) .and. associated(GHSNOW)) & - GHSNOW_enavg = GHSNOW_enavg + GHSNOW - if(associated(LHLAND_enavg) .and. associated(LHLAND)) & - LHLAND_enavg = LHLAND_enavg + LHLAND - if(associated(SHLAND_enavg) .and. associated(SHLAND)) & - SHLAND_enavg = SHLAND_enavg + SHLAND - if(associated(SWLAND_enavg) .and. associated(SWLAND)) & - SWLAND_enavg = SWLAND_enavg + SWLAND - if(associated(SWDOWNLAND_enavg) .and. associated(SWDOWNLAND)) & - SWDOWNLAND_enavg = SWDOWNLAND_enavg + SWDOWNLAND - if(associated(LWLAND_enavg) .and. associated(LWLAND)) & - LWLAND_enavg = LWLAND_enavg + LWLAND - if(associated(GHLAND_enavg) .and. associated(GHLAND)) & - GHLAND_enavg = GHLAND_enavg + GHLAND - if(associated(GHTSKIN_enavg) .and. associated(GHTSKIN)) & - GHTSKIN_enavg = GHTSKIN_enavg + GHTSKIN - if(associated(SMLAND_enavg) .and. associated(SMLAND)) & - SMLAND_enavg = SMLAND_enavg + SMLAND - if(associated(TWLAND_enavg) .and. associated(TWLAND)) & - TWLAND_enavg = TWLAND_enavg + TWLAND - if(associated(TELAND_enavg) .and. associated(TELAND)) & - TELAND_enavg = TELAND_enavg + TELAND - if(associated(TSLAND_enavg) .and. associated(TSLAND)) & - TSLAND_enavg = TSLAND_enavg + TSLAND - if(associated(DWLAND_enavg) .and. associated(DWLAND)) & - DWLAND_enavg = DWLAND_enavg + DWLAND - if(associated(DHLAND_enavg) .and. associated(DHLAND)) & - DHLAND_enavg = DHLAND_enavg + DHLAND - if(associated(SPLAND_enavg) .and. associated(SPLAND)) & - SPLAND_enavg = SPLAND_enavg + SPLAND - if(associated(SPWATR_enavg) .and. associated(SPWATR)) & - SPWATR_enavg = SPWATR_enavg + SPWATR - if(associated(SPSNOW_enavg) .and. associated(SPSNOW)) & - SPSNOW_enavg = SPSNOW_enavg + SPSNOW - if(associated(PEATCLSM_WATERLEVEL_enavg) .and. associated(PEATCLSM_WATERLEVEL)) & - PEATCLSM_WATERLEVEL_enavg = PEATCLSM_WATERLEVEL_enavg + PEATCLSM_WATERLEVEL - if(associated(PEATCLSM_FSWCHANGE_enavg) .and. associated(PEATCLSM_FSWCHANGE)) & - PEATCLSM_FSWCHANGE_enavg = PEATCLSM_FSWCHANGE_enavg + PEATCLSM_FSWCHANGE - - if(associated( CNLAI_enavg) .and. associated( CNLAI)) CNLAI_enavg = CNLAI_enavg + CNLAI - if(associated( CNTLAI_enavg) .and. associated(CNTLAI)) CNTLAI_enavg = CNTLAI_enavg + CNTLAI - if(associated( CNSAI_enavg) .and. associated( CNSAI)) CNSAI_enavg = CNSAI_enavg + CNSAI - if(associated( CNTOTC_enavg) .and. associated(CNTOTC)) CNTOTC_enavg = CNTOTC_enavg + CNTOTC - if(associated( CNVEGC_enavg) .and. associated(CNVEGC)) CNVEGC_enavg = CNVEGC_enavg + CNVEGC - if(associated( CNROOT_enavg) .and. associated(CNROOT)) CNROOT_enavg = CNROOT_enavg + CNROOT - if(associated( CNFROOTC_enavg) .and. associated(CNFROOTC)) CNFROOTC_enavg = CNFROOTC_enavg + CNFROOTC - if(associated( CNNPP_enavg) .and. associated( CNNPP)) CNNPP_enavg = CNNPP_enavg + CNNPP - if(associated( CNGPP_enavg) .and. associated( CNGPP)) CNGPP_enavg = CNGPP_enavg + CNGPP - if(associated( CNSR_enavg) .and. associated( CNSR)) CNSR_enavg = CNSR_enavg + CNSR - if(associated( CNNEE_enavg) .and. associated( CNNEE)) CNNEE_enavg = CNNEE_enavg + CNNEE - if(associated( CNXSMR_enavg).and. associated( CNXSMR))CNXSMR_enavg = CNXSMR_enavg+ CNXSMR - if(associated( CNADD_enavg) .and. associated( CNADD)) CNADD_enavg = CNADD_enavg + CNADD - if(associated( PARABS_enavg) .and. associated(PARABS)) PARABS_enavg = PARABS_enavg + PARABS - if(associated( PARINC_enavg) .and. associated(PARINC)) PARINC_enavg = PARINC_enavg + PARINC - if(associated( SCSAT_enavg) .and. associated( SCSAT)) SCSAT_enavg = SCSAT_enavg + SCSAT - if(associated( SCUNS_enavg) .and. associated( SCUNS)) SCUNS_enavg = SCUNS_enavg + SCUNS - if(associated( BTRANT_enavg) .and. associated(BTRANT)) BTRANT_enavg = BTRANT_enavg + BTRANT - if(associated( SIF_enavg) .and. associated( SIF)) SIF_enavg = SIF_enavg + SIF - if(associated( CNLOSS_enavg) .and. associated(CNLOSS)) CNLOSS_enavg = CNLOSS_enavg + CNLOSS - if(associated( CNBURN_enavg) .and. associated(CNBURN)) CNBURN_enavg = CNBURN_enavg + CNBURN - if(associated( CNFSEL_enavg) .and. associated(CNFSEL)) CNFSEL_enavg = CNFSEL_enavg + CNFSEL - - ! This counter is relative to ens_id - collect_land_counter = collect_land_counter + 1 - !collect catch_progn - - catch_progn(:,collect_land_counter)%tc1 = TC(:,1) - catch_progn(:,collect_land_counter)%tc2 = TC(:,2) - catch_progn(:,collect_land_counter)%tc4 = TC(:,3) - - catch_progn(:,collect_land_counter)%qa1 = QC(:,1) - catch_progn(:,collect_land_counter)%qa2 = QC(:,2) - catch_progn(:,collect_land_counter)%qa4 = QC(:,3) - - catch_progn(:,collect_land_counter)%capac = CAPAC(:) - catch_progn(:,collect_land_counter)%catdef = catdef(:) - catch_progn(:,collect_land_counter)%rzexc = rzexc(:) - catch_progn(:,collect_land_counter)%srfexc = srfexc(:) - - catch_progn(:,collect_land_counter)%ght(1) = GHTCNT1(:) - catch_progn(:,collect_land_counter)%ght(2) = GHTCNT2(:) - catch_progn(:,collect_land_counter)%ght(3) = GHTCNT3(:) - catch_progn(:,collect_land_counter)%ght(4) = GHTCNT4(:) - catch_progn(:,collect_land_counter)%ght(5) = GHTCNT5(:) - catch_progn(:,collect_land_counter)%ght(6) = GHTCNT6(:) - - catch_progn(:,collect_land_counter)%wesn(1) = WESNN1(:) - catch_progn(:,collect_land_counter)%wesn(2) = WESNN2(:) - catch_progn(:,collect_land_counter)%wesn(3) = WESNN3(:) - - catch_progn(:,collect_land_counter)%htsn(1) = HTSNNN1(:) - catch_progn(:,collect_land_counter)%htsn(2) = HTSNNN2(:) - catch_progn(:,collect_land_counter)%htsn(3) = HTSNNN3(:) - - catch_progn(:,collect_land_counter)%sndz(1) = SNDZN1(:) - catch_progn(:,collect_land_counter)%sndz(2) = SNDZN2(:) - catch_progn(:,collect_land_counter)%sndz(3) = SNDZN3(:) - - - if(collect_land_counter == NUM_ENSEMBLE) then - - Nm1 = real(NUM_ENSEMBLE-1) - if (NUM_ENSEMBLE>1) NdivNm1 = real(NUM_ENSEMBLE)/Nm1 - - collect_land_counter = 0 - if(associated(TC_enavg)) TC_enavg = TC_enavg/NUM_ENSEMBLE - if(associated(QC_enavg)) QC_enavg = QC_enavg/NUM_ENSEMBLE - if(associated(CAPAC_enavg)) CAPAC_enavg = CAPAC_enavg/NUM_ENSEMBLE - if(associated(CATDEF_enavg)) CATDEF_enavg = CATDEF_enavg/NUM_ENSEMBLE - if(associated(RZEXC_enavg)) RZEXC_enavg = RZEXC_enavg/NUM_ENSEMBLE - if(associated(SRFEXC_enavg)) SRFEXC_enavg = SRFEXC_enavg/NUM_ENSEMBLE - if(associated(GHTCNT1_enavg)) GHTCNT1_enavg = GHTCNT1_enavg/NUM_ENSEMBLE - if(associated(GHTCNT2_enavg)) GHTCNT2_enavg = GHTCNT2_enavg/NUM_ENSEMBLE - if(associated(GHTCNT3_enavg)) GHTCNT3_enavg = GHTCNT3_enavg/NUM_ENSEMBLE - if(associated(GHTCNT4_enavg)) GHTCNT4_enavg = GHTCNT4_enavg/NUM_ENSEMBLE - if(associated(GHTCNT5_enavg)) GHTCNT5_enavg = GHTCNT5_enavg/NUM_ENSEMBLE - if(associated(GHTCNT6_enavg)) GHTCNT6_enavg = GHTCNT6_enavg/NUM_ENSEMBLE - if(associated(WESNN1_enavg)) WESNN1_enavg = WESNN1_enavg/NUM_ENSEMBLE - if(associated(WESNN2_enavg)) WESNN2_enavg = WESNN2_enavg/NUM_ENSEMBLE - if(associated(WESNN3_enavg)) WESNN3_enavg = WESNN3_enavg/NUM_ENSEMBLE - if(associated(HTSNNN1_enavg)) HTSNNN1_enavg = HTSNNN1_enavg/NUM_ENSEMBLE - if(associated(HTSNNN2_enavg)) HTSNNN2_enavg = HTSNNN2_enavg/NUM_ENSEMBLE - if(associated(HTSNNN3_enavg)) HTSNNN3_enavg = HTSNNN3_enavg/NUM_ENSEMBLE - if(associated(SNDZN1_enavg)) SNDZN1_enavg = SNDZN1_enavg/NUM_ENSEMBLE - if(associated(SNDZN2_enavg)) SNDZN2_enavg = SNDZN2_enavg/NUM_ENSEMBLE - if(associated(SNDZN3_enavg)) SNDZN3_enavg = SNDZN3_enavg/NUM_ENSEMBLE - if(associated(EVAPOUT_enavg)) EVAPOUT_enavg = EVAPOUT_enavg/NUM_ENSEMBLE - if(associated(SUBLIM_enavg)) SUBLIM_enavg = SUBLIM_enavg/NUM_ENSEMBLE - if(associated(SHOUT_enavg)) SHOUT_enavg = SHOUT_enavg/NUM_ENSEMBLE - if(associated(RUNOFF_enavg)) RUNOFF_enavg = RUNOFF_enavg/NUM_ENSEMBLE - if(associated(EVPINT_enavg)) EVPINT_enavg = EVPINT_enavg/NUM_ENSEMBLE - if(associated(EVPSOI_enavg)) EVPSOI_enavg = EVPSOI_enavg/NUM_ENSEMBLE - if(associated(EVPVEG_enavg)) EVPVEG_enavg = EVPVEG_enavg/NUM_ENSEMBLE - if(associated(EVPICE_enavg)) EVPICE_enavg = EVPICE_enavg/NUM_ENSEMBLE - if(associated(WAT10CM_enavg)) WAT10CM_enavg = WAT10CM_enavg/NUM_ENSEMBLE - if(associated(WATSOI_enavg)) WATSOI_enavg = WATSOI_enavg/NUM_ENSEMBLE - if(associated(ICESOI_enavg)) ICESOI_enavg = ICESOI_enavg/NUM_ENSEMBLE - if(associated(EVPSNO_enavg)) EVPSNO_enavg = EVPSNO_enavg/NUM_ENSEMBLE - if(associated(BASEFLOW_enavg)) BASEFLOW_enavg = BASEFLOW_enavg/NUM_ENSEMBLE - if(associated(RUNSURF_enavg)) RUNSURF_enavg = RUNSURF_enavg/NUM_ENSEMBLE - if(associated(SMELT_enavg)) SMELT_enavg = SMELT_enavg/NUM_ENSEMBLE - if(associated(HLWUP_enavg)) HLWUP_enavg = HLWUP_enavg/NUM_ENSEMBLE - if(associated(LWNDSRF_enavg)) LWNDSRF_enavg = LWNDSRF_enavg/NUM_ENSEMBLE - if(associated(SWNDSRF_enavg)) SWNDSRF_enavg = SWNDSRF_enavg/NUM_ENSEMBLE - if(associated(HLATN_enavg)) HLATN_enavg = HLATN_enavg/NUM_ENSEMBLE - if(associated(QINFIL_enavg)) QINFIL_enavg = QINFIL_enavg/NUM_ENSEMBLE - !if(associated(AR1_enavg)) AR1_enavg = AR1_enavg/NUM_ENSEMBLE - !if(associated(AR2_enavg)) AR2_enavg = AR2_enavg/NUM_ENSEMBLE - !if(associated(RZEQ_enavg)) RZEQ_enavg = RZEQ_enavg/NUM_ENSEMBLE - if(associated(GHFLX_enavg)) GHFLX_enavg = GHFLX_enavg/NUM_ENSEMBLE - if(associated(TPSURF_enavg)) TPSURF_enavg = TPSURF_enavg/NUM_ENSEMBLE - if((NUM_ENSEMBLE>1) .and. associated(TPSURF_enstd) .and. associated(TPSURF_enavg)) then - TPSURF_enstd = max( sqrt( TPSURF_enstd/Nm1 - NdivNm1*(TPSURF_enavg**2) ), 0. ) - else if (associated(TPSURF_enstd)) then - TPSURF_enstd = MAPL_UNDEF - end if - if(associated(TPSNOW_enavg)) TPSNOW_enavg = TPSNOW_enavg/NUM_ENSEMBLE - if(associated(TPUNST_enavg)) TPUNST_enavg = TPUNST_enavg/NUM_ENSEMBLE - if(associated(TPSAT_enavg)) TPSAT_enavg = TPSAT_enavg/NUM_ENSEMBLE - if(associated(TPWLT_enavg)) TPWLT_enavg = TPWLT_enavg/NUM_ENSEMBLE - if(associated(SHSNOW_enavg)) SHSNOW_enavg = SHSNOW_enavg/NUM_ENSEMBLE - if(associated(AVETSNOW_enavg)) AVETSNOW_enavg = AVETSNOW_enavg/NUM_ENSEMBLE - if(associated(FRSAT_enavg)) FRSAT_enavg = FRSAT_enavg/NUM_ENSEMBLE - if(associated(FRUST_enavg)) FRUST_enavg = FRUST_enavg/NUM_ENSEMBLE - if(associated(FRWLT_enavg)) FRWLT_enavg = FRWLT_enavg/NUM_ENSEMBLE - if(associated(ASNOW_enavg)) ASNOW_enavg = max(min(1.0-(FRSAT_enavg+FRUST_enavg+FRWLT_enavg),1.0),0.0) - if(associated(SNOWMASS_enavg)) SNOWMASS_enavg = SNOWMASS_enavg/NUM_ENSEMBLE - if(associated(SNOWDP_enavg)) SNOWDP_enavg = SNOWDP_enavg/NUM_ENSEMBLE - if(associated(WET1_enavg)) WET1_enavg = WET1_enavg/NUM_ENSEMBLE - if(associated(WET2_enavg)) WET2_enavg = WET2_enavg/NUM_ENSEMBLE - if(associated(WET3_enavg)) WET3_enavg = WET3_enavg/NUM_ENSEMBLE - if(associated(WCSF_enavg)) WCSF_enavg = WCSF_enavg/NUM_ENSEMBLE - if((NUM_ENSEMBLE>1) .and. associated(WCSF_enstd) .and. associated(WCSF_enavg)) then - WCSF_enstd = max( sqrt( WCSF_enstd/Nm1 - NdivNm1*(WCSF_enavg**2) ), 0. ) - else if (associated(WCSF_enstd)) then - WCSF_enstd = MAPL_UNDEF - end if - if(associated(WCRZ_enavg)) WCRZ_enavg = WCRZ_enavg/NUM_ENSEMBLE - if((NUM_ENSEMBLE>1) .and. associated(WCRZ_enstd) .and. associated(WCRZ_enavg)) then - WCRZ_enstd = max( sqrt( WCRZ_enstd/Nm1 - NdivNm1*(WCRZ_enavg**2) ), 0. ) - else if (associated(WCRZ_enstd)) then - WCRZ_enstd = MAPL_UNDEF - end if - if(associated(WCPR_enavg)) WCPR_enavg = WCPR_enavg/NUM_ENSEMBLE - if((NUM_ENSEMBLE>1) .and. associated(WCPR_enstd) .and. associated(WCPR_enavg)) then - WCPR_enstd = max( sqrt( WCPR_enstd/Nm1 - NdivNm1*(WCPR_enavg**2) ), 0. ) - else if (associated(WCPR_enstd)) then - WCPR_enstd = MAPL_UNDEF - end if - if(associated(TP1_enavg)) TP1_enavg = TP1_enavg/NUM_ENSEMBLE ! units K - if((NUM_ENSEMBLE>1) .and. associated(TP1_enstd) .and. associated(TP1_enavg)) then - TP1_enstd = max( sqrt( TP1_enstd/Nm1 - NdivNm1*(TP1_enavg**2) ), 0. ) - else if (associated(TP1_enstd)) then - TP1_enstd = MAPL_UNDEF - end if - if(associated(TP2_enavg)) TP2_enavg = TP2_enavg/NUM_ENSEMBLE ! units now K, rreichle & borescan, 6 Nov 2020 - if(associated(TP3_enavg)) TP3_enavg = TP3_enavg/NUM_ENSEMBLE ! units now K, rreichle & borescan, 6 Nov 2020 - if(associated(TP4_enavg)) TP4_enavg = TP4_enavg/NUM_ENSEMBLE ! units now K, rreichle & borescan, 6 Nov 2020 - if(associated(TP5_enavg)) TP5_enavg = TP5_enavg/NUM_ENSEMBLE ! units now K, rreichle & borescan, 6 Nov 2020 - if(associated(TP6_enavg)) TP6_enavg = TP6_enavg/NUM_ENSEMBLE ! units now K, rreichle & borescan, 6 Nov 2020 - if(associated(EMIS_enavg)) EMIS_enavg = EMIS_enavg/NUM_ENSEMBLE - if(associated(ALBVR_enavg)) ALBVR_enavg = ALBVR_enavg/NUM_ENSEMBLE - if(associated(ALBVF_enavg)) ALBVF_enavg = ALBVF_enavg/NUM_ENSEMBLE - if(associated(ALBNR_enavg)) ALBNR_enavg = ALBNR_enavg/NUM_ENSEMBLE - if(associated(ALBNF_enavg)) ALBNF_enavg = ALBNF_enavg/NUM_ENSEMBLE - if(associated(DELTS_enavg)) DELTS_enavg = DELTS_enavg/NUM_ENSEMBLE - if(associated(DELQS_enavg)) DELQS_enavg = DELQS_enavg/NUM_ENSEMBLE - !if(associated(DELEVAP_enavg)) DELEVAP_enavg = DELEVAP_enavg/NUM_ENSEMBLE - !if(associated(DELSH_enavg)) DELSH_enavg = DELSH_enavg/NUM_ENSEMBLE - if(associated(TST_enavg)) TST_enavg = TST_enavg/NUM_ENSEMBLE - if(associated(LST_enavg)) LST_enavg = LST_enavg/NUM_ENSEMBLE - if(associated(QST_enavg)) QST_enavg = QST_enavg/NUM_ENSEMBLE - if(associated(TH_enavg)) TH_enavg = TH_enavg/NUM_ENSEMBLE - if(associated(QH_enavg)) QH_enavg = QH_enavg/NUM_ENSEMBLE - if(associated(CHT_enavg)) CHT_enavg = CHT_enavg/NUM_ENSEMBLE - if(associated(CMT_enavg)) CMT_enavg = CMT_enavg/NUM_ENSEMBLE - if(associated(CQT_enavg)) CQT_enavg = CQT_enavg/NUM_ENSEMBLE - if(associated(CNT_enavg)) CNT_enavg = CNT_enavg/NUM_ENSEMBLE - if(associated(RIT_enavg)) RIT_enavg = RIT_enavg/NUM_ENSEMBLE - if(associated(Z0_enavg)) Z0_enavg = Z0_enavg/NUM_ENSEMBLE - if(associated(MOT2M_enavg)) MOT2M_enavg = MOT2M_enavg/NUM_ENSEMBLE - if(associated(MOQ2M_enavg)) MOQ2M_enavg = MOQ2M_enavg/NUM_ENSEMBLE - if(associated(MOU2M_enavg)) MOU2M_enavg = MOU2M_enavg/NUM_ENSEMBLE - if(associated(MOV2M_enavg)) MOV2M_enavg = MOV2M_enavg/NUM_ENSEMBLE - if(associated(MOT10M_enavg)) MOT10M_enavg = MOT10M_enavg/NUM_ENSEMBLE - if(associated(MOQ10M_enavg)) MOQ10M_enavg = MOQ10M_enavg/NUM_ENSEMBLE - if(associated(MOU10M_enavg)) MOU10M_enavg = MOU10M_enavg/NUM_ENSEMBLE - if(associated(MOV10M_enavg)) MOV10M_enavg = MOV10M_enavg/NUM_ENSEMBLE - if(associated(MOU50M_enavg)) MOU50M_enavg = MOU50M_enavg/NUM_ENSEMBLE - if(associated(MOV50M_enavg)) MOV50M_enavg = MOV50M_enavg/NUM_ENSEMBLE - if(associated(Z0H_enavg)) Z0H_enavg = Z0H_enavg/NUM_ENSEMBLE - if(associated(D0_enavg)) D0_enavg = D0_enavg/NUM_ENSEMBLE - if(associated(GUST_enavg)) GUST_enavg = GUST_enavg/NUM_ENSEMBLE - if(associated(VENT_enavg)) VENT_enavg = VENT_enavg/NUM_ENSEMBLE - if(associated(ACCUM_enavg)) ACCUM_enavg = ACCUM_enavg/NUM_ENSEMBLE - if(associated(EVLAND_enavg)) EVLAND_enavg = EVLAND_enavg/NUM_ENSEMBLE - if(associated(PRLAND_enavg)) PRLAND_enavg = PRLAND_enavg/NUM_ENSEMBLE - if(associated(SNOLAND_enavg)) SNOLAND_enavg = SNOLAND_enavg/NUM_ENSEMBLE - if(associated(DRPARLAND_enavg)) DRPARLAND_enavg = DRPARLAND_enavg/NUM_ENSEMBLE - if(associated(DFPARLAND_enavg)) DFPARLAND_enavg = DFPARLAND_enavg/NUM_ENSEMBLE - if(associated(LHSNOW_enavg)) LHSNOW_enavg = LHSNOW_enavg/NUM_ENSEMBLE - if(associated(SWNETSNOW_enavg)) SWNETSNOW_enavg = SWNETSNOW_enavg/NUM_ENSEMBLE - if(associated(LWUPSNOW_enavg)) LWUPSNOW_enavg = LWUPSNOW_enavg/NUM_ENSEMBLE - if(associated(LWDNSNOW_enavg)) LWDNSNOW_enavg = LWDNSNOW_enavg/NUM_ENSEMBLE - if(associated(TCSORIG_enavg)) TCSORIG_enavg = TCSORIG_enavg/NUM_ENSEMBLE - if(associated(TPSN1IN_enavg)) TPSN1IN_enavg = TPSN1IN_enavg/NUM_ENSEMBLE - if(associated(TPSN1OUT_enavg)) TPSN1OUT_enavg = TPSN1OUT_enavg/NUM_ENSEMBLE - if(associated(GHSNOW_enavg)) GHSNOW_enavg = GHSNOW_enavg/NUM_ENSEMBLE - if(associated(LHLAND_enavg)) LHLAND_enavg = LHLAND_enavg/NUM_ENSEMBLE - if(associated(SHLAND_enavg)) SHLAND_enavg = SHLAND_enavg/NUM_ENSEMBLE - if(associated(SWLAND_enavg)) SWLAND_enavg = SWLAND_enavg/NUM_ENSEMBLE - if(associated(SWDOWNLAND_enavg)) SWDOWNLAND_enavg = SWDOWNLAND_enavg/NUM_ENSEMBLE - if(associated(LWLAND_enavg)) LWLAND_enavg = LWLAND_enavg/NUM_ENSEMBLE - if(associated(GHLAND_enavg)) GHLAND_enavg = GHLAND_enavg/NUM_ENSEMBLE - if(associated(GHTSKIN_enavg)) GHTSKIN_enavg = GHTSKIN_enavg/NUM_ENSEMBLE - if(associated(SMLAND_enavg)) SMLAND_enavg = SMLAND_enavg/NUM_ENSEMBLE - if(associated(TWLAND_enavg)) TWLAND_enavg = TWLAND_enavg/NUM_ENSEMBLE - if(associated(TELAND_enavg)) TELAND_enavg = TELAND_enavg/NUM_ENSEMBLE - if(associated(TSLAND_enavg)) TSLAND_enavg = TSLAND_enavg/NUM_ENSEMBLE - if(associated(DWLAND_enavg)) DWLAND_enavg = DWLAND_enavg/NUM_ENSEMBLE - if(associated(DHLAND_enavg)) DHLAND_enavg = DHLAND_enavg/NUM_ENSEMBLE - if(associated(SPLAND_enavg)) SPLAND_enavg = SPLAND_enavg/NUM_ENSEMBLE - if(associated(SPWATR_enavg)) SPWATR_enavg = SPWATR_enavg/NUM_ENSEMBLE - if(associated(SPSNOW_enavg)) SPSNOW_enavg = SPSNOW_enavg/NUM_ENSEMBLE - if(associated(PEATCLSM_WATERLEVEL_enavg)) PEATCLSM_WATERLEVEL_enavg = PEATCLSM_WATERLEVEL_enavg/NUM_ENSEMBLE - if(associated(PEATCLSM_FSWCHANGE_enavg)) PEATCLSM_FSWCHANGE_enavg = PEATCLSM_FSWCHANGE_enavg /NUM_ENSEMBLE - - if(associated( CNLAI_enavg)) CNLAI_enavg = CNLAI_enavg/NUM_ENSEMBLE - if(associated( CNTLAI_enavg)) CNTLAI_enavg = CNTLAI_enavg/NUM_ENSEMBLE - if(associated( CNSAI_enavg)) CNSAI_enavg = CNSAI_enavg/NUM_ENSEMBLE - if(associated( CNTOTC_enavg)) CNTOTC_enavg = CNTOTC_enavg/NUM_ENSEMBLE - if(associated( CNVEGC_enavg)) CNVEGC_enavg = CNVEGC_enavg/NUM_ENSEMBLE - if(associated( CNROOT_enavg)) CNROOT_enavg = CNROOT_enavg/NUM_ENSEMBLE - if(associated( CNFROOTC_enavg)) CNFROOTC_enavg = CNFROOTC_enavg/NUM_ENSEMBLE - if(associated( CNNPP_enavg)) CNNPP_enavg = CNNPP_enavg/NUM_ENSEMBLE - if(associated( CNGPP_enavg)) CNGPP_enavg = CNGPP_enavg/NUM_ENSEMBLE - if(associated( CNSR_enavg)) CNSR_enavg = CNSR_enavg/NUM_ENSEMBLE - if(associated( CNNEE_enavg)) CNNEE_enavg = CNNEE_enavg/NUM_ENSEMBLE - if(associated( CNXSMR_enavg)) CNXSMR_enavg = CNXSMR_enavg/NUM_ENSEMBLE - if(associated( CNADD_enavg)) CNADD_enavg = CNADD_enavg/NUM_ENSEMBLE - if(associated( PARABS_enavg)) PARABS_enavg = PARABS_enavg/NUM_ENSEMBLE - if(associated( PARINC_enavg)) PARINC_enavg = PARINC_enavg/NUM_ENSEMBLE - if(associated( SCSAT_enavg)) SCSAT_enavg = SCSAT_enavg/NUM_ENSEMBLE - if(associated( SCUNS_enavg)) SCUNS_enavg = SCUNS_enavg/NUM_ENSEMBLE - if(associated( BTRANT_enavg)) BTRANT_enavg = BTRANT_enavg/NUM_ENSEMBLE - if(associated( SIF_enavg)) SIF_enavg = SIF_enavg/NUM_ENSEMBLE - if(associated( CNLOSS_enavg)) CNLOSS_enavg = CNLOSS_enavg/NUM_ENSEMBLE - if(associated( CNBURN_enavg)) CNBURN_enavg = CNBURN_enavg/NUM_ENSEMBLE - if(associated( CNFSEL_enavg)) CNFSEL_enavg = CNFSEL_enavg/NUM_ENSEMBLE - - ! Deal with no-data-values - ! - ! Surface temperature components may be nodata in some but not all ensemble members. - ! (Nodata values are assigned in GEOS_CatchGridComp.F90 when the associated - ! area fraction is zero.) - ! - ! For now, the ensemble average is set to nodata if any member has a nodata value. - ! - ! Alternatively, only ensemble members with good values could be averaged, or the - ! averaging could use the associated area fraction as averaging weights. - ! - ! The simple detection implemented here relies on MAPL_UNDEF being many orders of - ! magnitude larger than any valid values, which works fine for Earth surface - ! temperatures as long as MAPL_UNDEF is 1.e15. - ! - ! - reichle, 29 May 2020 - - if(associated(TPSNOW_enavg)) where (TPSNOW_enavg > enavg_nodata_threshold) TPSNOW_enavg = MAPL_UNDEF - if(associated(TPSAT_enavg )) where (TPSAT_enavg > enavg_nodata_threshold) TPSAT_enavg = MAPL_UNDEF - if(associated(TPWLT_enavg )) where (TPWLT_enavg > enavg_nodata_threshold) TPWLT_enavg = MAPL_UNDEF - if(associated(TPUNST_enavg)) where (TPUNST_enavg > enavg_nodata_threshold) TPUNST_enavg = MAPL_UNDEF - - ! restore exact no-data-values for PEATCLSM diagnostics in mineral tiles - - if(associated(PEATCLSM_WATERLEVEL_enavg)) where (PEATCLSM_WATERLEVEL_enavg > enavg_nodata_threshold) PEATCLSM_WATERLEVEL_enavg = MAPL_UNDEF - if(associated(PEATCLSM_FSWCHANGE_enavg)) where (PEATCLSM_FSWCHANGE_enavg > enavg_nodata_threshold) PEATCLSM_FSWCHANGE_enavg = MAPL_UNDEF - - end if ! collect_land_counter==NUM_ENSEMBLE - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Collect_land") - call MAPL_TimerOff(MAPL, "TOTAL") - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Collect_land_ens - - - subroutine GET_CATCH_PARAM( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp),intent(inout) :: GC !Gridded component - type(ESMF_State), intent(inout) :: IMPORT !Import state - type(ESMF_State), intent(inout) :: EXPORT !Export state - type(ESMF_Clock), intent(inout) :: CLOCK !The clock - integer,optional, intent(out ) :: RC !Error code: - -!EOP -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME -! - -! Locals - type(MAPL_MetaComp), pointer :: MAPL=>null() - logical :: firsttime = .true. - - real, pointer :: poros(:) =>null() - real, pointer :: cond(:) =>null() - real, pointer :: psis(:) =>null() - real, pointer :: bee(:) =>null() - real, pointer :: wpwet(:) =>null() - real, pointer :: gnu(:) =>null() - real, pointer :: vgwmax(:) =>null() - real, pointer :: bf1(:) =>null() - real, pointer :: bf2(:) =>null() - real, pointer :: bf3(:) =>null() - real, pointer :: cdcr1(:) =>null() - real, pointer :: cdcr2(:) =>null() - real, pointer :: ars1(:) =>null() - real, pointer :: ars2(:) =>null() - real, pointer :: ars3(:) =>null() - real, pointer :: ara1(:) =>null() - real, pointer :: ara2(:) =>null() - real, pointer :: ara3(:) =>null() - real, pointer :: ara4(:) =>null() - real, pointer :: arw1(:) =>null() - real, pointer :: arw2(:) =>null() - real, pointer :: arw3(:) =>null() - real, pointer :: arw4(:) =>null() - real, pointer :: tsa1(:) =>null() - real, pointer :: tsa2(:) =>null() - real, pointer :: tsb1(:) =>null() - real, pointer :: tsb2(:) =>null() - real, pointer :: atau(:) =>null() - real, pointer :: btau(:) =>null() - real, pointer :: ity(:) =>null() - real, pointer :: z2ch(:) =>null() - - real :: SURFLAY, x - integer :: i - - if (firsttime) then - firsttime = .false. - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_GetPointer(import, poros, 'POROS', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cond, 'COND', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, psis, 'PSIS', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bee, 'BEE', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, wpwet, 'WPWET', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, gnu, 'GNU', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, vgwmax, 'VGWMAX', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf1, 'BF1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf2, 'BF2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, bf3, 'BF3', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cdcr1, 'CDCR1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, cdcr2, 'CDCR2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars1, 'ARS1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars2, 'ARS2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ars3, 'ARS3', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara1, 'ARA1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara2, 'ARA2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara3, 'ARA3', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ara4, 'ARA4', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw1, 'ARW1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw2, 'ARW2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw3, 'ARW3', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, arw4, 'ARW4', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsa1, 'TSA1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsa2, 'TSA2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsb1, 'TSB1', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, tsb2, 'TSB2', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, atau, 'ATAU', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, btau, 'BTAU', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ity, 'ITY', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, z2ch, 'Z2CH', rc=status) - VERIFY_(status) - - catch_param(:)%dzgt(1) = dzgt(1) - catch_param(:)%dzgt(2) = dzgt(2) - catch_param(:)%dzgt(3) = dzgt(3) - catch_param(:)%dzgt(4) = dzgt(4) - catch_param(:)%dzgt(5) = dzgt(5) - catch_param(:)%dzgt(6) = dzgt(6) - catch_param(:)%poros = poros - catch_param(:)%cond = cond - catch_param(:)%psis = psis - catch_param(:)%bee = bee - catch_param(:)%wpwet = wpwet - catch_param(:)%gnu = gnu - catch_param(:)%vgwmax= vgwmax - catch_param(:)%bf1 = bf1 - catch_param(:)%bf2 = bf2 - catch_param(:)%bf3 = bf3 - catch_param(:)%cdcr1 = cdcr1 - catch_param(:)%cdcr2 = cdcr2 - catch_param(:)%ars1 = ars1 - catch_param(:)%ars2 = ars2 - catch_param(:)%ars3 = ars3 - catch_param(:)%ara1 = ara1 - catch_param(:)%ara2 = ara2 - catch_param(:)%ara3 = ara3 - catch_param(:)%ara4 = ara4 - catch_param(:)%arw1 = arw1 - catch_param(:)%arw2 = arw2 - catch_param(:)%arw3 = arw3 - catch_param(:)%arw4 = arw4 - catch_param(:)%tsa1 = tsa1 - catch_param(:)%tsa2 = tsa2 - catch_param(:)%tsb1 = tsb1 - catch_param(:)%tsb2 = tsb2 - catch_param(:)%atau = atau - catch_param(:)%btau = btau - catch_param(:)%vegcls = nint(ity) - catch_param(:)%veghght = z2ch - - call MAPL_GetResource(MAPL, SURFLAY, Label="SURFLAY:", DEFAULT=50.0, rc=status) - - catch_param(:)%dzsf = SURFLAY - catch_param(:)%dzpr = (cdcr2/(1.-wpwet)) / poros - catch_param(:)%dzrz = vgwmax/poros - - !assign NaN to other fields - x = ieee_value(x,ieee_quiet_nan) - catch_param(:)%soilcls30 = transfer(x,i) - catch_param(:)%soilcls100 = transfer(x,i) - catch_param(:)%gravel30 = x - catch_param(:)%orgC30 = x - catch_param(:)%orgC = x - catch_param(:)%sand30 = x - catch_param(:)%clay30 = x - catch_param(:)%sand = x - catch_param(:)%clay = x - catch_param(:)%wpwet30 = x - catch_param(:)%poros30 = x - catch_param(:)%dpth = x - endif - RETURN_(ESMF_SUCCESS) -end subroutine GET_CATCH_PARAM - - - subroutine Finalize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! This Finalize routine cleans up the Ldas GridComp - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! Local variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Finalize" - - ! Call Finalize for every child - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - -end module GEOS_EnsGridCompMod diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/CMakeLists.txt deleted file mode 100644 index 13ca535e..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -esma_set_this () - -set (alldirs - GEOSexportcatchincr_GridComp - ) - -set (SRCS - io_hdf5.F90 enkf_general.F90 adapt_types.F90 mwRTM_types.F90 clsm_ensupd_glob_param.F90 - mwRTM_routines.F90 clsm_ensupd_upd_routines.F90 clsm_ensdrv_drv_routines.F90 - clsm_ensupd_read_obs.F90 catch_bias_types.F90 clsm_bias_routines.F90 clsm_adapt_routines.F90 - clsm_ensupd_enkf_update.F90 clsm_ensdrv_out_routines.F90 GEOS_LandAssimGridComp.F90 - ) - -find_package(HDF5 REQUIRED COMPONENTS Fortran) - -esma_add_library (${this} - SRCS ${SRCS} - SUBCOMPONENTS ${alldirs} - DEPENDENCIES GEOS_LdasShared GEOSens_GridComp GEOSlandpert_GridComp GEOSland_GridComp makebcs MAPL NCEP_bufr_r4i4 GMAO_gfio_r4 hdf5hl_fortran hdf5_fortran ${NETCDF_LIBRARIES} - INCLUDES ${INC_ESMF} ${INC_HDF5}) - -target_compile_definitions (${this} PRIVATE LDAS_MPI) diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOS_LandAssimGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOS_LandAssimGridComp.F90 deleted file mode 100644 index f24124fd..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOS_LandAssimGridComp.F90 +++ /dev/null @@ -1,2979 +0,0 @@ -#include "MAPL_Generic.h" - -!============================================================================= - -module GEOS_LandAssimGridCompMod - - !BOP - ! !DESCRIPTION: - ! - ! This is a gridded component for ensemble-based land data assimilation. - ! It has ExportCatchIncr as children for export purpose. - - ! - ! !USES: - - use ESMF - use MAPL_Mod - use ESMF_CFIOMOD, only: ESMF_CFIOstrTemplate - use GEOS_ExportCatchIncrGridCompMod, only: ExportCatchIncrSetServices=>SetServices - use MAPL_ConstantsMod, only: MAPL_TICE - - use LDAS_exceptionsMod, only: ldas_abort, LDAS_GENERIC_ERROR - - use LDAS_TileCoordType, only: tile_coord_type - use LDAS_TileCoordType, only: grid_def_type - use LDAS_TileCoordType, only: T_TILECOORD_STATE - use LDAS_TileCoordType, only: TILECOORD_WRAP - - use enkf_types, only: obs_type,obs_param_type - use nr_ran2_gasdev, only: NRANDSEED, init_randseed - use land_pert_routines, only: get_init_pert_rseed - use LDAS_ensdrv_mpi, only: mpicomm,numprocs,myid - use LDAS_ensdrv_mpi, only: root_proc - use LDAS_ensdrv_mpi, only: MPI_obs_param_type - - use LDAS_DateTimeMod, only: date_time_type - use LDAS_ensdrv_Globals, only: logunit, LDAS_is_nodata, nodata_generic, get_ensid_string - - use LDAS_ConvertMod, only: esmf2ldas - use LDAS_DriverTypes, only: met_force_type - - use GEOS_LandPertGridCompMod, only: N_force_pert, N_progn_pert - use GEOS_LandPertGridCompMod, only: progn_pert_param - use GEOS_LandPertGridCompMod, only: force_pert_param - - use catch_constants, only: DZGT=>CATCH_DZGT - use GEOS_EnsGridCompMod, only: cat_progn=>catch_progn - use GEOS_EnsGridCompMod, only: cat_param=>catch_param - use mwRTM_types, only: mwRTM_param_type, mwRTM_param_nodata_check - use catch_bias_types, only: obs_bias_type - use catch_bias_types, only: cat_bias_param_type - use catch_types, only: cat_progn_type - use catch_types, only: cat_param_type - use catch_types, only: cat_diagS_type - use catch_types, only: cat_diagS_max - use catch_types, only: cat_diagS_sqrt - use catch_types, only: assignment(=), operator (+), operator (-), operator (*), operator (/) - use clsm_bias_routines, only: initialize_obs_bias - use clsm_bias_routines, only: read_cat_bias_inputs - - use clsm_ensupd_upd_routines, only: read_ens_upd_inputs - use clsm_ensupd_upd_routines, only: finalize_obslog - use clsm_ensupd_glob_param, only: echo_clsm_ensupd_glob_param - use clsm_ensupd_enkf_update, only: get_enkf_increments - use clsm_ensupd_enkf_update, only: apply_enkf_increments - use clsm_ensupd_enkf_update, only: output_ObsFcstAna_wrapper - use clsm_ensupd_enkf_update, only: write_smapL4SMaup - use clsm_ensdrv_out_routines, only: init_log, GEOS_output_smapL4SMlmc - use clsm_ensdrv_drv_routines, only: recompute_diagS - - use mwRTM_routines, only: mwRTM_get_Tb, catch2mwRTM_vars - - use, intrinsic :: ieee_arithmetic - - implicit none - - include 'mpif.h' - - private - - ! !PUBLIC MEMBER FUNCTIONS: - - public :: SetServices - ! - !EOP - ! - integer, parameter :: NUM_SUBTILES = 4 - integer :: NUM_ENSEMBLE - integer :: FIRST_ENS_ID - integer :: collect_tb_counter - - type(met_force_type), allocatable :: mfPert_ensavg(:) - - type(obs_param_type), pointer :: obs_param(:)=>null() - - integer :: update_type - real :: xcompact, ycompact - real :: fcsterr_inflation_fac - integer :: N_obs_param - logical :: out_obslog - logical :: out_ObsFcstAna - logical :: out_smapL4SMaup - integer :: N_obsbias_max - - integer, dimension(:), pointer :: N_catl_vec,low_ind - integer :: N_catf - - !reordered tile_coord_rf and mapping l2rf - integer, dimension(:), pointer :: l2rf, rf2l,rf2g, rf2f - type(tile_coord_type), dimension(:), pointer :: tile_coord_rf => null() - - integer, allocatable :: Pert_rseed( :,:) - real(kind=ESMF_KIND_R8), allocatable :: pert_rseed_r8(:,:) - type(mwRTM_param_type), dimension(:), allocatable :: mwRTM_param - - logical :: mwRTM_all_nodata - logical :: land_assim - logical :: mwRTM - - logical, allocatable :: tb_nodata(:) - - character(len=400) :: err_msg - -contains - - ! ****************************************************************************** - - !BOP - ! !IROUTINE: SetServices -- Sets ESMF services for component - ! !INTERFACE: - - subroutine SetServices ( GC, RC ) - - ! !ARGUMENTS: - - type(ESMF_GridComp),intent(INOUT) :: GC - integer, optional, intent( OUT) :: RC - - ! !DESCRIPTION: - - !EOP - ! - ! ErrLog Variables - - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: STATUS - - ! Local Variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - character(len=ESMF_MAXSTR) :: LAND_ASSIM_STR, mwRTM_file - character(len=ESMF_MAXSTR) :: ensid_string, childname - integer :: i, ens_id_width, FIRST_ENS_ID, NUM_ENSEMBLE - integer :: ens_id, export_id - - ! Begin... - ! -------- - - ! Get my name and set-up traceback handle - ! ------------------------------------------------------------------------------ - - Iam='SetServices' - call ESMF_GridCompGet ( GC, NAME=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - Iam=trim(COMP_NAME)//trim(Iam) - - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - _VERIFY(status) - - call MAPL_GetResource ( MAPL, LAND_ASSIM_STR, Label="LAND_ASSIM:", DEFAULT="NO", RC=STATUS) - VERIFY_(STATUS) - LAND_ASSIM_STR = ESMF_UtilStringUpperCase(LAND_ASSIM_STR, rc=STATUS) - VERIFY_(STATUS) - land_assim = (trim(LAND_ASSIM_STR) /= 'NO') - - call MAPL_GetResource ( MAPL, mwRTM_file, Label="LANDASSIM_INTERNAL_RESTART_FILE:", DEFAULT='', RC=STATUS) - VERIFY_(STATUS) - mwRTM = ( len_trim(mwRTM_file) /= 0 ) - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - _VERIFY(status) - - !phase 1: assimilation run - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - RUN, & - rc=status & - ) - _VERIFY(status) - - !phase 2: feed back to change catch_progn - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - UPDATE_ASSIM, & - rc=status & - ) - _VERIFY(status) - - !phase 3: calculation of ensemble average of L-band Tb_h and Tb_v - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - CALC_LAND_TB, & - rc=status & - ) - _VERIFY(status) - - !phase 4: output_smapl4smlmc - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - OUTPUT_SMAPL4SMLMC, & - rc=status & - ) - _VERIFY(status) - - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - _VERIFY(status) - - - ! Set the state variable specs. - ! ----------------------------- - !BOS - ! - ! IMPORT STATE: - ! - ! --------------------------------- - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'soil_porosity' ,& - UNITS = '1' ,& - SHORT_NAME = 'POROS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'sfc_sat_hydraulic_conduct' ,& - UNITS = 'm s-1' ,& - SHORT_NAME = 'COND' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'saturated_matric_potential',& - UNITS = 'm' ,& - SHORT_NAME = 'PSIS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'clapp_hornberger_b' ,& - UNITS = '1' ,& - SHORT_NAME = 'BEE' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'wetness_at_wilting_point' ,& - UNITS = '1' ,& - SHORT_NAME = 'WPWET' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'vertical_transmissivity' ,& - UNITS = 'm-1' ,& - SHORT_NAME = 'GNU' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'max_rootzone_water_content',& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'VGWMAX' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'topo_baseflow_param_1' ,& - UNITS = 'kg m-4' ,& - SHORT_NAME = 'BF1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'topo_baseflow_param_2' ,& - UNITS = 'm' ,& - SHORT_NAME = 'BF2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'topo_baseflow_param_3' ,& - UNITS = 'log(m)' ,& - SHORT_NAME = 'BF3' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'moisture_threshold' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CDCR1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'max_water_content' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CDCR2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'wetness_param_1' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARS1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'wetness_param_2' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARS2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'wetness_param_3' ,& - UNITS = 'm+4 kg-2' ,& - SHORT_NAME = 'ARS3' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'shape_param_1' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARA1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'shape_param_2' ,& - UNITS = '1' ,& - SHORT_NAME = 'ARA2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'shape_param_3' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARA3' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'shape_param_4' ,& - UNITS = '1' ,& - SHORT_NAME = 'ARA4' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'min_theta_param_1' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARW1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'min_theta_param_2' ,& - UNITS = 'm+2 kg-1' ,& - SHORT_NAME = 'ARW2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'min_theta_param_3' ,& - UNITS = 'm+4 kg-2' ,& - SHORT_NAME = 'ARW3' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'min_theta_param_4' ,& - UNITS = '1' ,& - SHORT_NAME = 'ARW4' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_1' ,& - UNITS = '1' ,& - SHORT_NAME = 'TSA1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_2' ,& - UNITS = '1' ,& - SHORT_NAME = 'TSA2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_3' ,& - UNITS = '1' ,& - SHORT_NAME = 'TSB1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_4' ,& - UNITS = '1' ,& - SHORT_NAME = 'TSB2' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_5' ,& - UNITS = '1' ,& - SHORT_NAME = 'ATAU' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'water_transfer_param_6' ,& - UNITS = '1' ,& - SHORT_NAME = 'BTAU' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - SHORT_NAME = 'ITY' ,& - LONG_NAME = 'vegetation_type' ,& - UNITS = '1' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddImportSpec(GC ,& - SHORT_NAME = 'Z2CH' ,& - LONG_NAME = 'vegetation_height' ,& - UNITS = 'm' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - - ! Exports for brightness temperature - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Hpol' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TB_LAND_1410MHZ_40DEG_HPOL' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Vpol' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TB_LAND_1410MHZ_40DEG_VPOL' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - ! Exports for Catchment prognostics increments - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_saturated_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFSAT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_transition_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFTRN_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_wilting_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFWLT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_saturated_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFSAT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_transition_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFTRN_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_wilting_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFWLT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_interception_reservoir_capac' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CAPAC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_catchment_deficit' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CATDEF_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_root_zone_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'RZEXC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_surface_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'SRFEXC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_2' ,& - UNITS = 'J_m-2' ,& - SHORT_NAME = 'GHTCNT2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_4' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT4_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_5' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT5_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_6' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT6_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_1' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_2' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_3' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_2' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_1' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_2' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_3' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - ! some analysis model diagnostics - - ! - sm_surface_analysis [m3 m-3] - ! - sm_rootzone_analysis [m3 m-3] - ! - sm_profile_analysis [m3 m-3] - ! - surface_temp_analysis [K] - ! - soil_temp_layer1_analysis [K] - - ! could add other model diagnostics available in "cat_diagS_ensavg" (see below) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_surface_analysis' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCSF_ANA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_surface_analysis_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCSF_ANA_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_rootzone_analysis' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCRZ_ANA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_rootzone_analysis_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCRZ_ANA_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_profile_analysis' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCPR_ANA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_moisture_profile_analysis_ensstd' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'WCPR_ANA_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'ave_catchment_temp_incl_snw_analysis' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TPSURF_ANA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'ave_catchment_temp_incl_snw_analysis_ensstd' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TPSURF_ANA_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_temperatures_layer_1_analysis' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL1_ANA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'soil_temperatures_layer_1_analysis_ensstd' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TSOIL1_ANA_ENSSTD' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - ! Exports for microwave radiative transfer model (mwRTM) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Vegetation opacity (normalized with cosine of incidence angle)' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_VEGOPACITY' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - ! - ! INTERNAL STATE - ! - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Vegetation class. Type is Unsigned32' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_VEGCLS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - FRIENDLYTO = trim(COMP_NAME) ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Soil class. Type is Unsigned32' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_SOILCLS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Sand fraction' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_SAND' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Clay fraction' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_CLAY' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Porosity' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'MWRTM_POROS' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Wang dielectric model transition soil moisture' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'MWRTM_WANGWT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Wang dielectric model wilting point soil moisture' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'MWRTM_WANGWP' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Minimum microwave roughness parameter' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_RGHHMIN' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Maximum microwave roughness parameter' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_RGHHMAX' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Soil moisture value below which maximum microwave roughness parameter is used' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'MWRTM_RGHWMIN' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Soil moisture value above which minimum microwave roughness parameter is used' ,& - UNITS = 'm3 m-3' ,& - SHORT_NAME = 'MWRTM_RGHWMAX' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: H-pol. Exponent for rough reflectivity parameterization' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_RGHNRH' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: V-pol. Exponent for rough reflectivity parameterization' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_RGHNRV' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Polarization mixing parameter' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_RGHPOLMIX' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Scattering albedo' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_OMEGA' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: H-pol. Vegetation b parameter' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_BH' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: V-pol. Vegetation b parameter' ,& - UNITS = '1' ,& - SHORT_NAME = 'MWRTM_BV' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'L-band Microwave RTM: Parameter to transform leaf area index into vegetation water content' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'MWRTM_LEWT' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - DEFAULT = nodata_generic ,& - RC=STATUS) - - - if ( land_assim ) then - - call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, FIRST_ENS_ID, Label="FIRST_ENS_ID:", DEFAULT=0, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, ens_id_width, Label="ENS_ID_WIDTH:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - do i=1,NUM_ENSEMBLE - - ens_id = i-1 + FIRST_ENS_ID ! id start form FIRST_ENS_ID - - call get_ensid_string(ensid_string, ens_id, ens_id_width, NUM_ENSEMBLE) - - childname='CATCHINCR'//trim(ensid_string) - export_id = MAPL_AddChild(gc, name=childname, ss=ExportCatchIncrSetServices, rc=status) - VERIFY_(status) - enddo - endif - - call MAPL_TimerAdd(GC, name="Initialize" ,RC=STATUS) - _VERIFY(STATUS) - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) - _VERIFY(STATUS) - - call MAPL_GenericSetServices ( GC, RC=STATUS ) - _VERIFY(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - ! ****************************************************************************** - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !BOP - ! !IROTUINE: Initialize -- initialize method for LandAssim GC - - ! !INTERFACE: - subroutine Initialize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_Time) :: CurrentTime - type(ESMF_Time) :: AssimTime - type(ESMF_Alarm) :: LandAssimAlarm - type(ESMF_TimeInterval) :: LandAssim_DT, one_day - integer :: LandAssim_T0, LandAssimDTstep - type(ESMF_TimeInterval) :: ModelTimeStep - type(ESMF_Time) :: pertSeedTime - - ! locals - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - type(MAPL_MetaComp), pointer :: CHILD_MAPL=>null() ! Child's MAPL obj - type(ESMF_GridComp), pointer :: gcs(:) - - character(len=300) :: out_path - character(len=ESMF_MAXSTR) :: exp_id, GridName - integer :: model_dtstep - type(date_time_type) :: start_time - - ! LDAS' tile_coord variable - type(T_TILECOORD_STATE), pointer :: tcinternal - type(TILECOORD_WRAP) :: tcwrap - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l => null() - - integer :: land_nt_local,i,mpierr, ens, ens_id_width - ! mapping f to re-orderd f so it is continous for mpi_gather - ! rf -- ordered by processors. Within the processor, ordered by MAPL grid - integer, allocatable :: f2rf(:) ! mapping re-orderd rf to f for the LDASsa output - character(len=300) :: seed_fname - character(len=300) :: fname_tpl - character(len=ESMF_MAXSTR) :: ensid_string - integer :: nymd, nhms, yy, mm, dd, h, m, s - - !! from LDASsa - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - _VERIFY(status) - Iam = trim(comp_name) // "::Initialize" - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - _VERIFY(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Initialize") - - collect_tb_counter = 0 - call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, FIRST_ENS_ID, Label="FIRST_ENS_ID:", DEFAULT=0, RC=STATUS) - _VERIFY(STATUS) - call init_log( myid, numprocs, root_proc ) - ! Get number of land tiles - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - _VERIFY(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - _VERIFY(status) - - allocate(tb_nodata(land_nt_local)) - - if ( .not. land_assim) then ! to arrive here, mwRTM must be .true. - ! only need to calculate Tb for HISTORY; no processing of assimilation obs necessary; - ! generic initialization is sufficient - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - _VERIFY(status) - - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - RETURN_(ESMF_SUCCESS) - endif - - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="exp_id", RC=STATUS) - _VERIFY(STATUS) - - ! Get current time - call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) - _VERIFY(status) - call esmf2ldas(CurrentTime, start_time, rc=status) - _VERIFY(status) - - call ESMF_ClockGet(clock, timeStep=ModelTimeStep,rc=status) - _VERIFY(status) - call ESMF_TimeIntervalGet(ModelTimeStep, s=model_dtstep,rc=status) - _VERIFY(status) - - ! Create alarm for Land assimilation - ! -create-nonsticky-alarm- - ! -time-interval- - - ! get time step for land analysis - call MAPL_GetResource( & - MAPL, & - LandAssimDtStep, & - 'LANDASSIM_DT:', & - default=10800, & - rc=status & - ) - _VERIFY(status) - - _ASSERT(mod(LandAssimDtStep, model_dtstep)==0, "inconsistent inputs for HEARTBEAT_DT and LANDASSIM_DT") - _ASSERT(mod(86400, LandAssimDtStep)==0, "LANDASSIM_DT must be <=86400s and evenly divide a day") - _ASSERT(LandAssimDtStep>0, "LANDASSIM_DT must be non-negative") - - call ESMF_TimeIntervalSet(LandAssim_DT, s=LandAssimDtStep, rc=status) - _VERIFY(status) - - ! get "reference" time (HHMMSS) for land analysis (default=0z) - call MAPL_GetResource( & - MAPL, & - LandAssim_T0, & - 'LANDASSIM_T0:', & - default=000000, & - rc=status & - ) - _VERIFY(status) - - s = MAPL_nsecf(LandAssim_T0) - - _ASSERT(mod(s, model_dtstep)==0, "inconsistent inputs for HEARTBEAT_DT and LANDASSIM_T0") - - ! determine date and time of first land analysis - ! - ! LANDASSIM_T0 ("T0") and LANDASSIM_DT ("DT") define an infinite sequence of land analysis times: - ! - ! LANDASSIM_TIMES = {..., T0-3*DT, T0-2*DT, T0-DT, T0, T0+DT, T0+2*DT, T0+3*DT, ...} - ! - ! (because LANDASSIM_DT must be <=86400s and evenly divide a day, T0 only needs to specify HHMMSS) - ! - ! find the *earliest* date/time in LANDASSIM_TIMES that is *greater* than CurrentTime(=start_time) - ! (there is *no* land analysis at the restart time) - - ! to begin search for desired AssimTime, inherit date from CurrentTime(=start_time) - call ESMF_TimeGet(CurrentTime, YY = yy, & - MM = mm, & - DD = dd, & - rc=status) - _VERIFY(status) - - ! determine h, m, s from LANDASSIM_T0 - h = LandAssim_T0/10000 - m = mod(LandAssim_T0,10000)/100 - s = mod(LandAssim_T0,100) - - call ESMF_TimeSet( AssimTime, YY = yy, & - MM = mm, & - DD = dd, & - H = h, & - M = m, & - S = s, rc=status ) - - if (AssimTime > CurrentTime) then ! go back one day - call ESMF_TimeIntervalSet(one_day, d=1, rc=status) - _VERIFY(status) - AssimTime = AssimTime - one_day - endif - - ! now have (CurrentTime-one_day) < AssimTime <= CurrentTime; - ! compute *earliest* AssimTime that is *greater* than CurrentTime: - - AssimTime = AssimTime + (INT((CurrentTime - AssimTime)/LandAssim_DT)+1)*LandAssim_DT - - ! create LandAssimAlarm - - LandAssimAlarm = ESMF_AlarmCreate( & - clock, & - name='LandAssim', & - ringTime=AssimTime-ModelTimeStep, & - ringInterval=LandAssim_DT, & - ringTimeStepCount=1, & - sticky=.false., & - rc=status & - ) - _VERIFY(status) - - ! ------------------------------------ - - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - _VERIFY(status) - tcinternal =>tcwrap%ptr - tile_coord_l =>tcinternal%tile_coord - - allocate(Pert_rseed( NRANDSEED, NUM_ENSEMBLE), source = 0 ) - allocate(Pert_rseed_r8(NRANDSEED, NUM_ENSEMBLE), source = 0.0d0) - - if (root_proc) then - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=6, RC=STATUS) - _VERIFY(status) - call MAPL_GetResource( MAPL, fname_tpl, Label="LANDASSIM_OBSPERTRSEED_RESTART_FILE:", & - DEFAULT="../input/restart/landassim_obspertrseed%s_rst", RC=STATUS) - _VERIFY(STATUS) - - ! It is consistent with the default that psert seed time is one LandAssim_DT behind assim time - pertSeedTime = AssimTime - LandAssim_DT - - call ESMF_TimeGet(pertSeedTime, YY=YY, & - MM=MM, & - DD=DD, & - H =h, & - M =m, & - S =s, & - rc=status) - _VERIFY(STATUS) - - nymd = yy*10000 + mm*100 + dd - nhms = h *10000 + m*100 + s - - do ens = 0, NUM_ENSEMBLE-1 - call get_ensid_string(ensid_string, ens + FIRST_ENS_ID, ens_id_width, NUM_ENSEMBLE ) ! "_eXXXX" - seed_fname = "" - call ESMF_CFIOStrTemplate(seed_fname,fname_tpl,'GRADS', xid=trim(ensid_string), nymd=nymd,nhms=nhms,stat=status) - call read_pert_rseed(trim(ensid_string),seed_fname,Pert_rseed_r8(:,ens+1)) - - Pert_rseed(:,ens+1) = nint(Pert_rseed_r8(:,ens+1)) - if (all(Pert_rseed(:,ens+1) == 0)) then - call get_init_pert_rseed(ens, pert_rseed(1,ens+1)) - call init_randseed(pert_rseed(:,ens+1)) - endif - enddo - endif - call MPI_Bcast(pert_rseed, NRANDSEED*NUM_ENSEMBLE, MPI_INTEGER, 0, mpicomm, mpierr) - - allocate(N_catl_vec(numprocs)) - allocate(low_ind(numprocs)) - allocate(l2rf(land_nt_local)) - - call MPI_AllGATHER(land_nt_local,1,MPI_INTEGER,N_catl_vec,1,MPI_INTEGER,mpicomm,mpierr) - - low_ind(1) = 1 - do i = 2, numprocs - low_ind(i) = low_ind(i-1) + N_catl_vec(i-1) - enddo - N_catf = sum(N_catl_vec) - allocate(rf2f(N_catf)) - allocate(f2rf(N_catf)) - - call MPI_AllGATHERV(tcinternal%l2f, land_nt_local, MPI_INTEGER, & - rf2f, N_catl_vec, low_ind-1, MPI_INTEGER, & - mpicomm,mpierr) - - allocate(tile_coord_rf(N_catf)) - tile_coord_rf(:) = tcwrap%ptr%tile_coord_f(rf2f(:)) - allocate(rf2g(N_catf)) - rf2g(:) = tile_coord_rf(:)%tile_id - - do i=1,N_catf - f2rf(rf2f(i))= i - tile_coord_rf(i)%f_num = i - enddo - - do i=1, land_nt_local - l2rf(i) = low_ind(myid+1) + i - 1 - end do - - tcwrap%ptr%tile_coord%f_num = l2rf - - ! invert mapping from local to full grid (get f2l from l2f) - - allocate(rf2l(N_catf)) - - rf2l = -9999 - - do i=1,land_nt_local - rf2l( l2rf(i) ) = i - end do - - if (root_proc) then - call read_ens_upd_inputs( & - trim(out_path), & - trim(exp_id), & - start_time, & - N_catf, tile_coord_rf, & - N_progn_pert, progn_pert_param, & - N_force_pert, force_pert_param, & - mwRTM, & ! ensure mwRTM=.true. when microwave Tb obs are assimilated - update_type, & - xcompact, ycompact, & - fcsterr_inflation_fac, & - N_obs_param, & - obs_param, & - out_obslog, & - out_ObsFcstAna, & - out_smapL4SMaup, & - N_obsbias_max & - ) - - if (out_smapL4SMaup) then - - call MAPL_GetResource ( MAPL, GridName, Label="GEOSldas.GRIDNAME:", DEFAULT="EASE", RC=STATUS) - _VERIFY(STATUS) - _ASSERT( (NUM_ENSEMBLE>1), "out_smapL4SMaup=.true. only works for NUM_ENSEMBLE>1") - _ASSERT( (index(GridName,"EASEv2-M09") /=0 .or. index(GridName,"EASEv2_M09") /=0), "out_smapL4SMaup=.true. only works with EASEv2-M09 tile space") - - end if - - endif - - call MPI_BCAST(mwRTM, 1, MPI_LOGICAL, 0,MPICOMM,mpierr) - call MPI_BCAST(update_type, 1, MPI_INTEGER, 0,MPICOMM,mpierr) - call MPI_BCAST(xcompact, 1, MPI_REAL, 0,MPICOMM,mpierr) - call MPI_BCAST(ycompact, 1, MPI_REAL, 0,MPICOMM,mpierr) - call MPI_BCAST(fcsterr_inflation_fac, 1, MPI_REAL, 0,MPICOMM,mpierr) - call MPI_BCAST(N_obs_param, 1, MPI_INTEGER, 0,MPICOMM,mpierr) - call MPI_BCAST(out_obslog, 1, MPI_LOGICAL, 0,MPICOMM,mpierr) - call MPI_BCAST(out_ObsFcstAna, 1, MPI_LOGICAL, 0,MPICOMM,mpierr) - call MPI_BCAST(out_smapL4SMaup, 1, MPI_LOGICAL, 0,MPICOMM,mpierr) - call MPI_BCAST(N_obsbias_max, 1, MPI_INTEGER, 0,MPICOMM,mpierr) - - !---- - - if (.not. root_proc) allocate(obs_param(N_obs_param)) - - call MPI_BCAST(obs_param, N_obs_param, MPI_OBS_PARAM_TYPE, 0,MPICOMM,mpierr) - - if (root_proc) call echo_clsm_ensupd_glob_param(logunit) - - call MAPL_Get(MAPL, GCS=gcs, rc=status) - VERIFY_(STATUS) - - do i = 1,NUM_ENSEMBLE - call MAPL_GetObjectFromGC(gcs(i), CHILD_MAPL, rc=status) - VERIFY_(status) - call MAPL_Set(CHILD_MAPL, LocStream=locstream, rc=status) - VERIFY_(status) - enddo - - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - _VERIFY(status) - - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - - RETURN_(ESMF_SUCCESS) - - end subroutine Initialize - - ! ****************************************************************************** - - ! !IROUTINE: RUN - ! !INTERFACE: - subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) - - ! !ARGUMENTS: - - type(ESMF_GridComp),intent(inout) :: GC !Gridded component - type(ESMF_State), intent(inout) :: IMPORT !Import state - type(ESMF_State), intent(inout) :: EXPORT !Export state - type(ESMF_Clock), intent(inout) :: CLOCK !The clock - integer,optional, intent(out ) :: RC !Error code: - - !EOP - ! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - type(ESMF_State), pointer :: gex(:) - ! - ! time - ! - type(ESMF_Time) :: ModelTimeCur - type(ESMF_Alarm) :: LandAssimAlarm - type(ESMF_TimeInterval) :: ModelTimeStep - - - ! Locals - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(TILECOORD_WRAP) :: tcwrap - type(tile_coord_type), pointer :: tile_coord_l(:)=>null() - type(T_TILECOORD_STATE), pointer :: tcinternal - - type(ESMF_State) :: INTERNAL - type(date_time_type) :: start_time - type(date_time_type) :: date_time_new - character(len=14) :: datestamp - - integer :: N_catl, N_catg,N_obsl_max, n_e, ii - - character(len=300) :: out_path - character(len=ESMF_MAXSTR) :: exp_id - - type(met_force_type), dimension(:), allocatable :: met_force - - integer :: N_adapt_R - type(MAPL_LocStream) :: locstream - - integer, dimension(:), allocatable :: obs_pert_adapt_param - real, dimension(:,:), allocatable :: Pert_adapt_R - real, dimension(:,:), allocatable :: Obs_pert - type(obs_bias_type), dimension(:,:,:), allocatable :: obs_bias - - type(cat_progn_type), dimension(:,:), allocatable :: cat_progn_incr - type(cat_progn_type), dimension(:), allocatable :: cat_progn_incr_ensavg - type(cat_progn_type), dimension(:), allocatable :: cat_progn_tmp - - type(cat_diagS_type), dimension(:), allocatable :: cat_diagS - type(cat_diagS_type), dimension(:), allocatable :: cat_diagS_ensavg - type(cat_diagS_type), dimension(:), allocatable :: cat_diagS_ensstd - type(obs_type), dimension(:), pointer :: Observations_l => null() - - logical :: fresh_incr - integer :: N_obsf,N_obsl - !! import ensemble forcing - - real, pointer :: TA_enavg(:)=>null() - real, pointer :: QA_enavg(:)=>null() - real, pointer :: PS_enavg(:)=>null() - real, pointer :: UU_enavg(:)=>null() - real, pointer :: PCU_enavg(:)=>null() - real, pointer :: PLS_enavg(:)=>null() - real, pointer :: SNO_enavg(:)=>null() - real, pointer :: DRPAR_enavg(:)=>null() - real, pointer :: DFPAR_enavg(:)=>null() - real, pointer :: DRNIR_enavg(:)=>null() - real, pointer :: DFNIR_enavg(:)=>null() - real, pointer :: DRUVR_enavg(:)=>null() - real, pointer :: DFUVR_enavg(:)=>null() - real, pointer :: LWDNSRF_enavg(:)=>null() - real, pointer :: DZ_enavg(:)=>null() - real, pointer :: SWLAND(:)=>null() - real, pointer :: LAI(:)=>null() - - !! export for analysis model diagnostics - - real, dimension(:),pointer :: SFMC_ana=>null() ! surface soil moisture - real, dimension(:),pointer :: RZMC_ana=>null() ! rootzone soil moisture - real, dimension(:),pointer :: PRMC_ana=>null() ! profile soil moisture - real, dimension(:),pointer :: TPSURF_ana=>null() ! tpsurf - real, dimension(:),pointer :: TSOIL1_ana=>null() ! tsoil1 - - real, dimension(:),pointer :: SFMC_ana_ensstd=>null() ! surface soil moisture - real, dimension(:),pointer :: RZMC_ana_ensstd=>null() ! rootzone soil moisture - real, dimension(:),pointer :: PRMC_ana_ensstd=>null() ! profile soil moisture - real, dimension(:),pointer :: TPSURF_ana_ensstd=>null() ! tpsurf - real, dimension(:),pointer :: TSOIL1_ana_ensstd=>null() ! tsoil1 - - !! export for microwave radiative transfer model (mwRTM) - - real, dimension(:),pointer :: MWRTM_VEGOPACITY=>null() ! vegetation opacity (time-varying) - - logical, save :: firsttime=.true. - type(cat_bias_param_type) :: cat_bias_param - integer :: N_catbias - character(len=300) :: seed_fname - character(len=300) :: fname_tpl - character(len=ESMF_MAXSTR) :: ensid_string - integer :: ens, nymd, nhms, ens_id_width - integer :: LandassimDTstep - real :: Nm1, NdivNm1 - -#ifdef DBG_LANDASSIM_INPUTS - ! vars for debugging purposes - type(ESMF_Grid) :: TILEGRID - integer, pointer :: mask(:) - integer :: nt, ens_counter - integer, save :: unit_i=0 - integer :: unit - integer :: NT_GLOBAL,mpierr,i - real, allocatable :: metTair(:),metTair_l(:) - integer, allocatable :: ids(:) -#endif - - - call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - Iam=trim(COMP_NAME)//"::RUN" - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - _VERIFY(STATUS) - ! Start timers - ! ------------ - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"RUN") - call ESMF_ClockGetAlarm(clock, 'LandAssim', LandAssimAlarm, rc=status) - _VERIFY(status) - - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="exp_id", RC=STATUS) - - ! Get component's internal variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - _VERIFY(status) - tcinternal => tcwrap%ptr - tile_coord_l => tcwrap%ptr%tile_coord - - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, rc=status) - _VERIFY(status) - - ! Get current time - call ESMF_ClockGet(clock, timeStep=ModelTimeStep,rc=status) - _VERIFY(status) - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - _VERIFY(status) - call esmf2ldas(ModelTimeCur+ModelTimeStep, date_time_new, rc=status) - _VERIFY(status) - - call esmf2ldas(ModelTimeCur, start_time, rc=status) - _VERIFY(status) - - ! Get number of land tiles - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - _VERIFY(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=N_catl,rc=status) - _VERIFY(status) - - ! Pointers to internals - !---------------------- - - ! assert mwRTM parameters are not nodata for all tiles - if (mwRTM_all_nodata) then - _ASSERT(.false., "Tb innovations or assimilation requested but all mwRTM parameters are nodata") - endif - - if (firsttime) then - firsttime = .false. - if (root_proc) then - ! for out put - call read_cat_bias_inputs( trim(out_path), trim(exp_id), start_time, update_type, & - cat_bias_param, N_catbias) - endif - endif - - ! The time is one model time step behind Current time, so record the checkpoint here - if (MAPL_RecordAlarmIsRinging(MAPL)) then - if (root_proc) then - Pert_rseed_r8 = Pert_rseed - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=6, RC=STATUS) - _VERIFY(status) - call MAPL_GetResource ( MAPL, fname_tpl, Label="LANDASSIM_OBSPERTRSEED_CHECKPOINT_FILE:", DEFAULT="landassim_obspertrseed%s_checkpoint", RC=STATUS) - _VERIFY(STATUS) - fname_tpl = trim(fname_tpl) //".%y4%m2%d2_%h2%n2z.nc4" - call MAPL_DateStampGet( clock, datestamp, rc=status) - _VERIFY(STATUS) - read(datestamp(1:8),*) nymd - read(datestamp(10:13),*) nhms - nhms = nhms*100 - do ens = 0, NUM_ENSEMBLE-1 - call get_ensid_string(ensid_string, ens + FIRST_ENS_ID, ens_id_width, NUM_ENSEMBLE) ! " _eXXXX" - seed_fname = "" - call ESMF_CFIOStrTemplate(seed_fname,fname_tpl,'GRADS', xid=trim(ensid_string),nymd=nymd,nhms=nhms,stat=status) - _VERIFY(STATUS) - call write_pert_rseed(trim(seed_fname), Pert_rseed_r8(:,ens+1)) - enddo - endif - endif - - - if ( .not. ESMF_AlarmIsRinging(LandAssimAlarm)) then - call MAPL_TimerOff ( MAPL, "RUN" ) - call MAPL_TimerOff ( MAPL, "TOTAL" ) - RETURN_(ESMF_SUCCESS) - endif - - N_obsl_max = N_catl*N_obs_param - - !! get import from ens to get ensemble average forcing - - call MAPL_GetPointer(import, TA_enavg, 'TA', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, QA_enavg, 'QA', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, PS_enavg, 'PS', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, UU_enavg, 'UU', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, PCU_enavg, 'PCU', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, PLS_enavg, 'PLS', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, SNO_enavg, 'SNO', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DRPAR_enavg, 'DRPAR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DFPAR_enavg, 'DFPAR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DRNIR_enavg, 'DRNIR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DFNIR_enavg, 'DFNIR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DRUVR_enavg, 'DRUVR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DFUVR_enavg, 'DFUVR', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, LWDNSRF_enavg, 'LWDNSRF', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, DZ_enavg, 'DZ', rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, SWLAND, 'SWLAND', rc=status) ! not _enavg - _VERIFY(status) - call MAPL_GetPointer(import, LAI, 'LAI', rc=status) - _VERIFY(status) - - ! exports for analysis model diagnostics - - call MAPL_GetPointer(export, TPSURF_ana, 'TPSURF_ANA' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TSOIL1_ana, 'TSOIL1_ANA' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SFMC_ana, 'WCSF_ANA' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RZMC_ana, 'WCRZ_ANA' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PRMC_ana, 'WCPR_ANA' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TPSURF_ana_ensstd, 'TPSURF_ANA_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, TSOIL1_ana_ensstd, 'TSOIL1_ANA_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SFMC_ana_ensstd, 'WCSF_ANA_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RZMC_ana_ensstd, 'WCRZ_ANA_ENSSTD' ,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PRMC_ana_ensstd, 'WCPR_ANA_ENSSTD' ,rc=status) - VERIFY_(status) - - ! exports for microwave radiative transfer model (mwRTM) - - call MAPL_GetPointer(export, MWRTM_VEGOPACITY, 'MWRTM_VEGOPACITY' ,rc=status) - VERIFY_(status) - - - allocate(met_force(N_catl)) - met_force(:)%Tair = TA_enavg(:) - met_force(:)%Qair = QA_enavg(:) - met_force(:)%Psurf = PS_enavg(:) - met_force(:)%Rainf_c = PCU_enavg(:) - met_force(:)%Rainf = PCU_enavg(:) + PLS_enavg(:) - met_force(:)%Snowf = SNO_enavg(:) - met_force(:)%LWdown = LWDNSRF_enavg(:) - met_force(:)%SWdown = DRPAR_enavg(:)+DFPAR_enavg(:)+DRNIR_enavg(:) + & - DFNIR_enavg(:)+DRUVR_enavg(:)+DFUVR_enavg(:) - met_force(:)%PARdrct = DRPAR_enavg(:) - met_force(:)%PARdffs = DFPAR_enavg(:) - met_force(:)%wind = UU_enavg(:) - met_force(:)%RefH = DZ_enavg(:) - - ! Weiyuan note: dummy adapt for now - N_adapt_R = 0 - ! allocate(obs_pert_adapt_param(N_obs_param)) - ! allocate(Pert_adapt_R(N_adapt_R,NUM_ENSEMBLE)) - ! allocate(Obs_pert(N_obsl_max,NUM_ENSEMBLE)) - ! allocate zero size of array to pass in subroutine for debugging mode - allocate(obs_pert_adapt_param(0)) - allocate(Pert_adapt_R(N_adapt_R,NUM_ENSEMBLE)) - allocate(Obs_pert(0,NUM_ENSEMBLE)) - - allocate(obs_bias(N_catl,N_obs_param,N_obsbias_max)) - if (N_obsbias_max>0) then - call initialize_obs_bias( N_catf, N_obs_param, N_obsbias_max, trim(out_path), & - trim(exp_id), start_time, N_catl, numprocs, N_catl_vec, low_ind, obs_bias) - end if - - allocate(cat_progn_incr( N_catl, NUM_ENSEMBLE)) - allocate(cat_progn_incr_ensavg(N_catl )) - allocate(Observations_l( N_obsl_max )) - - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -#ifdef DBG_LANDASSIM_INPUTS - - if (firsttime) then - firsttime = .false. - call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) - _VERIFY(STATUS) - - call MAPL_TileMaskGet(tilegrid, mask, rc=status) - _VERIFY(STATUS) - - allocate(metTair(N_catf),metTair_l(N_catl)) - allocate(ids(N_catf)) - - metTair_l(:) = met_force(:)%Tair - ids(:) = tile_coord_rf(:)%tile_id - - call MPI_AllGATHERV(metTair_l, N_catl, MPI_REAL, & - metTair, N_catl_vec, low_ind-1, MPI_REAL, & - mpicomm,mpierr) - - - if(myid ==0) then - open(unit=10,file='metTair.txt',action="write",status="replace") - do i = 1, N_catf - write(10,*) ids(i), metTair(i) - enddo - close(10) - endif - - unit = GETFILE( "landassim_force_inputs.bin", form="unformatted", RC=STATUS ) - _VERIFY(STATUS) - ! Inputs - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Tair, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Qair, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Psurf, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Rainf_c, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Rainf, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%Snowf, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%LWdown, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%SWdown, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%PARdrct,mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%PARdffs, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%wind, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, met_force(:)%RefH, mask=mask, rc=status); _VERIFY(STATUS) - - - unit = GETFILE( "landassim_catprogn_inputs.bin", form="unformatted", RC=STATUS ) - _VERIFY(STATUS) - - ens_counter = 1 - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%tc1, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%tc2, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%tc4, mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%qa1, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%qa2, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%qa4, mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%capac, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%catdef, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%rzexc, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%srfexc, mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(1), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(2), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(3), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(4), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(5), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%ght(6), mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%wesn(1), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%wesn(2), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%wesn(3), mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%htsn(1), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%htsn(2), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%htsn(3), mask=mask, rc=status); _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%sndz(1), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%sndz(2), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid, cat_progn(:,ens_counter)%sndz(3), mask=mask, rc=status); _VERIFY(STATUS) - - - unit = GETFILE( "landassim_mwrtm_inputs.bin", form="unformatted", RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_VarWrite(unit, tilegrid,real(mwRTM_param(:)%vegcls), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,real(mwRTM_param(:)%soilcls), mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%sand, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%clay, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%poros, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%wang_wt, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%wang_wp, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_hmin, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_hmax, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_wmin, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_wmax, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_Nrh, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_Nrv, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_polmix,mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%omega, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%bh, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%bv, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%lewt, mask=mask, rc=status); _VERIFY(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%vegopacity,mask=mask, rc=status); _VERIFY(STATUS) ! NOT constant in time!!! - - !unit = GETFILE( "landassim_catparam_inputs.bin", form="unformatted", RC=STATUS ) - !_VERIFY(STATUS) - - endif - -#endif ! DBG_LANDASSIM_INPUTS - - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - call MAPL_GetResource( & - MAPL, & - LandAssimDtStep, & - 'LANDASSIM_DT:', & - default=10800, & - rc=status & - ) - _VERIFY(status) - - if ( mwRTM ) then - - ! mwRTM_param already contains static parameters, only need vegopacity. - - call get_vegopacity(MAPL, clock, N_catl, rc=status) - _VERIFY(STATUS) - - ! Check no-data consistency of vegetation attenuation parameter values. - ! Good values are allowed for either the relevant static parameters - ! (bh, bv, lewt) or for the vegopacity values from the file, but not both. - - do ii=1,N_catl - call mwRTM_param_nodata_check( mwRTM_param(ii) ) - end do - - endif - - if(.not. allocated(mwRTM_param)) then - - allocate(mwRTM_param(0)) - - endif - - call get_enkf_increments( & - date_time_new, & - NUM_ENSEMBLE, N_catl, N_catf, N_obsl_max, & - trim(out_path), trim(exp_id), & - met_force, lai, cat_param, mwRTM_param, & - tile_coord_l, tile_coord_rf, & - tcinternal%tgrid_g, tcinternal%pgrid_f, tcinternal%pgrid_g, & - N_catl_vec, low_ind, l2rf, rf2l, & - update_type, & - LandAssimDTstep, & - xcompact, ycompact, fcsterr_inflation_fac, & - N_obs_param, obs_param, N_obsbias_max, & - out_obslog, out_smapL4SMaup, & - cat_progn, & - Pert_rseed, obs_bias, & - cat_progn_incr, fresh_incr, & - N_obsf, N_obsl, Observations_l, & - ! below are dummy for now - N_adapt_R, obs_pert_adapt_param, Pert_adapt_R) - - if (fresh_incr) then - ! apply EnKF increments (incl. call to catch_calc_soil_moist but not to recompute_diagS()) - call apply_enkf_increments( N_catl, NUM_ENSEMBLE, update_type, cat_param, & - cat_progn_incr, cat_progn ) - - end if ! fresh_incr - - ! if requested, write incr and/or ObsFcstAna files whenever it was - ! time for assimilation, even if there were no observations - ! - reichle, 29 Aug 2014 - - ! WY note : Here N_catg is not the global land tile number - ! but a maximum global_id this simulation covers. - ! Need to find the number - N_catg = maxval(rf2g) - - if (.true.) then ! replace obsolete check for analysis time with "if true" to keep indents - - call output_ObsFcstAna_wrapper( out_ObsFcstAna, & - date_time_new, trim(exp_id), & - N_obsl, N_obs_param, NUM_ENSEMBLE, & - N_catl, tile_coord_l, & - N_catf, tile_coord_rf, tcinternal%pgrid_g, & - N_catl_vec, low_ind, rf2l, & - obs_param, & - met_force, lai, & - cat_param, cat_progn, mwRTM_param, & - Observations_l, rf2f=rf2f ) - - do ii = 1, N_catl - cat_progn_incr_ensavg(ii) = 0.0 - do n_e=1, NUM_ENSEMBLE - cat_progn_incr_ensavg(ii) = cat_progn_incr_ensavg(ii) & - + cat_progn_incr(ii,n_e) - end do - cat_progn_incr_ensavg(ii) = cat_progn_incr_ensavg(ii)/real(NUM_ENSEMBLE) - enddo - - ! Get information about children - call MAPL_Get(MAPL, GEX=gex, rc=status) - _VERIFY(STATUS) - do n_e =1, NUM_ENSEMBLE - call EXPORT_INCR(cat_progn_incr(:,n_e), gex(n_e), rc=status) - _VERIFY(status) - enddo - - call EXPORT_INCR(cat_progn_incr_ensavg, export, rc=status) - _VERIFY(status) - - ! recompute select model diagnostics after analysis - - allocate(cat_progn_tmp( N_catl)) - allocate(cat_diagS( N_catl)) - allocate(cat_diagS_ensavg(N_catl)) - allocate(cat_diagS_ensstd(N_catl)) - - do ii=1,N_catl - cat_diagS_ensavg(ii) = 0.0 ! initialize sum for ens average - cat_diagS_ensstd(ii) = 0.0 ! initialize sum of squares for ensemble standard deviation - end do - - ! compute sum (and sum of squares) of ensemble members - - do n_e=1,NUM_ENSEMBLE - - ! make a copy of cat_progn to ensure 0-diff (recompute_diagS() potentially alters its input cat_progn) - - do ii=1,N_catl - cat_progn_tmp(ii) = cat_progn(ii,n_e) - end do - - call recompute_diagS( N_catl, cat_param, cat_progn_tmp, cat_diagS ) - - do ii=1,N_catl - cat_diagS_ensavg(ii) = cat_diagS_ensavg(ii) + cat_diagS(ii) ! sum - cat_diagS_ensstd(ii) = cat_diagS_ensstd(ii) + ( cat_diagS(ii) * cat_diagS(ii) ) ! sum of squares - end do - - end do - - ! finalize ensemble average and standard deviation - - if (NUM_ENSEMBLE > 1) then - - Nm1 = real(NUM_ENSEMBLE-1) - - NdivNm1 = real(NUM_ENSEMBLE)/Nm1 - - do ii=1,N_catl - - cat_diagS_ensavg(ii) = cat_diagS_ensavg(ii)/real(NUM_ENSEMBLE) ! normalize --> ens avg - - cat_diagS_ensstd(ii) = & - cat_diagS_sqrt( & - cat_diagS_max( 0., cat_diagS_ensstd(ii)/Nm1 - NdivNm1*(cat_diagS_ensavg(ii)*cat_diagS_ensavg(ii))) & - ) - - end do - - else ! NUM_ENSEMBLE = 1 - - ! no need to normalize ens avg, set ens std to undef - - do ii=1,N_catl - - cat_diagS_ensstd(ii) = MAPL_UNDEF - - end do - - end if - - ! set export variables - - if(associated(SFMC_ana)) SFMC_ana(:) = cat_diagS_ensavg(:)%sfmc - if(associated(RZMC_ana)) RZMC_ana(:) = cat_diagS_ensavg(:)%rzmc - if(associated(PRMC_ana)) PRMC_ana(:) = cat_diagS_ensavg(:)%prmc - if(associated(TPSURF_ana)) TPSURF_ana(:) = cat_diagS_ensavg(:)%tsurf - if(associated(TSOIL1_ana)) TSOIL1_ana(:) = cat_diagS_ensavg(:)%tp(1) + MAPL_TICE ! convert to K - - if(associated(SFMC_ana_ensstd)) SFMC_ana_ensstd(:) = max( cat_diagS_ensstd(:)%sfmc , 0. ) - if(associated(RZMC_ana_ensstd)) RZMC_ana_ensstd(:) = max( cat_diagS_ensstd(:)%rzmc , 0. ) - if(associated(PRMC_ana_ensstd)) PRMC_ana_ensstd(:) = max( cat_diagS_ensstd(:)%prmc , 0. ) - if(associated(TPSURF_ana_ensstd)) TPSURF_ana_ensstd(:) = max( cat_diagS_ensstd(:)%tsurf , 0. ) - if(associated(TSOIL1_ana_ensstd)) TSOIL1_ana_ensstd(:) = max( cat_diagS_ensstd(:)%tp(1) , 0. ) - - if(associated(MWRTM_VEGOPACITY)) MWRTM_VEGOPACITY(:) = mwRTM_param(:)%VEGOPACITY - - deallocate(cat_progn_tmp) - deallocate(cat_diagS) - deallocate(cat_diagS_ensavg) - deallocate(cat_diagS_ensstd) - - ! write analysis fields into SMAP L4_SM aup file - ! whenever it was time for assimilation (regardless - ! of whether obs were actually assimilated and fresh - ! increments were computed) - - if (out_smapL4SMaup) & - call write_smapL4SMaup( 'analysis', date_time_new, & - trim(exp_id), NUM_ENSEMBLE, N_catl, N_catf, N_obsl, tile_coord_rf, & - tcinternal%tgrid_g, N_catl_vec, low_ind, & - N_obs_param, obs_param, Observations_l, cat_param, cat_progn ) - - end if ! end if (.true.) - - fresh_incr = .false. - - !-------------------- - ! Pointers to inputs - !-------------------- - deallocate(cat_progn_incr) - deallocate(cat_progn_incr_ensavg) - deallocate(Observations_l) - - call MAPL_TimerOff ( MAPL, "RUN" ) - call MAPL_TimerOff ( MAPL, "TOTAL" ) - - RETURN_(ESMF_SUCCESS) - - end subroutine RUN - - ! ****************************************************************************** - - ! !IROTUINE: collecting and averaging - - subroutine UPDATE_ASSIM(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - ! this export is from land grid come - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam='UPDATE_ASSIM' - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_Alarm) :: LandAssimAlarm - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - - real, dimension(:,:),pointer :: TC - real, dimension(:,:),pointer :: QC - real, dimension(:), pointer :: CAPAC - real, dimension(:), pointer :: CATDEF - real, dimension(:), pointer :: RZEXC - real, dimension(:), pointer :: SRFEXC - real, dimension(:), pointer :: GHTCNT1 - real, dimension(:), pointer :: GHTCNT2 - real, dimension(:), pointer :: GHTCNT3 - real, dimension(:), pointer :: GHTCNT4 - real, dimension(:), pointer :: GHTCNT5 - real, dimension(:), pointer :: GHTCNT6 - real, dimension(:), pointer :: WESNN1 - real, dimension(:), pointer :: WESNN2 - real, dimension(:), pointer :: WESNN3 - real, dimension(:), pointer :: HTSNNN1 - real, dimension(:), pointer :: HTSNNN2 - real, dimension(:), pointer :: HTSNNN3 - real, dimension(:), pointer :: SNDZN1 - real, dimension(:), pointer :: SNDZN2 - real, dimension(:), pointer :: SNDZN3 - - integer, save :: ens_counter = 0 - - !BOP - - call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - Iam=trim(COMP_NAME)//"::RUN" - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - _VERIFY(STATUS) - - call ESMF_ClockGetAlarm(clock, 'LandAssim', LandAssimAlarm, rc=status) - _VERIFY(status) - if ( .not. ESMF_AlarmIsRinging(LandAssimAlarm)) then - RETURN_(ESMF_SUCCESS) - endif - - call MAPL_GetPointer(export, TC, 'TC' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, QC, 'QC' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, CAPAC, 'CAPAC' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, CATDEF, 'CATDEF' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, RZEXC, 'RZEXC' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SRFEXC, 'SRFEXC' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT1, 'GHTCNT1' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT2, 'GHTCNT2' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT3, 'GHTCNT3' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT4, 'GHTCNT4' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT5, 'GHTCNT5' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT6, 'GHTCNT6' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN1, 'WESNN1' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN2, 'WESNN2' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN3, 'WESNN3' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN1, 'HTSNNN1' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN2, 'HTSNNN2' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN3, 'HTSNNN3' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN1, 'SNDZN1' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN2, 'SNDZN2' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN3, 'SNDZN3' ,rc=status) - _VERIFY(status) - - ! This counter is relative to ens_id - ens_counter = ens_counter + 1 - - !distribute catch_progn - TC(:,1) = cat_progn(:,ens_counter)%tc1 - TC(:,2) = cat_progn(:,ens_counter)%tc2 - TC(:,3) = cat_progn(:,ens_counter)%tc4 - - QC(:,1) = cat_progn(:,ens_counter)%qa1 - QC(:,2) = cat_progn(:,ens_counter)%qa2 - QC(:,3) = cat_progn(:,ens_counter)%qa4 - - CAPAC(:) = cat_progn(:,ens_counter)%capac - - CATDEF(:) = cat_progn(:,ens_counter)%catdef - RZEXC(:) = cat_progn(:,ens_counter)%rzexc - SRFEXC(:) = cat_progn(:,ens_counter)%srfexc - - GHTCNT1(:) = cat_progn(:,ens_counter)%ght(1) - GHTCNT2(:) = cat_progn(:,ens_counter)%ght(2) - GHTCNT3(:) = cat_progn(:,ens_counter)%ght(3) - GHTCNT4(:) = cat_progn(:,ens_counter)%ght(4) - GHTCNT5(:) = cat_progn(:,ens_counter)%ght(5) - GHTCNT6(:) = cat_progn(:,ens_counter)%ght(6) - - WESNN1(:) = cat_progn(:,ens_counter)%wesn(1) - WESNN2(:) = cat_progn(:,ens_counter)%wesn(2) - WESNN3(:) = cat_progn(:,ens_counter)%wesn(3) - - HTSNNN1(:) = cat_progn(:,ens_counter)%htsn(1) - HTSNNN2(:) = cat_progn(:,ens_counter)%htsn(2) - HTSNNN3(:) = cat_progn(:,ens_counter)%htsn(3) - - SNDZN1(:) = cat_progn(:,ens_counter)%sndz(1) - SNDZN2(:) = cat_progn(:,ens_counter)%sndz(2) - SNDZN3(:) = cat_progn(:,ens_counter)%sndz(3) - - if(ens_counter == NUM_ENSEMBLE ) ens_counter = 0 - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine UPDATE_ASSIM - - ! ****************************************************************************** - - ! subroutine to calculate Tb for HISTORY output - ! - ! IMPORTANT: hardwired mwRTM configuration for SMAP L-band Tb w/o Pellarin atm correction (RTM_ID=4) - - subroutine CALC_LAND_TB(gc, import, export, clock, rc) - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - ! this import is from land grid component - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - - ! hard-coded SMAP Tb parameters - real, parameter :: freq = 1.41e9 ! microwave frequency [Hz] - real, parameter :: inc_angle = 40. ! incidence angle [deg] - integer, parameter :: RTM_ID = 4 ! config of RTM - see obs_param (LDAS_DEFAULT_inputs_ensupd.nml) - - integer :: status - character(len=ESMF_MAXSTR) :: Iam='CALC_LAND_TB' - character(len=ESMF_MAXSTR) :: comp_name - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - type(ESMF_State) :: INTERNAL - - real, dimension(:), pointer :: LAI - real, dimension(:), pointer :: TP1 - real, dimension(:), pointer :: TPSURF - real, dimension(:), pointer :: WCSF - real, dimension(:), pointer :: SWE - - ! export - real, dimension(:), pointer :: TB_H_enavg - real, dimension(:), pointer :: TB_V_enavg - real, dimension(:), pointer :: MWRTM_VEGOPACITY - - ! local - real, allocatable, dimension(:) :: sfmc_mwRTM, tsoil_mwRTM - real, allocatable, dimension(:) :: dummy_real - real, allocatable, dimension(:) :: Tb_h_tmp, TB_v_tmp - - - integer :: N_catl - type(MAPL_LocStream) :: locstream - - call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - Iam=trim(COMP_NAME)//"::RUN" - - call MAPL_GetPointer(export, TB_H_enavg, 'TB_LAND_1410MHZ_40DEG_HPOL' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, TB_V_enavg, 'TB_LAND_1410MHZ_40DEG_VPOL' ,rc=status) - _VERIFY(STATUS) - - call MAPL_GetPointer(export, MWRTM_VEGOPACITY, 'MWRTM_VEGOPACITY' ,rc=status) - _VERIFY(STATUS) - - !if HISTORY does not ask for these variables, no calculation necessary; return - if ( (.not. associated(TB_H_enavg) ) .and. & - (.not. associated(TB_V_enavg) ) .and. & - (.not. associated(MWRTM_VEGOPACITY)) ) then - _RETURN(_SUCCESS) - endif - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - _VERIFY(status) - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - _VERIFY(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=N_catl,rc=status) - _VERIFY(status) - - ! Pointers to internals - !---------------------- - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, rc=status) - _VERIFY(status) - - call get_mwrtm_param(MAPL, clock, N_catl, INTERNAL, rc=status) - _VERIFY(STATUS) - ! make sure that at least some mwRTM parameters are not nodata - if (mwRTM_all_nodata) then - _ASSERT(.false., "Tb output requested but all mwRTM parameters are nodata") - endif - - ! set export variable - if(associated(MWRTM_VEGOPACITY)) MWRTM_VEGOPACITY(:) = mwRTM_param(:)%VEGOPACITY - - !if HISTORY does not ask for these variables, no calculation necessary; return - if ( (.not. associated(TB_H_enavg)) .and. & - (.not. associated(TB_V_enavg)) ) then - _RETURN(_SUCCESS) - endif - - call MAPL_GetPointer(import, LAI, 'LAI' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, TP1, 'TP1' ,rc=status) ! units now K, rreichle & borescan, 6 Nov 2020 - _VERIFY(status) - call MAPL_GetPointer(import, WCSF, 'WCSF' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, TPSURF, 'TPSURF' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(import, SWE, 'SNOWMASS' ,rc=status) - _VERIFY(status) - - ! convert Catchment model variables into inputs suitable for the mwRTM - ! NOTE: input TP1 must be in degree Celsius! - allocate(sfmc_mwRTM(N_catl), tsoil_mwRTM (N_catl)) - call catch2mwRTM_vars( & - N_catl, & - cat_param%vegcls, & ! not used anymore but keep for now - cat_param%poros, & - mwRTM_param%poros, & - WCSF, & - TPSURF, & - TP1, & ! units Kelvin !!! - sfmc_mwRTM, & - tsoil_mwRTM, & ! units Kelvin !!! - tp1_in_Kelvin=.true. ) - - ! calculate brightness temperatures - ! (tau-omega model as in De Lannoy et al. 2013 [doi:10.1175/JHM-D-12-092.1] - ! but without Pellarin atmospheric corrections) - - allocate(TB_h_tmp(N_catl), TB_v_tmp(N_catl)) - - select case (RTM_ID) - - case(2,4) - - allocate(dummy_real(N_catl)) ! allocate needed for GNU compiler - - call mwRTM_get_Tb( & - N_catl, freq, inc_angle, mwRTM_param, & - dummy_real, & ! intent(in), "elev", not used as long as RTM_ID=4 (formerly "incl_atm_terms=.false.") - LAI, & - sfmc_mwRTM, & - tsoil_mwRTM, & - SWE, & - dummy_real, & ! intent(in), "Tair", not used as long as "incl_atm_terms=.false." - RTM_ID, & - Tb_h_tmp, Tb_v_tmp ) ! intent(out) 'TB_LAND_1410MHZ_40DEG_HPOL', 'TB_LAND_1410MHZ_40DEG_VPOL' - deallocate(dummy_real) - - case(1,3) - - _ASSERT(.false., "top-of-atmosphere Tb calculation (requested per RTM_ID) not yet implemented") - - case default - - err_msg = 'unknown RTM_ID (during CALC_LAND_TB)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - if (collect_tb_counter == 0) then - TB_H_enavg = 0. - TB_V_enavg = 0. - tb_nodata = .false. - endif - - ! ensemble average Tb must be nodata if Tb of any member is nodata - - tb_nodata = tb_nodata .or. LDAS_is_nodata(Tb_h_tmp) .or. LDAS_is_nodata(Tb_v_tmp) - - ! This counter is relative to ens_id - collect_tb_counter = collect_tb_counter + 1 - - TB_H_enavg(:) = TB_H_enavg(:) + Tb_h_tmp(:) - TB_V_enavg(:) = TB_V_enavg(:) + Tb_v_tmp(:) - - if (collect_tb_counter == NUM_ENSEMBLE) then - - collect_tb_counter = 0 - - TB_H_enavg(:) = TB_H_enavg(:)/NUM_ENSEMBLE - TB_V_enavg(:) = TB_V_enavg(:)/NUM_ENSEMBLE - - ! finalize no-data-value - where (tb_nodata) - TB_H_enavg = MAPL_UNDEF - TB_V_enavg = MAPL_UNDEF - end where - - endif - - deallocate(Tb_h_tmp, Tb_v_tmp, sfmc_mwRTM, tsoil_mwRTM) - - RETURN_(_SUCCESS) - end subroutine CALC_LAND_TB - - ! ****************************************************************************** - - subroutine OUTPUT_SMAPL4SMLMC(gc, import, export, clock, rc) - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - ! this import is from land grid component - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - integer :: status - character(len=ESMF_MAXSTR) :: Iam='Output_smapL4SMlmc' - character(len=ESMF_MAXSTR) :: comp_name - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - type(ESMF_State) :: INTERNAL - type(T_TILECOORD_STATE), pointer :: tcinternal - type(TILECOORD_WRAP) :: tcwrap - type(tile_coord_type), dimension(:), pointer :: tile_coord_l => null() - character(len=300) :: out_path - character(len=ESMF_MAXSTR) :: exp_id - integer :: N_catl - type(MAPL_LocStream) :: locstream - type(ESMF_Time) :: ModelTimeCur - type(date_time_type) :: start_time - logical, save :: first_time = .true. - - if (.not. first_time) then - _RETURN(_SUCCESS) - endif - - call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - _VERIFY(status) - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - _VERIFY(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=N_catl,rc=status) - _VERIFY(status) - - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - _VERIFY(status) - tcinternal =>tcwrap%ptr - tile_coord_l =>tcinternal%tile_coord - - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, rc=status) - _VERIFY(status) - - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="exp_id", RC=STATUS) - _VERIFY(STATUS) - ! Get current time - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - _VERIFY(status) - call esmf2ldas(ModelTimeCur, start_time, rc=status) - _VERIFY(status) - - call get_mwrtm_param(MAPL, clock, N_catl, INTERNAL, rc=status) - _VERIFY(status) - - call GEOS_output_smapL4SMlmc( GC, start_time, trim(out_path), trim(exp_id), & - N_catl, tile_coord_l, cat_param, mwRTM_param ) - first_time = .false. - - _RETURN(_SUCCESS) - - end subroutine OUTPUT_SMAPL4SMLMC - - ! ****************************************************************************** - - subroutine EXPORT_INCR( cat_progn_incr, export,rc) - type(cat_progn_type), dimension(:),intent(in) :: cat_progn_incr - type(ESMF_State), intent(inout) :: export - integer, optional, intent(out) :: rc - !! export incr progn - - real, dimension(:),pointer :: TC1_incr=>null() - real, dimension(:),pointer :: TC2_incr=>null() - real, dimension(:),pointer :: TC4_incr=>null() - real, dimension(:),pointer :: QC1_incr=>null() - real, dimension(:),pointer :: QC2_incr=>null() - real, dimension(:),pointer :: QC4_incr=>null() - real, dimension(:),pointer :: CAPAC_incr=>null() - real, dimension(:),pointer :: CATDEF_incr=>null() - real, dimension(:),pointer :: RZEXC_incr=>null() - real, dimension(:),pointer :: SRFEXC_incr=>null() - real, dimension(:),pointer :: GHTCNT1_incr=>null() - real, dimension(:),pointer :: GHTCNT2_incr=>null() - real, dimension(:),pointer :: GHTCNT3_incr=>null() - real, dimension(:),pointer :: GHTCNT4_incr=>null() - real, dimension(:),pointer :: GHTCNT5_incr=>null() - real, dimension(:),pointer :: GHTCNT6_incr=>null() - real, dimension(:),pointer :: WESNN1_incr=>null() - real, dimension(:),pointer :: WESNN2_incr=>null() - real, dimension(:),pointer :: WESNN3_incr=>null() - real, dimension(:),pointer :: HTSNNN1_incr=>null() - real, dimension(:),pointer :: HTSNNN2_incr=>null() - real, dimension(:),pointer :: HTSNNN3_incr=>null() - real, dimension(:),pointer :: SNDZN1_incr=>null() - real, dimension(:),pointer :: SNDZN2_incr=>null() - real, dimension(:),pointer :: SNDZN3_incr=>null() - - integer :: status - - ! exports for model prognostics increments - - call MAPL_GetPointer(export, TC1_incr, 'TCFSAT_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, TC2_incr, 'TCFTRN_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, TC4_incr, 'TCFWLT_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, QC1_incr, 'QCFSAT_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, QC2_incr, 'QCFTRN_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, QC4_incr, 'QCFWLT_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, CAPAC_incr, 'CAPAC_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, CATDEF_incr, 'CATDEF_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, RZEXC_incr, 'RZEXC_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SRFEXC_incr, 'SRFEXC_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT1_incr, 'GHTCNT1_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT2_incr, 'GHTCNT2_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT3_incr, 'GHTCNT3_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT4_incr, 'GHTCNT4_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT5_incr, 'GHTCNT5_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, GHTCNT6_incr, 'GHTCNT6_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN1_incr, 'WESNN1_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN2_incr, 'WESNN2_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, WESNN3_incr, 'WESNN3_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN1_incr, 'HTSNNN1_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN2_incr, 'HTSNNN2_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, HTSNNN3_incr, 'HTSNNN3_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN1_incr, 'SNDZN1_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN2_incr, 'SNDZN2_INCR' ,rc=status) - _VERIFY(status) - call MAPL_GetPointer(export, SNDZN3_incr, 'SNDZN3_INCR' ,rc=status) - _VERIFY(status) - - if(associated(TC1_incr)) TC1_incr(:) = cat_progn_incr(:)%tc1 - if(associated(TC2_incr)) TC2_incr(:) = cat_progn_incr(:)%tc2 - if(associated(TC4_incr)) TC4_incr(:) = cat_progn_incr(:)%tc4 - if(associated(QC1_incr)) QC1_incr(:) = cat_progn_incr(:)%qa1 - if(associated(QC2_incr)) QC2_incr(:) = cat_progn_incr(:)%qa2 - if(associated(QC4_incr)) QC4_incr(:) = cat_progn_incr(:)%qa4 - - if(associated(CAPAC_incr)) CAPAC_incr(:) = cat_progn_incr(:)%capac - if(associated(CATDEF_incr)) CATDEF_incr(:) = cat_progn_incr(:)%catdef - if(associated(RZEXC_incr)) RZEXC_incr(:) = cat_progn_incr(:)%rzexc - if(associated(SRFEXC_incr)) SRFEXC_incr(:) = cat_progn_incr(:)%srfexc - - if(associated(GHTCNT1_incr)) GHTCNT1_incr(:) = cat_progn_incr(:)%ght(1) - if(associated(GHTCNT2_incr)) GHTCNT2_incr(:) = cat_progn_incr(:)%ght(2) - if(associated(GHTCNT3_incr)) GHTCNT3_incr(:) = cat_progn_incr(:)%ght(3) - if(associated(GHTCNT4_incr)) GHTCNT4_incr(:) = cat_progn_incr(:)%ght(4) - if(associated(GHTCNT5_incr)) GHTCNT5_incr(:) = cat_progn_incr(:)%ght(5) - if(associated(GHTCNT6_incr)) GHTCNT6_incr(:) = cat_progn_incr(:)%ght(6) - - if(associated(WESNN1_incr)) WESNN1_incr(:) = cat_progn_incr(:)%wesn(1) - if(associated(WESNN2_incr)) WESNN2_incr(:) = cat_progn_incr(:)%wesn(2) - if(associated(WESNN3_incr)) WESNN3_incr(:) = cat_progn_incr(:)%wesn(3) - - if(associated(HTSNNN1_incr)) HTSNNN1_incr(:) = cat_progn_incr(:)%htsn(1) - if(associated(HTSNNN2_incr)) HTSNNN2_incr(:) = cat_progn_incr(:)%htsn(2) - if(associated(HTSNNN3_incr)) HTSNNN3_incr(:) = cat_progn_incr(:)%htsn(3) - - if(associated(SNDZN1_incr)) SNDZN1_incr(:) = cat_progn_incr(:)%sndz(1) - if(associated(SNDZN2_incr)) SNDZN2_incr(:) = cat_progn_incr(:)%sndz(2) - if(associated(SNDZN3_incr)) SNDZN3_incr(:) = cat_progn_incr(:)%sndz(3) - - _RETURN(_SUCCESS) - - end subroutine EXPORT_INCR - - ! ****************************************************************************** - - subroutine read_pert_rseed(ensid_string,seed_fname,pert_rseed_r8) - use netcdf - character(len=*),intent(in) :: ensid_string - character(len=*),intent(in) :: seed_fname - real(kind=ESMF_KIND_R8),intent(inout) :: pert_rseed_r8(:) - - integer :: ncid, s_varid - logical :: file_exist - - character(len=ESMF_MAXSTR) :: tmpstr - - inquire (file = trim(seed_fname), exist=file_exist) - if ( .not. file_exist) then - tmpstr = 'Cold-starting OBSPERTRSEED for ens member ' // trim(ensid_string) // '.' - if (len_trim(seed_fname)>0) then - print *, trim(tmpstr), 'File not found: ', trim(seed_fname) - else - print *, trim(tmpstr), 'Restart file name is empty.' - end if - pert_rseed_r8 = 0 - return - else - tmpstr = 'Reading OBSPERTRSEED for ens member ' // trim(ensid_string) // ' from ' - print *, trim(tmpstr), trim(seed_fname) - endif - - call check( nf90_open(seed_fname, NF90_NOWRITE, ncid) ) - ! Get the varid of the data variable, based on its name. - call check( nf90_inq_varid(ncid, "pert_rseed", s_varid) ) - call check( nf90_get_var(ncid, s_varid, pert_rseed_r8) ) - - ! Close the file, freeing all resources. - call check( nf90_close(ncid) ) - - contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop 1 - end if - end subroutine check - end subroutine read_pert_rseed - - ! ****************************************************************************** - - subroutine write_pert_rseed(chk_fname, pert_rseed_r8) - use netcdf - character(len=*),intent(in) :: chk_fname - real(kind=ESMF_KIND_R8),intent(in) :: pert_rseed_r8(:) - character(len=*), parameter :: SHORT_NAME = "SHORT_NAME" - character(len=*), parameter :: LONG_NAME = "LONG_NAME" - character(len=*), parameter :: UNITS = "UNITS" - character(len=*), parameter :: s_SHORT = "obspert_rseed" - character(len=*), parameter :: s_long = "Observation_Perturbations_rseed" - character(len=*), parameter :: units_ = "1" - - integer :: nseeds - integer :: ncid, s_varid - integer :: seed_dimid - - nseeds = size(pert_rseed_r8) - - ! Create the file. - call check( nf90_create(trim(chk_fname), nf90_clobber + NF90_NETCDF4, ncid) ) - ! Define the dimensions. - call check( nf90_def_dim(ncid, "NRANDSEED", nseeds, seed_dimid) ) - call check( nf90_def_var(ncid, 'pert_rseed', NF90_DOUBLE, [seed_dimid], s_varid) ) - - ! Assign attribute - call check( nf90_put_att(ncid, s_varid, UNITS, units_) ) - call check( nf90_put_att(ncid, s_varid, SHORT_NAME, s_short) ) - call check( nf90_put_att(ncid, s_varid, LONG_NAME, s_long) ) - - ! End define mode. - call check( nf90_enddef(ncid) ) - - ! write varaible - call check( nf90_put_var(ncid, s_varid, pert_rseed_r8) ) - ! Close the file. - call check( nf90_close(ncid) ) - - contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop 1 - end if - end subroutine check - end subroutine write_pert_rseed - - ! ****************************************************************************** - - subroutine get_mwrtm_param(MAPL, clock, N_catl, INTERNAL, rc) - - type(MAPL_MetaComp), pointer, intent(in) :: MAPL - type(ESMF_Clock), intent(in) :: clock ! the clock - integer, intent(in) :: N_catl - type(ESMF_State), intent(inout) :: INTERNAL - integer, optional, intent(out) :: rc - - ! local variables - - real, dimension(:), pointer :: VEGCLS - real, dimension(:), pointer :: SOILCLS - real, dimension(:), pointer :: SAND - real, dimension(:), pointer :: CLAY - real, dimension(:), pointer :: mw_POROS - real, dimension(:), pointer :: WANGWT - real, dimension(:), pointer :: WANGWP - real, dimension(:), pointer :: RGHHMIN - real, dimension(:), pointer :: RGHHMAX - real, dimension(:), pointer :: RGHWMAX - real, dimension(:), pointer :: RGHWMIN - real, dimension(:), pointer :: RGHNRH - real, dimension(:), pointer :: RGHNRV - real, dimension(:), pointer :: RGHPOLMIX - real, dimension(:), pointer :: OMEGA - real, dimension(:), pointer :: BH - real, dimension(:), pointer :: BV - real, dimension(:), pointer :: LEWT - - integer :: N_catl_tmp, n, mpierr, status - logical :: mwp_nodata, all_nodata_l - - - if(.not. allocated(mwRTM_param)) then - - ! get static mwRTM parameters from MWRTM_FILE - - call MAPL_GetPointer(INTERNAL, SAND , 'MWRTM_SAND' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, SOILCLS , 'MWRTM_SOILCLS' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, VEGCLS , 'MWRTM_VEGCLS' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, CLAY , 'MWRTM_CLAY' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, mw_POROS , 'MWRTM_POROS' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, WANGWT , 'MWRTM_WANGWT' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, WANGWP , 'MWRTM_WANGWP' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHHMIN , 'MWRTM_RGHHMIN' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHHMAX , 'MWRTM_RGHHMAX' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHWMIN , 'MWRTM_RGHWMIN' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHWMAX , 'MWRTM_RGHWMAX' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHNRH , 'MWRTM_RGHNRH' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHNRV , 'MWRTM_RGHNRV' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, RGHPOLMIX, 'MWRTM_RGHPOLMIX', RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, OMEGA , 'MWRTM_OMEGA' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, BH , 'MWRTM_BH' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, BV , 'MWRTM_BV' , RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetPointer(INTERNAL, LEWT , 'MWRTM_LEWT' , RC=STATUS) - _VERIFY(STATUS) - - N_catl_tmp = size(sand,1) - _ASSERT(N_catl_tmp == N_catl, "sanity check: N_catl should be consistent") - - allocate(mwRTM_param(N_catl)) - mwRTM_param(:)%sand = SAND(:) - mwRTM_param(:)%vegcls = nint(VEGCLS(:)) - mwRTM_param(:)%soilcls = nint(SOILCLS(:)) - mwRTM_param(:)%clay = CLAY(:) - mwRTM_param(:)%poros = mw_POROS(:) - mwRTM_param(:)%wang_wt = WANGWT(:) - mwRTM_param(:)%wang_wp = WANGWP(:) - mwRTM_param(:)%rgh_hmin = RGHHMIN(:) - mwRTM_param(:)%rgh_hmax = RGHHMAX(:) - mwRTM_param(:)%rgh_wmin = RGHWMIN(:) - mwRTM_param(:)%rgh_wmax = RGHWMAX(:) - mwRTM_param(:)%rgh_Nrh = RGHNRH(:) - mwRTM_param(:)%rgh_Nrv = RGHNRV(:) - mwRTM_param(:)%rgh_polmix= RGHPOLMIX(:) - mwRTM_param(:)%omega = OMEGA(:) - mwRTM_param(:)%bh = BH(:) - mwRTM_param(:)%bv = bv(:) - mwRTM_param(:)%lewt = LEWT(:) - - endif ! if (.not. allocated(mwRTM_param)) - - ! get current value of vegopacity - - call get_vegopacity(MAPL, clock, N_catl, rc=status) - _VERIFY(STATUS) - - ! no-data value check - - all_nodata_l = .true. - do n=1,N_catl - call mwRTM_param_nodata_check(mwRTM_param(n), mwp_nodata ) - if (.not. mwp_nodata) all_nodata_l = .false. - end do - - ! perform logical AND across elements - call MPI_AllReduce(all_nodata_l, mwRTM_all_nodata, 1, MPI_LOGICAL, & - MPI_LAND, mpicomm, mpierr) - _RETURN(_SUCCESS) - - end subroutine get_mwrtm_param - - ! ****************************************************************************** - - subroutine get_vegopacity(MAPL, clock, N_catl, rc) - - ! read seasonally-varying veg opacity (climatology) from file - - type(MAPL_MetaComp), pointer, intent(in) :: MAPL - type(ESMF_Clock), intent(in) :: clock ! the clock - integer, intent(in) :: N_catl - integer, optional, intent(out) :: rc - - ! local variables - real, dimension(:), pointer :: VEGOPACITY - - integer :: status - - character(len=ESMF_MAXSTR) :: VEGOPACITYFile - type(ESMF_Time) :: CURRENT_TIME - - ! -------------------------------------------------- - - call ESMF_ClockGet( CLOCK, currTime=CURRENT_TIME, RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_GetResource(MAPL, VEGOPACITYFile, label = 'VEGOPACITY_FILE:', & - default = '', RC=STATUS ) - _VERIFY(STATUS) - - allocate(VEGOPACITY(N_catl), source=MAPL_UNDEF) - - ! if a non-empty file name is provided in LDAS.rc, read vegetation opacity from this file - - if (len(trim(VEGOPACITYFile))>0) then - - ! for a given tile, vegetation opacity in the data file may contain a mix of "good" and no-data values; - ! the file must use MAPL_UNDEF (=1.e15) as the no-data value because MAPL_ReadForcing() only - ! recognized MAPL_UNDEF - - call MAPL_ReadForcing(MAPL,'VEGOPACITY',VEGOPACITYFile,CURRENT_TIME,VEGOPACITY,ON_TILES=.true.,RC=STATUS) - _VERIFY(STATUS) - - ! fix "bad" (-9999.) no-data-values in first edition of VEGOPACITY file - - where (VEGOPACITY<0.) VEGOPACITY=MAPL_UNDEF - - end if - - mwRTM_param(:)%vegopacity= VEGOPACITY(:) - deallocate(VEGOPACITY) - _RETURN(_SUCCESS) - - end subroutine get_vegopacity - - ! ****************************************************************************** - - !BOP - ! !IROTUINE: Finalize -- finalize method for LDAS GC - ! !INTERFACE: - subroutine Finalize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - type(MAPL_MetaComp), pointer :: MAPL=>null() - character(len=300) :: seed_fname - character(len=300) :: fname_tpl - character(len=300) :: out_path - character(len=ESMF_MAXSTR) :: exp_id - character(len=ESMF_MAXSTR) :: ensid_string - character(len=14) :: datestamp - integer :: ens, nymd, nhms, ens_id_width - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - _VERIFY(status) - Iam = trim(comp_name) // "::Finalize" - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - _VERIFY(STATUS) - - if( land_assim) then - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - _VERIFY(STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="exp_id", RC=STATUS) - _VERIFY(STATUS) - - if (root_proc) then - if (out_obslog) call finalize_obslog() - Pert_rseed_r8 = Pert_rseed - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=6, RC=STATUS) - _VERIFY(status) - call MAPL_GetResource ( MAPL, fname_tpl, Label="LANDASSIM_OBSPERTRSEED_CHECKPOINT_FILE:", & - DEFAULT="landassim_obspertrseed%s_checkpoint", RC=STATUS) - _VERIFY(STATUS) - call MAPL_DateStampGet( clock, datestamp, rc=status) - _VERIFY(STATUS) - - read(datestamp(1:8),*) nymd - read(datestamp(10:13),*) nhms - nhms = nhms*100 - do ens = 0, NUM_ENSEMBLE-1 - call get_ensid_string(ensid_string, ens + FIRST_ENS_ID, ens_id_width, NUM_ENSEMBLE ) - seed_fname = "" - call ESMF_CFIOStrTemplate(seed_fname,fname_tpl,'GRADS', xid=trim(ensid_string),nymd=nymd,nhms=nhms,stat=status) - _VERIFY(STATUS) - call write_pert_rseed(trim(seed_fname), Pert_rseed_r8(:,ens+1)) - enddo - endif - endif ! land_assim - - ! Call Finalize for every child - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - _VERIFY(status) - - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - -end module GEOS_LandAssimGridCompMod - -! ====================== EOF ======================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/CMakeLists.txt deleted file mode 100644 index 89fb9b41..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/CMakeLists.txt +++ /dev/null @@ -1,12 +0,0 @@ -esma_set_this () - -set (SRCS - GEOS_ExportCatchIncrGridComp.F90 - ) - -esma_add_library (${this} - SRCS ${SRCS} - DEPENDENCIES MAPL - ) - -target_compile_definitions (${this} PRIVATE LDAS_MPI) diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/GEOS_ExportCatchIncrGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/GEOS_ExportCatchIncrGridComp.F90 deleted file mode 100644 index 8ea79574..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/GEOSexportcatchincr_GridComp/GEOS_ExportCatchIncrGridComp.F90 +++ /dev/null @@ -1,391 +0,0 @@ -#include "MAPL_Generic.h" - -!============================================================================= -module GEOS_ExportCatchIncrGridCompMod - - !BOP - ! !DESCRIPTION: - ! - ! This is a gridded component to export analysis increments for Catchment. - ! It has no children. - - ! - ! !USES: - - use ESMF - use MAPL_Mod - use ESMF_CFIOMOD, only: ESMF_CFIOstrTemplate - - implicit none - - include 'mpif.h' - - private - ! !PUBLIC MEMBER FUNCTIONS: - public :: SetServices - ! - !EOP - ! - integer, parameter :: NUM_SUBTILES = 4 - -contains - - ! ****************************************************************************** - - !BOP - ! !IROUTINE: SetServices -- Sets ESMF services for component - ! !INTERFACE: - - subroutine SetServices ( GC, RC ) - - ! !ARGUMENTS: - - type(ESMF_GridComp),intent(INOUT) :: GC - integer, optional, intent( OUT) :: RC - - ! !DESCRIPTION: - - !EOP - ! - ! ErrLog Variables - - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: STATUS - - ! Local Variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(ESMF_Config) :: CF - - ! Begin... - ! -------- - - ! Get my name and set-up traceback handle - ! ------------------------------------------------------------------------------ - - Iam='SetServices' - call ESMF_GridCompGet ( GC, NAME=COMP_NAME, RC=STATUS ) - _VERIFY(STATUS) - Iam=trim(COMP_NAME)//trim(Iam) - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - _VERIFY(status) - - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - _VERIFY(status) - - ! Exports for Catchment prognostics increments - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_saturated_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFSAT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_transition_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFTRN_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_temperature_wilting_zone' ,& - UNITS = 'K' ,& - SHORT_NAME = 'TCFWLT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_saturated_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFSAT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_transition_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFTRN_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_canopy_specific_humidity_wilting_zone' ,& - UNITS = 'kg kg-1' ,& - SHORT_NAME = 'QCFWLT_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_interception_reservoir_capac' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CAPAC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_catchment_deficit' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'CATDEF_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_root_zone_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'RZEXC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_surface_excess' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'SRFEXC_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_2' ,& - UNITS = 'J_m-2' ,& - SHORT_NAME = 'GHTCNT2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_4' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT4_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_5' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT5_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_soil_heat_content_layer_6' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'GHTCNT6_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_1' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_2' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_mass_layer_3' ,& - UNITS = 'kg m-2' ,& - SHORT_NAME = 'WESNN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_1' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_2' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_heat_content_snow_layer_3' ,& - UNITS = 'J m-2' ,& - SHORT_NAME = 'HTSNNN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_1' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN1_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_2' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN2_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'increment_snow_depth_layer_3' ,& - UNITS = 'm' ,& - SHORT_NAME = 'SNDZN3_INCR' ,& - DIMS = MAPL_DimsTileOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - _VERIFY(STATUS) - - call MAPL_TimerAdd(GC, name="Initialize" ,RC=STATUS) - _VERIFY(STATUS) - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) - _VERIFY(STATUS) - - call MAPL_GenericSetServices ( GC, RC=STATUS ) - _VERIFY(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - !BOP - ! !INTERFACE: - subroutine Initialize(gc, import, export, clock, rc) - ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - type(MAPL_MetaComp), pointer :: MAPL=>null() - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - _VERIFY(status) - Iam = trim(comp_name) // "::Initialize" - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - _VERIFY(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Initialize") - - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - _VERIFY(status) - - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - _RETURN(ESMF_SUCCESS) - - end subroutine Initialize - - ! !IROTUINE: Finalize -- finalize method for LDAS GC - ! !INTERFACE: - subroutine Finalize(gc, import, export, clock, rc) - ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - !EOP - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - call ESMF_GridCompget(gc, name=comp_name, rc=status) - _VERIFY(status) - Iam = trim(comp_name) // "::Finalize" - - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - _VERIFY(status) - - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - -end module GEOS_ExportCatchIncrGridCompMod diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/adapt_types.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/adapt_types.F90 deleted file mode 100644 index 51d229b2..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/adapt_types.F90 +++ /dev/null @@ -1,51 +0,0 @@ - -module adapt_types - - ! definition of types for adaptive filtering - ! - ! reichle, 19 Jul 2007 - ! - ! ------------------------------------------------------------------- - - implicit none - - save - - ! everything is private by default unless made public - - private - - public :: adapt_misc_param_type - - ! ---------------------------------------------------------------------- - - type :: adapt_misc_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: gamma_P - real :: gamma_R - - real :: delta_P - real :: delta_R - - real :: beta_P - real :: beta_R - - real :: min_alpha_P - real :: max_alpha_P - - real :: min_alpha_R - real :: max_alpha_R - - end type adapt_misc_param_type - - ! ------------------------------------------------------------------- - -end module adapt_types - -! ======================== EOF =========================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/catch_bias_types.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/catch_bias_types.F90 deleted file mode 100644 index 91d8fd7f..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/catch_bias_types.F90 +++ /dev/null @@ -1,107 +0,0 @@ - -module catch_bias_types - - ! definition of bias types for Catchment land surface model - ! - ! reichle, 17 Oct 2005 - ! reichle+draper, 26 Mar 2013 - prep for separation of model and obs bias - ! reichle+draper, 28 Aug 2013 - added "obs_bias" type - ! - ! ------------------------------------------------------------------- - - use catch_constants, ONLY: & - N_snow => CATCH_N_SNOW, & - N_gt => CATCH_N_GT - - use catch_types, ONLY: & - cat_progn_type - - implicit none - - save - - ! everything is private by default unless made public - - private - - public :: cat_progn_int_type - public :: cat_bias_param_type - - public :: obs_bias_type - - ! ---------------------------------------------------------------------- - ! - ! *INTEGER* Catchment model prognostic variables - ! - ! THESE MUST MATCH THE "real" cat_progn TYPE IN catch_types.f90 - - type :: cat_progn_int_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer :: tc1 ! surface/canopy temperature - integer :: tc2 - integer :: tc4 - - integer :: qa1 ! specific humidity in canopy air - integer :: qa2 - integer :: qa4 - - integer :: capac ! canopy interception water - - integer :: catdef ! catchment deficit - integer :: rzexc ! root zone excess - integer :: srfexc ! surface excess - - integer, dimension(N_gt) :: ght ! ground heat content - - integer, dimension(N_snow) :: wesn ! snow water equivalent - integer, dimension(N_snow) :: htsn ! snow heat content - integer, dimension(N_snow) :: sndz ! snow depth - - end type cat_progn_int_type - - ! ----------------------------------------- - - type :: cat_bias_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type(cat_progn_type) :: tconst - type(cat_progn_type) :: trelax - - type(cat_progn_int_type) :: Nparam - - end type cat_bias_param_type - - ! ----------------------------------------- - - type :: obs_bias_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: bias ! observation bias - integer, dimension(2) :: tcount ! count for time since last obs [seconds] - ! at start of assim cycle, for each tile: - ! tcount(1) = time since most recent obs. - ! tcount(1) = time since 2nd most recent obs. - - end type obs_bias_type - - ! ------------------------------------------------------------------- - -end module catch_bias_types - -! ======================== EOF =========================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_adapt_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_adapt_routines.F90 deleted file mode 100644 index 3ef58389..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_adapt_routines.F90 +++ /dev/null @@ -1,1054 +0,0 @@ -! this file contains a collection of subroutines for adaptive features in the -! the Ensemble Kalman filter of the Catchment model off-line driver -! -! reichle, 14 Dec 2006 -! reichle, 1 Feb 2007 - major re-design for separate tuning of P and R -! reichle, 11 Apr 2007 - major re-design for run-time selection of adapt_type -! reichle, 27 Jun 2007 - new adapt_update_7, changed adapt_min/max -! reichle, 28 Jun 2007 - changed useless update_adapt_7 into update_adapt_8 -! reichle, 2 Jul 2007 - added spatial avg of innov stats (update_adapt_9) -! reichle, 3 Jul 2007 - added empirical factor to increase alpha_P (update_adapt_10) -! reichle, 19 Jul 2007 - clean up, add "adapt_misc_param", keep only update_adapt_10 -! reichle, 24 Aug 2007 - added update_adapt_12 -! reichle, 16 Jun 2011 - updated for new "obs_type" fields - COULD HAVE ADDED BUGS!!! -! reichle, 21 Nov 2014 - renamed force_pert_type fields for consistency w/ met_force_type -! %tmp2m --> %tair (but note lower-case!) -! %dpt2m --> %qair (but note lower-case!) -! %wnd --> %wind (but note lower-case!) - -module clsm_adapt_routines - - use LDAS_ensdrv_globals, ONLY: & - logit, & - logunit - - use LDAS_DateTimeMod, ONLY: & - date_time_type - - use catch_types, ONLY: & - cat_progn_type - - use force_and_cat_progn_pert_types, ONLY: & - force_pert_real_type - - use LDAS_pertTypes, ONLY: & - pert_param_type - - use enkf_types, ONLY: & - obs_type, & - obs_param_type - - use LDAS_tilecoordtype, ONLY: & - tile_coord_type, & - grid_def_type - - use adapt_types, ONLY: & - adapt_misc_param_type - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - use LDAS_TilecoordRoutines, ONLY: & - grid2tile - - use LDAS_exceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - private - - public :: get_adapt_param - public :: apply_adapt_P - public :: apply_adapt_R - public :: io_adapt_5 - public :: update_adapt_10 - public :: update_adapt_12 - -contains - - ! *********************************************************************** - - subroutine read_adapt_inputs( work_path, exp_id, date_time, & - adapt_type, adapt_misc_param, adapt_progn_pert, adapt_force_pert ) - - ! read adapt inputs from nml file - - implicit none - - character(200), intent(in) :: work_path - character(40), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(out) :: adapt_type - - type(adapt_misc_param_type), intent(out) :: adapt_misc_param - - type(cat_progn_type), intent(out) :: adapt_progn_pert - type(force_pert_real_type), intent(out) :: adapt_force_pert - - ! local variables - - character(200) :: adapt_inputs_path - character( 40) :: adapt_inputs_file, dir_name, file_tag, file_ext - - character(300) :: fname - - logical :: file_exists - - ! ----------------------------------------- - - namelist / adapt_inputs / & - adapt_type, adapt_misc_param, adapt_progn_pert, adapt_force_pert - - ! --------------------------------------------------------------------- - ! - ! Set default file name for driver inputs namelist file - - adapt_inputs_path = './' ! set default - adapt_inputs_file = 'LDASsa_DEFAULT_inputs_adapt.nml' - - ! Read data from default adapt_inputs namelist file - - fname = trim(adapt_inputs_path) // '/' // trim(adapt_inputs_file) - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *default* adapt inputs from ', trim(fname) - if (logit) write (logunit,*) - - read (10, nml=adapt_inputs) - - close(10,status='keep') - - - ! Read from special adapt inputs file (if present) - - adapt_inputs_file = 'LDASsa_SPECIAL_inputs_adapt.nml' - - ! Read data from special adapt_inputs namelist file - - fname = trim(adapt_inputs_path) // '/' // trim(adapt_inputs_file) - - inquire(file=fname, exist=file_exists) - - if (file_exists) then - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *special* adapt inputs from ', trim(fname) - if (logit) write (logunit,*) - - read (10, nml=adapt_inputs) - - close(10,status='keep') - - end if - - ! echo variables of adapt_inputs - - if (logit) write (logunit,*) 'adapt inputs are:' - if (logit) write (logunit,*) - if (logit) write (logunit, nml=adapt_inputs) - if (logit) write (logunit,*) - - ! ------------------------------------------------------------- - ! - ! save adapt inputs into *adapt_inputs.nml file - - dir_name = 'rc_out' - file_tag = 'ldas_adapt_inputs' - file_ext = '.nml' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - if (logit) write (logunit,*) 'writing adapt inputs to ', trim(fname) - - open (10, file=fname, status='unknown', action='write', delim='apostrophe') - - write(10, nml=adapt_inputs) - - close(10, status='keep') - - end subroutine read_adapt_inputs - - ! ----------------------------------------------------------------- - - subroutine get_adapt_progn_pert_param( N_progn_pert, & - progn_pert_param, adapt_progn_pert, progn_pert_adapt_param ) - - ! transform adapt_progn_pert from nml into progn_pert_adapt_param - - implicit none - - integer, intent(in) :: N_progn_pert - - type(pert_param_type), dimension(N_progn_pert), intent(in) :: & - progn_pert_param - - type(cat_progn_type), intent(in) :: adapt_progn_pert - - integer, dimension(N_progn_pert), intent(out) :: progn_pert_adapt_param - - ! local variables - - integer :: m - - character(len=*), parameter :: Iam = 'get_adapt_progn_pert_param' - character(len=400) :: err_msg - - ! ------------------------------------------------------ - - do m=1,N_progn_pert - - select case (trim(progn_pert_param(m)%descr)) - - case ('tc1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%tc1 - case ('tc2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%tc2 - case ('tc4' ) - progn_pert_adapt_param(m) = adapt_progn_pert%tc4 - case ('qa1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%qa1 - case ('qa2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%qa2 - case ('qa4' ) - progn_pert_adapt_param(m) = adapt_progn_pert%qa4 - case ('capac' ) - progn_pert_adapt_param(m) = adapt_progn_pert%capac - case ('catdef') - progn_pert_adapt_param(m) = adapt_progn_pert%catdef - case ('rzexc' ) - progn_pert_adapt_param(m) = adapt_progn_pert%rzexc - case ('srfexc') - progn_pert_adapt_param(m) = adapt_progn_pert%srfexc - case ('ght1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(1) - case ('ght2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(2) - case ('ght3' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(3) - case ('ght4' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(4) - case ('ght5' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(5) - case ('ght6' ) - progn_pert_adapt_param(m) = adapt_progn_pert%ght(6) - case ('wesn1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%wesn(1) - case ('wesn2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%wesn(2) - case ('wesn3' ) - progn_pert_adapt_param(m) = adapt_progn_pert%wesn(3) - case ('htsn1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%htsn(1) - case ('htsn2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%htsn(2) - case ('htsn3' ) - progn_pert_adapt_param(m) = adapt_progn_pert%htsn(3) - case ('sndz1' ) - progn_pert_adapt_param(m) = adapt_progn_pert%sndz(1) - case ('sndz2' ) - progn_pert_adapt_param(m) = adapt_progn_pert%sndz(2) - case ('sndz3' ) - progn_pert_adapt_param(m) = adapt_progn_pert%sndz(3) - - case default - - err_msg = 'unknown progn_pert_param%descr = ' & - // trim(progn_pert_param(m)%descr) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end do - - end subroutine get_adapt_progn_pert_param - - ! ----------------------------------------------------------------------- - - subroutine get_adapt_force_pert_param( N_force_pert, & - force_pert_param, adapt_force_pert, force_pert_adapt_param ) - - ! transform adapt_force_pert from nml into force_pert_adapt_param - - implicit none - - integer, intent(in) :: N_force_pert - - type(pert_param_type), dimension(N_force_pert), intent(in) :: & - force_pert_param - - type(force_pert_real_type), intent(in) :: adapt_force_pert - - integer, dimension(N_force_pert), intent(out) :: force_pert_adapt_param - - ! local variables - - integer :: m - - character(len=*), parameter :: Iam = 'get_adapt_force_pert_param' - character(len=400) :: err_msg - - ! ------------------------------------------------------ - - do m=1,N_force_pert - - select case (trim(force_pert_param(m)%descr)) - - case ('pcp' ) - force_pert_adapt_param(m) = adapt_force_pert%pcp - case ('sw' ) - force_pert_adapt_param(m) = adapt_force_pert%sw - case ('lw' ) - force_pert_adapt_param(m) = adapt_force_pert%lw - case ('tair' ) - force_pert_adapt_param(m) = adapt_force_pert%tair - case ('qair' ) - force_pert_adapt_param(m) = adapt_force_pert%qair - case ('wind' ) - force_pert_adapt_param(m) = adapt_force_pert%wind - - case default - - err_msg = 'unknown force_pert_param%descr = ' & - // trim(force_pert_param(m)%descr) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end do - - end subroutine get_adapt_force_pert_param - - ! ----------------------------------------------------------------------- - - subroutine get_adapt_obs_pert_param( N_obs_param, obs_param, obs_pert_adapt_param ) - - ! map between first dimension of Pert_adapt_R and obs_param - - implicit none - - integer, intent(in) :: N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - integer, dimension(N_obs_param), intent(out) :: obs_pert_adapt_param - - ! local variables - - integer :: i, n - - ! ------------------------------------------------------- - - i = 0 - - do n=1,N_obs_param - - if (obs_param(n)%assim) then - - i = i+1 - - obs_pert_adapt_param(n) = i - - else - - obs_pert_adapt_param(n) = -9999 - - end if - - end do - - end subroutine get_adapt_obs_pert_param - - ! ----------------------------------------------------------------------- - - subroutine get_adapt_param( work_path, exp_id, date_time, & - N_progn_pert, N_force_pert, N_obs_param, & - progn_pert_param, force_pert_param, obs_param, & - adapt_type, adapt_misc_param, N_adapt_P, N_adapt_R, & - progn_pert_adapt_param, force_pert_adapt_param, obs_pert_adapt_param ) - - implicit none - - character(200), intent(in) :: work_path - character(40), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_progn_pert, N_force_pert, N_obs_param - - type(pert_param_type), dimension(N_progn_pert), intent(in) :: progn_pert_param - type(pert_param_type), dimension(N_force_pert), intent(in) :: force_pert_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - integer, intent(out) :: adapt_type, N_adapt_P, N_adapt_R - - type(adapt_misc_param_type), intent(out) :: adapt_misc_param - - integer, dimension(N_progn_pert), intent(out) :: progn_pert_adapt_param - integer, dimension(N_force_pert), intent(out) :: force_pert_adapt_param - - integer, dimension(N_obs_param), intent(out) :: obs_pert_adapt_param - - ! local variables - - integer :: n - - type(cat_progn_type) :: adapt_progn_pert - type(force_pert_real_type) :: adapt_force_pert - - ! ------------------------------------------------------- - - ! get adapt params from nml - - call read_adapt_inputs( work_path, exp_id, date_time, & - adapt_type, adapt_misc_param, adapt_progn_pert, adapt_force_pert ) - - ! initialize N_adapt_P and N_adapt_R - - N_adapt_P = 0 - N_adapt_R = 0 - - if (adapt_type>0) then - - ! get N_adapt_P and N_adapt_R from obs_param - - do n=1,N_obs_param - - N_adapt_P = max( N_adapt_P, obs_param(n)%adapt ) - - if (obs_param(n)%assim) N_adapt_R = N_adapt_R + 1 - - end do - - ! IMPORTANT: overwrite N_adapt_R for some cases of adapt_type - - select case (adapt_type) - - case (3,12) - - N_adapt_R = 0 - - end select - - ! set up progn_pert_adapt_param - - call get_adapt_progn_pert_param( N_progn_pert, & - progn_pert_param, adapt_progn_pert, progn_pert_adapt_param ) - - ! set up force_pert_adapt_param - - call get_adapt_force_pert_param( N_force_pert, & - force_pert_param, adapt_force_pert, force_pert_adapt_param ) - - ! set up obs_pert_adapt_param - - call get_adapt_obs_pert_param( N_obs_param, obs_param, obs_pert_adapt_param ) - - end if - - end subroutine get_adapt_param - - ! ----------------------------------------------------------------------- - - subroutine io_adapt_5( adapt_tag, action, work_path, exp_id, date_time, & - N_adapt, N_catd, N_obs_param, obs_param, & - Pert_adapt_MA_XmXxOmB, Pert_adapt_MA_X, Pert_adapt ) - - ! read/initialize or write Pert_adapt - ! - ! adapt_tag = 'P' (adapting state err cov...) - ! adapt_tag = 'R' (adapting obs err cov...) - ! - ! action_tag = 'r' or 'R' (read) - ! action_tag = 'w' or 'W' (write) - ! - ! reichle, 15 Dec 2006 - ! reichle, 1 Feb 2007 - modified for separate tuning of P and R - - implicit none - - character, intent(in) :: adapt_tag - - character, intent(in) :: action ! read ('r') or write ('w') - - character(200), intent(in) :: work_path - character(40), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_adapt, N_catd, N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - real, dimension(N_adapt,N_catd), intent(inout) :: Pert_adapt_MA_XmXxOmB - real, dimension(N_adapt,N_catd), intent(inout) :: Pert_adapt_MA_X - real, dimension(N_adapt,N_catd), intent(inout) :: Pert_adapt - - ! local variables - - character(40), parameter :: file_tag = 'adapt' - - character( 40) :: tmp_file_tag, dir_name='rs', file_ext='.bin' - character(300) :: fname - - integer :: n, k, istat - - logical :: tmp_write_action - - character(len=*), parameter :: Iam = 'io_adapt_5' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - tmp_write_action = .false. - - if (adapt_tag=='P') then - tmp_file_tag = 'adaptP_ldas_rst' - elseif (adapt_tag=='R') then - tmp_file_tag = 'adaptR_ldas_rst' - else - - err_msg = 'unknown adapt_tag=' // adapt_tag - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - fname = get_io_filename( work_path, exp_id, tmp_file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext) - - if ( action=='r' .or. action=='R') then - - open(10, file=fname, form='unformatted', status='old', & - action='read', iostat=istat) - - if (istat==0) then - - if (logit) write (logunit,*) 'Reading Pert_adapt file ', trim(fname) - - do k=1,N_adapt - - read (10) (Pert_adapt(k,n), n=1,N_catd) - - end do - - do k=1,N_adapt - - read (10) (Pert_adapt_MA_XmXxOmB(k,n), n=1,N_catd) - - end do - - do k=1,N_adapt - - read (10) (Pert_adapt_MA_X(k,n), n=1,N_catd) - - end do - - close(10, status='keep') - - else - - ! initialize and set "write" flag - - if (logit) write (logunit,*) 'Initializing Pert_adapt=1.' - - Pert_adapt = 1. - - do n=1,N_obs_param - - if (obs_param(n)%assim) then - - k=obs_param(n)%adapt - - Pert_adapt_MA_XmXxOmB(k,:) = obs_param(n)%errstd**2 - Pert_adapt_MA_X( k,:) = obs_param(n)%errstd**2 - - end if - - end do - - tmp_write_action = .true. - - end if - - end if - - if ( action=='w' .or. action=='W' .or. tmp_write_action ) then - - open(10,file=fname,form='unformatted',status='unknown',action='write') - - if (logit) write (logunit,*) 'Writing Pert_adapt file ', trim(fname) - - do k=1,N_adapt - - write (10) (Pert_adapt(k,n), n=1,N_catd) - - end do - - do k=1,N_adapt - - write (10) (Pert_adapt_MA_XmXxOmB(k,n), n=1,N_catd) - - end do - - do k=1,N_adapt - - write (10) (Pert_adapt_MA_X(k,n), n=1,N_catd) - - end do - - close (10,status='keep') - - end if - - if ( action/='w' .and. action/='W' .and. & - action/='r' .and. action/='R' ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown action') - - end if - - end subroutine io_adapt_5 - - ! ----------------------------------------------------------------------- - - subroutine update_adapt_10( N_obs_param, obs_param, N_obs, N_catd, Observations, & - obs_pert_adapt_param, N_adapt_P, N_adapt_R, adapt_misc_param, & - Pert_adapt_MA_AmBxOmB, Pert_adapt_MA_HPHt, Pert_adapt_P, & - Pert_adapt_MA_OmAxOmB, Pert_adapt_MA_R, Pert_adapt_R ) - - ! reichle, 8 Feb 2007 - use tuning of Desroziers et al, QJR Met Soc, 2005 - ! based on temporal avg of AmBxOmB divided by - ! temporal avg of HPHt etc - ! reichle, 27 Jun 2007 - correct design flaw in update_adapt_5 - ! (temporarily named update_adapt_7) - ! reichle, 28 Jun 2007 - renamed update_adapt_8, introduced damping parameter delta - ! reichle, 3 Jul 2007 - same as A0008 but with additional - ! reduction of tmp_real by empirical factor - ! reichle, 6 Jul 2007 - corrected lower bound of tmp_real to 1./(1.+delta) - - implicit none - - integer, intent(in) :: N_obs_param, N_obs, N_catd, N_adapt_P, N_adapt_R - - type(obs_param_type), dimension(N_obs_param), intent(in) :: & - obs_param - - type(adapt_misc_param_type), intent(in) :: adapt_misc_param - - type(obs_type), dimension(N_obs), intent(in) :: Observations - - integer, dimension(N_obs_param), intent(in) :: obs_pert_adapt_param - - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_MA_AmBxOmB - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_MA_HPHt - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_P - real, dimension(N_adapt_R,N_catd), intent(inout) :: Pert_adapt_MA_OmAxOmB - real, dimension(N_adapt_R,N_catd), intent(inout) :: Pert_adapt_MA_R - real, dimension(N_adapt_R,N_catd), intent(inout) :: Pert_adapt_R - - ! local variables - - integer :: n, k, m - - real :: HPHt, AminusB, OminusF, OminusA, tmp_real - - !!!!real, parameter :: beta = 1.06 - !!!!real, parameter :: delta = 0.005 - - !!!!real, parameter :: w_P = adapt_innov_weight_P - !!!!real, parameter :: one_minus_w_P = 1 - w_P - - !!!!real, parameter :: w_R = adapt_innov_weight_R - !!!!real, parameter :: one_minus_w_R = 1 - w_R - - real :: w_P, one_minus_w_P, w_R, one_minus_w_R - - ! ----------------------------------------------------------------- - - w_P = adapt_misc_param%gamma_P - one_minus_w_P = 1. - w_P - - w_R = adapt_misc_param%gamma_R - one_minus_w_R = 1. - w_R - - - do n=1,N_obs - - if (Observations(n)%assim) then - - m = Observations(n)%tilenum - - ! --------------------- - ! - ! update Pert_adapt_P: - - k = obs_param( Observations(n)%species )%adapt - - ! compute analysis minus background (in obs space) - - AminusB = Observations(n)%ana - Observations(n)%fcst - - OminusF = Observations(n)%obs - Observations(n)%fcst - - OminusA = Observations(n)%obs - Observations(n)%ana - - ! compute expected HPHt - - HPHt = Observations(n)%fcstvar - - ! moving average - - Pert_adapt_MA_AmBxOmB(k,m) = & - one_minus_w_P*Pert_adapt_MA_AmBxOmB(k,m) + & - w_P*(AminusB*OminusF) - - Pert_adapt_MA_HPHt(k,m) = & - one_minus_w_P*Pert_adapt_MA_HPHt(k,m) + & - w_P*HPHt - - ! update Pert_adapt_P (omit whenever moving avg of HPHt<=0.) - - if (Pert_adapt_MA_HPHt(k,m)>0.) then - - tmp_real = Pert_adapt_MA_AmBxOmB(k,m)/Pert_adapt_MA_HPHt(k,m) - - ! -------------------------------------------------------------- - ! - ! multiply with empirical factor - ! A0008 tends to produce alphas that are too small in all cases - - tmp_real = tmp_real*adapt_misc_param%beta_P !!!!!!!!!!!! - - ! -------------------------------------------------------------- - - tmp_real = max(tmp_real,1./(1.+adapt_misc_param%delta_P)) - tmp_real = min(tmp_real,1.+adapt_misc_param%delta_P) - - Pert_adapt_P(k,m) = Pert_adapt_P(k,m)*tmp_real - - end if - - ! ensure adapt_min_P <= Pert_adapt <= adapt_max_P - - Pert_adapt_P(k,m) = & - max( min( Pert_adapt_P(k,m), adapt_misc_param%max_alpha_P), & - adapt_misc_param%min_alpha_P ) - - ! --------------------- - ! - ! update Pert_adapt_R: - - k = obs_pert_adapt_param( Observations(n)%species ) - - ! moving average - - Pert_adapt_MA_OmAxOmB(k,m) = & - one_minus_w_R*Pert_adapt_MA_OmAxOmB(k,m) + & - w_R*(OminusA*OminusF) - - Pert_adapt_MA_R(k,m) = & - one_minus_w_R*Pert_adapt_MA_R(k,m) + & - w_R*(Observations(n)%obsvar) - - ! update Pert_adapt_R (omit whenever moving avg of R<=0.) - - if (Pert_adapt_MA_R(k,m)>0.) then - - tmp_real = Pert_adapt_MA_OmAxOmB(k,m)/Pert_adapt_MA_R(k,m) - - tmp_real = max(tmp_real,1./(1.+adapt_misc_param%delta_R)) - tmp_real = min(tmp_real,1.+adapt_misc_param%delta_R) - - Pert_adapt_R(k,m) = Pert_adapt_R(k,m)*tmp_real - - end if - - ! ensure adapt_min_R <= Pert_adapt <= adapt_max_R - - Pert_adapt_R(k,m) = & - max( min( Pert_adapt_R(k,m), adapt_misc_param%max_alpha_R), & - adapt_misc_param%min_alpha_R ) - - end if - - end do - - end subroutine update_adapt_10 - - ! --------------------------------------------------------------------------- - - subroutine update_adapt_12( N_obs_param, obs_param, N_obs, N_catd, Observations, & - N_adapt_P, adapt_misc_param, & - Pert_adapt_MA_AmBxOmB, Pert_adapt_MA_HPHt, Pert_adapt_P ) - - ! reichle,24 Aug 2007 - same as update_adapt_10 but for Pert_adapt_P *only* - - implicit none - - integer, intent(in) :: N_obs_param, N_obs, N_catd, N_adapt_P - - type(obs_param_type), dimension(N_obs_param), intent(in) :: & - obs_param - - type(adapt_misc_param_type), intent(in) :: adapt_misc_param - - type(obs_type), dimension(N_obs), intent(in) :: Observations - - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_MA_AmBxOmB - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_MA_HPHt - real, dimension(N_adapt_P,N_catd), intent(inout) :: Pert_adapt_P - - ! local variables - - integer :: n, k, m - - real :: HPHt, AminusB, OminusF, OminusA, tmp_real - - real :: w_P, one_minus_w_P - - ! ----------------------------------------------------------------- - - w_P = adapt_misc_param%gamma_P - one_minus_w_P = 1. - w_P - - do n=1,N_obs - - if (Observations(n)%assim) then - - m = Observations(n)%tilenum - - ! --------------------- - ! - ! update Pert_adapt_P: - - k = obs_param( Observations(n)%species )%adapt - - ! compute analysis minus background (in obs space) - - AminusB = Observations(n)%ana - Observations(n)%fcst - - OminusF = Observations(n)%obs - Observations(n)%fcst - - OminusA = Observations(n)%obs - Observations(n)%ana - - ! compute expected HPHt - - HPHt = Observations(n)%fcstvar - - ! moving average - - Pert_adapt_MA_AmBxOmB(k,m) = & - one_minus_w_P*Pert_adapt_MA_AmBxOmB(k,m) + & - w_P*(AminusB*OminusF) - - Pert_adapt_MA_HPHt(k,m) = & - one_minus_w_P*Pert_adapt_MA_HPHt(k,m) + & - w_P*HPHt - - ! update Pert_adapt_P (omit whenever moving avg of HPHt<=0.) - - if (Pert_adapt_MA_HPHt(k,m)>0.) then - - tmp_real = Pert_adapt_MA_AmBxOmB(k,m)/Pert_adapt_MA_HPHt(k,m) - - ! -------------------------------------------------------------- - ! - ! multiply with empirical factor - ! A0008 tends to produce alphas that are too small in all cases - - tmp_real = tmp_real*adapt_misc_param%beta_P !!!!!!!!!!!! - - ! -------------------------------------------------------------- - - tmp_real = max(tmp_real,1./(1.+adapt_misc_param%delta_P)) - tmp_real = min(tmp_real,1.+adapt_misc_param%delta_P) - - Pert_adapt_P(k,m) = Pert_adapt_P(k,m)*tmp_real - - end if - - ! ensure adapt_min_P <= Pert_adapt <= adapt_max_P - - Pert_adapt_P(k,m) = & - max( min( Pert_adapt_P(k,m), adapt_misc_param%max_alpha_P), & - adapt_misc_param%min_alpha_P ) - - - end if - - end do - - end subroutine update_adapt_12 - - ! --------------------------------------------------------------------------- - - subroutine apply_adapt_P( N_pert, pert_param, pert_adapt_param, & - N_adapt_P, N_catd, Pert_adapt_P, pert_grid, tile_coord, N_ens, Pert_tile ) - - ! re-scale "Force_pert" or "Progn_pert" based on Pert_adapt_P - ! (pert_param() never changes, ie. "Force_pert" and "Progn_pert" - ! are computed with fixed nml inputs for perturbations parameters) - ! - ! reichle, 15 Dec 2006 - ! - ! reichle, 19 Dec 2006 - empirical rule: - ! apply adapt using *square* of Pert_adapt, because - ! doubling of std_pert does *not* lead to - ! doubling of sqrt(HPHt) - ! reichle, 28 Jun 2007 - deleted empirical rule (RedArk_adapt A0007 did not work) - - implicit none - - integer, intent(in) :: N_pert, N_adapt_P, N_catd, N_ens - - type(pert_param_type), dimension(N_pert), intent(in) :: pert_param - - integer, dimension(N_pert), intent(in) :: pert_adapt_param - - real, dimension(N_adapt_P,N_catd) :: Pert_adapt_P - - type(grid_def_type) :: pert_grid - - type(tile_coord_type), dimension(:), pointer :: tile_coord - - real, dimension(N_pert,N_catd,N_ens) :: Pert_tile - - ! local variables - - integer :: n, m, k, j - - real, dimension(N_catd) :: mu, sg - - real :: s_square, tmp_x, tmp_mu, tmp_sg, tmp_real - - character(len=*), parameter :: Iam = 'apply_adapt_P' - character(len=400) :: err_msg - - ! ----------------------------------------------- - - do n=1,N_pert - - j = pert_adapt_param(n) - - if (j>0) then - - ! get mean and std in tile space - - call grid2tile( pert_grid, N_catd, tile_coord%pert_i_indg,tile_coord%pert_j_indg, & !tile_coord, & - pert_param(n)%mean, mu ) - - call grid2tile( pert_grid, N_catd, tile_coord%pert_i_indg,tile_coord%pert_j_indg, & !tile_coord, & - pert_param(n)%std, sg ) - - select case (pert_param(n)%typ) - - case (0) ! additive - - do k=1,N_catd - do m=1,N_ens - - !Pert_tile(n,k,m) = & - ! Pert_adapt_P(j,k)*(Pert_tile(n,k,m)-mu(k)) + mu(k) - - Pert_tile(n,k,m) = & - sqrt(Pert_adapt_P(j,k))*(Pert_tile(n,k,m)-mu(k)) + mu(k) - - end do - end do - - case (1) ! multiplicative and lognormal (mean=1) - - do k=1,N_catd - do m=1,N_ens - - ! compute new lognormal parameters mean and std (tmp_mu, - ! tmp_sg) instead of scaling Pert_tile - ! tmp_x = original std_normal perturbation that - ! was used to compute Pert_tile - ! s_square = original variance of Pert_tile - - s_square = exp(-2.*mu(k)) - 1. - - tmp_x = (log(Pert_tile(n,k,m)) - mu(k))/sg(k) - - tmp_real = log(1+Pert_adapt_P(j,k)*s_square) - !tmp_real = log(1+(Pert_adapt_P(j,k)**2)*s_square) - - tmp_mu = -.5*tmp_real - - tmp_sg = sqrt(tmp_real); - - Pert_tile(n,k,m) = exp( tmp_mu + tmp_sg*tmp_x ); - - end do - end do - - case default - - err_msg = 'unknown typ of perturbation' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end if - - end do - - end subroutine apply_adapt_P - - ! --------------------------------------------------------------------- - - subroutine apply_adapt_R( N_obs, N_obs_param, obs_pert_adapt_param, & - N_adapt_R, N_catd, Pert_adapt_R, Observations ) - - ! reichle, 1 Feb 2007 - - implicit none - - integer, intent(in) :: N_obs, N_obs_param, N_adapt_R, N_catd - - integer, dimension(N_obs_param), intent(in) :: obs_pert_adapt_param - - real, dimension(N_adapt_R,N_catd) :: Pert_adapt_R - - type(obs_type), dimension(N_obs), intent(inout) :: Observations - - ! local variables - - integer :: n, k, j - - ! ----------------------------------------------- - - do n=1,N_obs - - j = obs_pert_adapt_param(Observations(n)%species) - k = Observations(n)%tilenum - - ! THE FOLLOWING LINE WAS CHANGED WHEN OBS_TYPE FIELDS WERE REVISED - ! - ! NOT SURE WHETHER THE REVISED LINE IS OK - ! - ! REICHLE - 16 JUNE 2011 - - ! Observations(n)%errstd = sqrt(Pert_adapt_R(j,k))*Observations(n)%errstd - - Observations(n)%obsvar = Pert_adapt_R(j,k)*Observations(n)%obsvar - - end do - - end subroutine apply_adapt_R - - ! ----------------------------------------------------------------------- - -end module clsm_adapt_routines - -! ====================== EOF ============================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_bias_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_bias_routines.F90 deleted file mode 100644 index bee99863..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_bias_routines.F90 +++ /dev/null @@ -1,1713 +0,0 @@ -! this file contains a collection of bias subroutines for the -! the Ensemble Kalman filter of the Catchment model off-line driver -! -! reichle, 17 Oct 2005 -! draper+reichle, 28 Aug 2013 - added obs bias routines -! draper+reichle, 19 Sep 2013 - revised obs bias routines - -module clsm_bias_routines - - use catch_constants, ONLY: & - N_snow => CATCH_N_SNOW, & - N_gt => CATCH_N_GT - - use LDAS_ensdrv_globals, ONLY: & - nodata_generic, & - logit, & - logunit - - use LDAS_DateTimeMod, ONLY: & - date_time_type - - use catch_types, ONLY: & - cat_progn_type, & - assignment (=) - - use enkf_types, ONLY: & - obs_type, & - obs_param_type - - use catch_bias_types, ONLY: & - cat_bias_param_type, & - obs_bias_type - - use LDAS_ensdrv_mpi, ONLY: & - root_proc, & - MPI_obs_bias_type, & - mpicomm, & - MPIERR - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - use clsm_ensupd_upd_routines, ONLY: & - get_cat_progn_ens_avg - - use LDAS_exceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - private - - public :: io_rstrt_cat_bias - public :: read_cat_bias_inputs - public :: init_cat_bias - public :: cat_bias_corr - public :: cat_bias_calcs_update - - public :: io_rstrt_obs_bias - public :: init_obs_bias - public :: obs_bias_upd_tcount - public :: obs_bias_upd_bias_and_Obs - public :: obs_bias_corr_obs - public :: output_obs_bias - public :: initialize_obs_bias - - integer, parameter :: max_tcount = 86400*365 ! ~1 year - -contains - - ! ------------------------------------------------------------------- - ! - ! CAT BIAS ROUTINES - ! - ! ------------------------------------------------------------------- - - subroutine io_rstrt_cat_bias( action, work_path, exp_id, date_time, & - model_dtstep, N_cat, N_catbias, cat_bias ) - - ! read or write cat bias re-start file. - ! - ! bias restart file contains all time-invariant and time-varying bias - ! parameters - ! - ! reichle, 18 Oct 2005 - ! reichle+draper, 27 Mar 2013 - revised cat_bias structure - - implicit none - - character, intent(in) :: action ! read or write - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: model_dtstep, N_cat, N_catbias - - type(cat_progn_type), dimension(N_cat,N_catbias), intent(inout) :: cat_bias - - ! local variables - - integer :: j, k, n, model_dtstep_tmp, N_cat_tmp, N_catbias_tmp - - character(300) :: filename - - character(40) :: file_tag='catbias_ldas_rst', dir_name='rs', file_ext='.bin' - - character(len=*), parameter :: Iam = 'io_rstrt_cat_bias' - - ! -------------------------------------------------------------------- - - select case (action) - - case ('r','R') - - filename = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - if (logit) write (logunit,*) 'Reading bias restart file ', trim(filename) - - open(10, file=filename, form='unformatted', status='old', & - action='read') - - read (10) model_dtstep_tmp, N_cat_tmp, N_catbias_tmp - - if ( model_dtstep_tmp /= model_dtstep ) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'inconsistent model_dtstep') - end if - - if ( N_cat_tmp /= N_cat ) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'inconsistent num of tiles') - end if - - if ( N_catbias_tmp /= N_catbias ) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'inconsistent N_catbias') - end if - - do j=1,N_catbias - - read (10) (cat_bias(n,j)%tc1, n=1,N_cat) - read (10) (cat_bias(n,j)%tc2, n=1,N_cat) - read (10) (cat_bias(n,j)%tc4, n=1,N_cat) - - read (10) (cat_bias(n,j)%qa1, n=1,N_cat) - read (10) (cat_bias(n,j)%qa2, n=1,N_cat) - read (10) (cat_bias(n,j)%qa4, n=1,N_cat) - - read (10) (cat_bias(n,j)%capac, n=1,N_cat) - - read (10) (cat_bias(n,j)%catdef, n=1,N_cat) - read (10) (cat_bias(n,j)%rzexc, n=1,N_cat) - read (10) (cat_bias(n,j)%srfexc, n=1,N_cat) - - do k=1,N_gt - read (10) (cat_bias(n,j)%ght(k), n=1,N_cat) - end do - - do k=1,N_snow - read (10) (cat_bias(n,j)%wesn(k), n=1,N_cat) - end do - do k=1,N_snow - read (10) (cat_bias(n,j)%htsn(k), n=1,N_cat) - end do - do k=1,N_snow - read (10) (cat_bias(n,j)%sndz(k), n=1,N_cat) - end do - - end do - - - case ('w','W') - - filename = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - if (logit) write (logunit,*) 'Writing bias restart file ', trim(filename) - - open(10, file=filename, form='unformatted', status='unknown', & - action='write') - - ! write header - - write (10) model_dtstep, N_cat, N_catbias - - ! write bias estimate - - do j=1,N_catbias - - write (10) (cat_bias(n,j)%tc1, n=1,N_cat) - write (10) (cat_bias(n,j)%tc2, n=1,N_cat) - write (10) (cat_bias(n,j)%tc4, n=1,N_cat) - - write (10) (cat_bias(n,j)%qa1, n=1,N_cat) - write (10) (cat_bias(n,j)%qa2, n=1,N_cat) - write (10) (cat_bias(n,j)%qa4, n=1,N_cat) - - write (10) (cat_bias(n,j)%capac, n=1,N_cat) - - write (10) (cat_bias(n,j)%catdef, n=1,N_cat) - write (10) (cat_bias(n,j)%rzexc, n=1,N_cat) - write (10) (cat_bias(n,j)%srfexc, n=1,N_cat) - - do k=1,N_gt - write (10) (cat_bias(n,j)%ght(k), n=1,N_cat) - end do - - do k=1,N_snow - write (10) (cat_bias(n,j)%wesn(k), n=1,N_cat) - end do - do k=1,N_snow - write (10) (cat_bias(n,j)%htsn(k), n=1,N_cat) - end do - do k=1,N_snow - write (10) (cat_bias(n,j)%sndz(k), n=1,N_cat) - end do - - end do - - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown action') - - end select - - close (10,status='keep') - - end subroutine io_rstrt_cat_bias - - ! ************************************************************* - - subroutine init_cat_bias( & - work_path, exp_id, date_time, model_dtstep, N_cat, N_catbias, & - cat_bias ) - - ! reichle, 18 Oct 2005 - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: model_dtstep, N_cat, N_catbias - - type(cat_progn_type), dimension(N_cat,N_catbias), intent(out) :: cat_bias - - ! local variables - - character(300) :: fname - - integer :: j, n - logical :: fexists - - character(40) :: file_tag = 'catbias_ldas_rst' - character(40) :: dir_name = 'rs' - character(40) :: file_ext = '.bin' - - ! ------------------------------------------------------------- - - ! try reading from restart file - - fname = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - inquire(file=fname, exist=fexists) - - if (fexists) then - - ! read bias restart file - - call io_rstrt_cat_bias( & - 'r', work_path, exp_id, date_time, model_dtstep, N_cat, N_catbias, & - cat_bias) - - else - - if (logit) then - write (logunit,*) 'init_cat_bias(): restart file not found ', trim(fname) - write (logunit,*) ' initializing cat_bias to zero' - end if - - do n=1,N_cat - - do j=1,N_catbias - - cat_bias(n,j) = 0. - - end do - - end do - - end if - - end subroutine init_cat_bias - - ! ******************************************************************** - - subroutine check_cat_bias_inputs( update_type, cat_bias_param ) - - ! Check cat bias param inputs against update_type: - ! Make sure that the increments that are needed for bias estimation - ! are computed with the selected "update_type". - ! - ! reichle, 19 Oct 2005 - ! reichle, 11 Jan 2006 - - implicit none - - integer, intent(in) :: update_type - - type(cat_bias_param_type), intent(in) :: cat_bias_param - - ! locals - - character(10) :: update_type_string - - character(len=*), parameter :: Iam = 'check_cat_bias_inputs' - character(len=400) :: err_msg - - ! ------------------------ - - write(update_type_string,'(i10)') update_type - - select_update_type: select case (update_type) - - case (1,2) - - if ( & - (cat_bias_param%Nparam%tc1>0) .or. & - (cat_bias_param%Nparam%tc2>0) .or. & - (cat_bias_param%Nparam%tc4>0) .or. & - !(cat_bias_param%Nparam%srfexc>0) .or. & - !(cat_bias_param%Nparam%rzexc >0) .or. & - !(cat_bias_param%Nparam%catdef>0) .or. & - (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac>0) .or. & - any(cat_bias_param%Nparam%ght(:) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'no increments computed for requested bias corr' // & - 'variables (update_type = ' // trim(update_type_string) // ')' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - else - - err_msg = 'untested bias corr requested for srfexc/rzexc/catdef' // & - ' - are you sure? If yes, disable this abort and start over.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - case (3) - - if ( & - !(cat_bias_param%Nparam%tc1>0) .or. & - !(cat_bias_param%Nparam%tc2>0) .or. & - !(cat_bias_param%Nparam%tc4>0) .or. & - (cat_bias_param%Nparam%srfexc>0) .or. & - (cat_bias_param%Nparam%rzexc >0) .or. & - (cat_bias_param%Nparam%catdef>0) .or. & - (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac>0) .or. & - any(cat_bias_param%Nparam%ght(:) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'no increments computed for requested bias corr ' // & - 'variables (update_type = ' // trim(update_type_string) // ')' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - case (4,5,7,9) - - if ( & - !(cat_bias_param%Nparam%tc1>0) .or. & - !(cat_bias_param%Nparam%tc2>0) .or. & - !(cat_bias_param%Nparam%tc4>0) .or. & - (cat_bias_param%Nparam%srfexc>0) .or. & - (cat_bias_param%Nparam%rzexc >0) .or. & - (cat_bias_param%Nparam%catdef>0) .or. & - (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac>0) .or. & - !any(cat_bias_param%Nparam%ght(:) >0) .or. & - any(cat_bias_param%Nparam%ght(2:N_gt) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'no increments computed for requested bias corr ' // & - 'variables (update_type = ' // trim(update_type_string) // ')' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - case (6,8) - - if ( & - !(cat_bias_param%Nparam%tc1>0) .or. & - !(cat_bias_param%Nparam%tc2>0) .or. & - !(cat_bias_param%Nparam%tc4>0) .or. & - !(cat_bias_param%Nparam%srfexc>0) .or. & - !(cat_bias_param%Nparam%rzexc >0) .or. & - !(cat_bias_param%Nparam%catdef>0) .or. & - (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac>0) .or. & - !any(cat_bias_param%Nparam%ght(:) >0) .or. & - any(cat_bias_param%Nparam%ght(2:N_gt) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'no increments computed for requested bias corr ' // & - 'variables (update_type = ' // trim(update_type_string) // ')' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - case (10) - - ! For PEATCLSM tiles, update_type 10 may have non-zero catdef increments, - ! but catdef increments still vanish for non-PEATCLSM tiles. - ! Leaving code here unchanged for now, that is, cannot request bias - ! corr for catdef. - reichle, 20 Feb 2022 - - if ( & - !(cat_bias_param%Nparam%tc1>0) .or. & - !(cat_bias_param%Nparam%tc2>0) .or. & - !(cat_bias_param%Nparam%tc4>0) .or. & - !(cat_bias_param%Nparam%srfexc>0) .or. & - !(cat_bias_param%Nparam%rzexc >0) .or. & - (cat_bias_param%Nparam%catdef>0) .or. & - (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac>0) .or. & - !any(cat_bias_param%Nparam%ght(:) >0) .or. & - any(cat_bias_param%Nparam%ght(2:N_gt) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'no increments computed for requested bias corr ' // & - 'variables (update_type = ' // trim(update_type_string) // ')' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown update_type') - - end select select_update_type - - end subroutine check_cat_bias_inputs - - ! ******************************************************************** - - subroutine read_cat_bias_inputs( work_path, exp_id, date_time, & - update_type, cat_bias_param, N_catbias ) - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: update_type - - type(cat_bias_param_type), intent(out) :: cat_bias_param - - integer, intent(out) :: N_catbias - - ! ----------- - - character(300) :: fname - character(200) :: cat_bias_inputs_path - character( 40) :: cat_bias_inputs_file, dir_name, file_tag, file_ext - - logical :: file_exist - - ! ------------------------------------------------------------------- - - namelist /cat_bias_inputs/ & - cat_bias_param - - ! ------------------------------------------------------------------- - - ! read default cat bias inputs file - - cat_bias_inputs_path = './' ! set default - cat_bias_inputs_file = 'LDASsa_DEFAULT_inputs_catbias.nml' - - fname = trim(cat_bias_inputs_path) // '/' // trim(cat_bias_inputs_file) - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *default* cat bias inputs from ' // trim(fname) - if (logit) write (logunit,*) - - read (10, nml=cat_bias_inputs) - - close(10,status='keep') - - - ! Read from special cat bias inputs file (if present) - - cat_bias_inputs_file = 'LDASsa_SPECIAL_inputs_catbias.nml' - - ! Read data from special cat bias inputs namelist file - - fname = trim(cat_bias_inputs_path)//'/'//trim(cat_bias_inputs_file) - - inquire(file=fname, exist=file_exist) - - if (file_exist) then - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *special* cat bias inputs from ' // trim(fname) - if (logit) write (logunit,*) - - read (10, nml=cat_bias_inputs) - - close(10,status='keep') - - end if - - ! diagnose N_catbias = max(cat_bias_param%Nparam) - - N_catbias = 0 - - N_catbias = max( N_catbias, cat_bias_param%Nparam%tc1 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%tc2 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%tc4 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%srfexc ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%rzexc ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%catdef ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%qa1 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%qa2 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%qa4 ) - N_catbias = max( N_catbias, cat_bias_param%Nparam%capac ) - N_catbias = max( N_catbias, maxval(cat_bias_param%Nparam%ght ) ) - N_catbias = max( N_catbias, maxval(cat_bias_param%Nparam%wesn ) ) - N_catbias = max( N_catbias, maxval(cat_bias_param%Nparam%htsn ) ) - N_catbias = max( N_catbias, maxval(cat_bias_param%Nparam%sndz ) ) - - - ! check for consistency with update_type - - if (N_catbias>0) call check_cat_bias_inputs( update_type, cat_bias_param ) - - - ! ------------------------------------------------------------- - ! - ! echo variables of namelist cat_bias_inputs - - if (logit) write (logunit,*) 'cat bias inputs are:' - if (logit) write (logunit,*) - if (logit) write (logunit, nml=cat_bias_inputs) - if (logit) write (logunit,*) - - ! ------------------------------------------------------------- - ! - ! save cat bias inputs into *catbias_inputs.nml file - - dir_name = 'rc_out' - file_tag = 'ldas_catbias_inputs' - file_ext = '.nml' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') 'writing cat bias inputs to ' // trim(fname) - - open (10, file=fname, status='unknown', action='write', delim='apostrophe') - - write(10, nml=cat_bias_inputs) - - close(10, status='keep') - - end subroutine read_cat_bias_inputs - - ! ******************************************************************** - - !subroutine cat_bias_calcs_corr( ) - - ! This subroutine was a wrapper for subroutine cat_bias_corr() with - ! an added call to subroutine recompute_diagnostics(). - ! The call to recompute_diagnostics() has been moved, making the wrapper - ! obsolete - ! -reichle+csdraper, 30 Oct 2013 - - !end subroutine cat_bias_calcs_corr - - ! ******************************************************************** - - subroutine cat_bias_calcs_update( date_time, model_dtstep_real, & - N_cat, N_ens, N_catbias, cat_progn_incr, fresh_incr, cat_bias_param, & - cat_bias ) - - implicit none - - type(date_time_type), intent(in) :: date_time - - real, intent(in) :: model_dtstep_real - integer, intent(in) :: N_cat, N_ens, N_catbias - - type(cat_progn_type), dimension(N_cat,N_ens), intent(in) :: cat_progn_incr - - logical, intent(in) :: fresh_incr - - type(cat_bias_param_type), intent(in) :: cat_bias_param - - type(cat_progn_type), dimension(N_cat,N_catbias), intent(inout) :: cat_bias - - ! local variables - - type(cat_progn_type), dimension(N_cat) :: cat_progn_incr_vec - - ! -------------------------------------------------------------- - - if (fresh_incr) then - - ! update bias parameters from ensemble average increments - - call get_cat_progn_ens_avg(N_cat, N_ens, cat_progn_incr, & - cat_progn_incr_vec) - - call cat_bias_update(date_time, model_dtstep_real, N_cat, & - N_catbias, cat_progn_incr_vec, cat_bias_param, cat_bias ) - - end if - - end subroutine cat_bias_calcs_update - - ! ******************************************************************** - - subroutine cat_bias_corr( date_time, dtstep, N_cat, N_ens, & - N_catbias, cat_bias_param, cat_bias, cat_progn ) - - ! apply bias correction to cat_progn, relax bias parameters) - ! - ! - ! reichle, 19 Oct 2005 - - implicit none - - type(date_time_type), intent(in) :: date_time - - real, intent(in) :: dtstep - integer, intent(in) :: N_cat, N_ens, N_catbias - - type(cat_bias_param_type), intent(in) :: cat_bias_param - - type(cat_progn_type), dimension(N_cat,N_catbias), intent(inout) :: cat_bias - type(cat_progn_type), dimension(N_cat,N_ens), intent(inout) :: cat_progn - - ! local variables - - integer :: n - - real, dimension(N_catbias) :: const_param - - character(len=*), parameter :: Iam = 'cat_bias_corr' - character(len=400) :: err_msg - - ! ----------------------------------------------------------- - - call bias_get_const_param( date_time, N_catbias, const_param ) - - do n=1,N_cat - - ! tc1, tc2, tc4 - - if (cat_bias_param%Nparam%tc1>0) & - call bias_corr_helper( date_time, dtstep, N_ens, cat_bias_param%Nparam%tc1, & - const_param, cat_bias_param%trelax%tc1, cat_progn(n,:)%tc1, & - cat_bias(n,1:cat_bias_param%Nparam%tc1)%tc1 ) - - if (cat_bias_param%Nparam%tc2>0) & - call bias_corr_helper( date_time, dtstep, N_ens, cat_bias_param%Nparam%tc2, & - const_param, cat_bias_param%trelax%tc2, cat_progn(n,:)%tc2, & - cat_bias(n,1:cat_bias_param%Nparam%tc2)%tc2 ) - - if (cat_bias_param%Nparam%tc4>0) & - call bias_corr_helper( date_time, dtstep, N_ens, cat_bias_param%Nparam%tc4, & - const_param, cat_bias_param%trelax%tc4, cat_progn(n,:)%tc4, & - cat_bias(n,1:cat_bias_param%Nparam%tc4)%tc4 ) - - if (cat_bias_param%Nparam%ght(1)>0) & - call bias_corr_helper( date_time, dtstep, N_ens, cat_bias_param%Nparam%ght(1), & - const_param, cat_bias_param%trelax%ght(1), cat_progn(n,:)%ght(1), & - cat_bias(n,1:cat_bias_param%Nparam%ght(1))%ght(1) ) - - - if ( (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac >0) .or. & - (cat_bias_param%Nparam%srfexc>0) .or. & - (cat_bias_param%Nparam%rzexc >0) .or. & - (cat_bias_param%Nparam%catdef>0) .or. & - any(cat_bias_param%Nparam%ght(2:N_gt) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'must add fields to source code' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end do - - end subroutine cat_bias_corr - - ! ******************************************************************** - - subroutine bias_corr_helper( date_time, dtstep, N_ens, Nparam, & - const_param, trelax, cat_progn_field, bias_param ) - - implicit none - - ! diagnose/apply bias flux and relax bias parameters for a single - ! tile and a single field of cat_progn - ! - ! reichle, 17 Oct 2005 - ! - ! reichle, 18 Aug 2008 -- added new "time-of-day" bias option - - type(date_time_type), intent(in) :: date_time - - real, intent(in) :: dtstep, trelax - - integer, intent(in) :: N_ens, Nparam - - real, dimension(Nparam), intent(in) :: const_param - - real, dimension(N_ens), intent(inout) :: cat_progn_field - - real, dimension(Nparam), intent(inout) :: bias_param - - ! local variables - - real :: tmpflux, relax_fac - - integer :: i, ind_start, ind_end - - real, dimension(Nparam) :: const_param_tmp - - ! ----------------------------------------------------------------- - - if (Nparam > 0) then - - call bias_options_helper( date_time, Nparam, const_param, & - ind_start, ind_end, const_param_tmp ) - - ! diagnose bias flux from bias parameters - - tmpflux = 0. - - do i=ind_start,ind_end - - tmpflux = tmpflux + bias_param(i)*const_param_tmp(i) - - end do - - ! apply bias flux - - cat_progn_field(:) = cat_progn_field(:) - tmpflux*dtstep - - ! relax bias parameters - - relax_fac = (1. - dtstep/trelax) - - do i=ind_start,ind_end - - bias_param(i) = bias_param(i) * relax_fac - - end do - - end if - - end subroutine bias_corr_helper - - ! ******************************************************************** - - subroutine cat_bias_update( date_time, dtstep, & - N_cat, N_catbias, cat_progn_incr, cat_bias_param, & - cat_bias) - - ! update bias parameters from ens avg assimilation increments - ! - ! reichle, 19 Oct 2005 - - implicit none - - type(date_time_type), intent(in) :: date_time - - real, intent(in) :: dtstep - integer, intent(in) :: N_cat, N_catbias - - type(cat_progn_type), dimension(N_cat), intent(in) :: cat_progn_incr - - type(cat_bias_param_type), intent(in) :: cat_bias_param - - type(cat_progn_type), dimension(N_cat,N_catbias), intent(inout) :: cat_bias - - ! local variables - - integer :: n - - real, dimension(N_catbias) :: const_param - - character(len=*), parameter :: Iam = 'cat_bias_update' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - call bias_get_const_param( date_time, N_catbias, const_param ) - - do n=1,N_cat - - ! tc1, tc2, tc4 - - if (cat_bias_param%Nparam%tc1>0) & - call bias_update_helper(date_time, dtstep, cat_bias_param%Nparam%tc1, & - const_param, cat_bias_param%tconst%tc1, cat_progn_incr(n)%tc1, & - cat_bias(n,1:cat_bias_param%Nparam%tc1)%tc1 ) - - if (cat_bias_param%Nparam%tc2>0) & - call bias_update_helper(date_time, dtstep, cat_bias_param%Nparam%tc2, & - const_param, cat_bias_param%tconst%tc2, cat_progn_incr(n)%tc2, & - cat_bias(n,1:cat_bias_param%Nparam%tc2)%tc2 ) - - if (cat_bias_param%Nparam%tc4>0) & - call bias_update_helper(date_time, dtstep, cat_bias_param%Nparam%tc4, & - const_param, cat_bias_param%tconst%tc4, cat_progn_incr(n)%tc4, & - cat_bias(n,1:cat_bias_param%Nparam%tc4)%tc4 ) - - if (cat_bias_param%Nparam%ght(1)>0) & - call bias_update_helper(date_time, dtstep, cat_bias_param%Nparam%ght(1), & - const_param, cat_bias_param%tconst%ght(1), cat_progn_incr(n)%ght(1), & - cat_bias(n,1:cat_bias_param%Nparam%ght(1))%ght(1) ) - - if ( (cat_bias_param%Nparam%qa1 >0) .or. & - (cat_bias_param%Nparam%qa2 >0) .or. & - (cat_bias_param%Nparam%qa4 >0) .or. & - (cat_bias_param%Nparam%capac >0) .or. & - (cat_bias_param%Nparam%srfexc>0) .or. & - (cat_bias_param%Nparam%rzexc >0) .or. & - (cat_bias_param%Nparam%catdef>0) .or. & - any(cat_bias_param%Nparam%ght(2:N_gt) >0) .or. & - any(cat_bias_param%Nparam%wesn(:)>0) .or. & - any(cat_bias_param%Nparam%htsn(:)>0) .or. & - any(cat_bias_param%Nparam%sndz(:)>0) ) then - - err_msg = 'must add fields to source code' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end do - - - end subroutine cat_bias_update - - ! ******************************************************************** - - subroutine bias_update_helper( date_time, dtstep, Nparam, const_param, tconst, & - increment, bias_param ) - - implicit none - - ! update bias parameters for a single tile and a single field of cat_progn - ! - ! reichle, 17 Oct 2005 - ! - ! reichle, 18 Aug 2008 -- added new "time-of-day" bias option - - type(date_time_type), intent(in) :: date_time - - real, intent(in) :: dtstep, tconst, increment - - integer, intent(in) :: Nparam - - real, dimension(Nparam), intent(in) :: const_param - - real, dimension(Nparam), intent(inout) :: bias_param - - ! local variables - - real, dimension(Nparam) :: const_param_tmp - - real :: tmp_real - - integer :: i, ind_start, ind_end - - ! ------------------------------------------------------------- - - if (Nparam > 0) then - - call bias_options_helper( date_time, Nparam, const_param, & - ind_start, ind_end, const_param_tmp ) - - ! update bias parameters - - tmp_real = - tconst * increment / dtstep - - do i=ind_start,ind_end - - bias_param(i) = bias_param(i) + tmp_real*const_param_tmp(i) - - end do - - end if - - end subroutine bias_update_helper - - ! *************************************************************************** - - subroutine bias_options_helper( date_time, Nparam, const_param_in, & - ind_start, ind_end, const_param_out ) - - implicit none - - type(date_time_type), intent(in) :: date_time - integer, intent(in) :: Nparam - real, dimension(Nparam), intent(in) :: const_param_in - - integer, intent(out) :: ind_start, ind_end - real, dimension(Nparam), intent(out) :: const_param_out - - ! local variables - - !integer :: bias_time_of_day_index - - ! ------------------------------------------------------------- - - select case (Nparam) - - case (1,3,5) ! constant or sine/cosine (semi-)diurnal bias corr - - ind_start = 1 - ind_end = Nparam - - const_param_out = const_param_in - - case (2,4,8) ! separate "time-of-day" bias correction - - ind_start = bias_time_of_day_index( date_time, Nparam ) - ind_end = ind_start - - const_param_out = 1. - - case default - - write (*,*) 'bias_options_helper(): unknown Nparam = ', Nparam - - end select - - end subroutine bias_options_helper - - ! ************************************************************************* - - subroutine bias_get_const_param( date_time, N_const, const_param ) - - ! compute time-of-day dependent sine/cosine variables for bias calculations - ! - ! reichle, 18 Aug 2008 - - implicit none - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_const - - real, dimension(N_const), intent(out) :: const_param - - ! local variables - - real, parameter :: MY_PI = 3.14159265 - - real, parameter :: omega1 = 2.*MY_PI/86400. - real, parameter :: omega2 = 2.*MY_PI/43200. - - real :: secs_in_day, om1_t, om2_t - - ! ------------------------------------------------------------------ - - const_param = nodata_generic - - secs_in_day = real(date_time%hour)*3600. + real(date_time%min)*60. & - + real(date_time%sec) - - om1_t = secs_in_day*omega1 - om2_t = secs_in_day*omega2 - - - if (N_const>=1) const_param(1) = 1. - - if (N_const>=3) then - - const_param(2) = cos(om1_t) - const_param(3) = sin(om1_t) - - end if - - if (N_const>=5) then - - const_param(4) = cos(om2_t) - const_param(5) = sin(om2_t) - - end if - - end subroutine bias_get_const_param - - ! ------------------------------------------------------------------- - ! - ! OBS BIAS ROUTINES - ! - ! ------------------------------------------------------------------- - - subroutine initialize_obs_bias( N_catf, N_obs_param, N_obsbias_max, work_path, & - exp_id, date_time, N_catl, numprocs, N_catl_vec, low_ind, obs_bias) - - ! initialize obs_bias for use with observations bias corrections, - ! and handle mpi - ! - ! draper, Aug 29 2013. - - implicit none - - integer, intent(in) :: N_catf, N_obs_param - integer, intent(in) :: N_obsbias_max - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - integer, intent(in) :: N_catl, numprocs - integer, intent(in), dimension(numprocs) :: N_catl_vec, low_ind - - type(obs_bias_type), intent(inout), dimension(N_catl,N_obs_param,N_obsbias_max) :: & - obs_bias - - !local variables - - type(obs_bias_type), dimension(:,:,:), allocatable :: obs_bias_f - - integer :: i,j - - ! ------------------------------------------------------------------ - - if (root_proc) then - - allocate(obs_bias_f(N_catf,N_obs_param,N_obsbias_max)) - - call init_obs_bias( & - work_path, exp_id, date_time, N_catf, N_obs_param, N_obsbias_max, & - obs_bias_f ) - - end if - -#ifdef LDAS_MPI - - do i=1,N_obs_param - do j=1,N_obsbias_max - - call MPI_SCATTERV( & - obs_bias_f(:,i,j), N_catl_vec, low_ind-1, MPI_obs_bias_type, & - obs_bias( :,i,j), N_catl, MPI_obs_bias_type, & - 0, mpicomm, mpierr ) - - end do - end do - -#else - - obs_bias = obs_bias_f - -#endif - - if (root_proc) deallocate(obs_bias_f) - - end subroutine initialize_obs_bias - - ! ************************************************************************* - - subroutine init_obs_bias( & - work_path, exp_id, date_time, N_cat, N_obs_param, N_obsbias_max, & - obs_bias ) - - ! draper, 4 April 2013 - ! based on init_cat_bias - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_cat, N_obs_param,N_obsbias_max - - type(obs_bias_type), intent(out), dimension(N_cat,N_obs_param,N_obsbias_max) :: & - obs_bias - - ! local variables - - character(300) :: fname - - logical :: fexists - - character(40) :: file_tag = 'obsbias_ldas_rst' - character(40) :: dir_name = 'rs' - character(40) :: file_ext = '.bin' - - ! ------------------------------------------------------------- - - ! try reading from restart file - - fname = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - inquire(file=fname, exist=fexists) - - if (fexists) then - - ! read bias restart file - - call io_rstrt_obs_bias('r', work_path, exp_id, date_time, & - N_cat, N_obs_param, N_obsbias_max, obs_bias ) - - else - - if (logit) then - write (logunit,*) 'init_obs_bias(): restart file not found ', trim(fname) - end if - - obs_bias(:,:,:)%bias = 0.0 - - obs_bias(:,:,:)%tcount(1) = max_tcount - obs_bias(:,:,:)%tcount(2) = max_tcount - - end if - - end subroutine init_obs_bias - - ! ******************************************************************** - - subroutine io_rstrt_obs_bias( action, work_path, exp_id, date_time, & - N_cat, N_obs_param, N_obsbias_max, obs_bias ) - - ! read or write obs bias re-start file. - ! - ! bias restart file contains all time-invariant and time-varying bias - ! parameters - ! - ! reichle, 18 Oct 2005 - ! reichle+draper, 27 Mar 2013 - revised cat_bias structure - - implicit none - - character, intent(in) :: action ! read or write - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_cat, N_obs_param, N_obsbias_max - - type(obs_bias_type), intent(inout), dimension(N_cat,N_obs_param,N_obsbias_max) :: & - obs_bias - - ! local variables - - integer :: i, j, k, n, N_cat_tmp, N_obs_param_tmp, N_obsbias_max_tmp - - character(300) :: filename - - character(40) :: file_tag='obsbias_ldas_rst', dir_name='rs', file_ext='.bin' - - character(len=*), parameter :: Iam = 'io_rstrt_obs_bias' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - select case (action) - - case ('r','R') - - filename = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - if (logit) write (logunit,*) 'Reading obs bias restart file ', trim(filename) - - open(10, file=filename, form='unformatted', status='old', & - action='read') - - read (10) N_cat_tmp, N_obs_param_tmp, N_obsbias_max_tmp - - if ( N_cat_tmp /= N_cat ) then - err_msg = 'inconsistent number of tiles' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if ( N_obs_param_tmp /= N_obs_param ) then - err_msg = 'inconsistent N_obs_param' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if ( N_obsbias_max_tmp /= N_obsbias_max ) then - err_msg = 'inconsistent N_catbias' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - do j=1,N_obsbias_max - do i=1,N_obs_param - - read (10) (obs_bias(n,i,j)%bias, n=1,N_cat) - - do k=1,2 - read (10) (obs_bias(n,i,j)%tcount(k), n=1,N_cat) - end do - - end do - end do - - case ('w','W') - - filename = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, file_ext=file_ext ) - - if (logit) write (logunit,*) 'Writing obs bias restart file ', trim(filename) - - open(10, file=filename, form='unformatted', status='unknown', & - action='write') - - ! write header - - write (10) N_cat, N_obs_param, N_obsbias_max - - do j=1,N_obsbias_max - do i=1,N_obs_param - - write (10) (obs_bias(n,i,j)%bias, n=1,N_cat) - - do k=1,2 - write (10) (obs_bias(n,i,j)%tcount(k), n=1,N_cat) - end do - - end do - end do - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown action') - - end select - - close (10,status='keep') - - end subroutine io_rstrt_obs_bias - - ! ******************************************************************** - - subroutine output_obs_bias(N_obs_param, N_obsbias_max, N_catl, N_catf, & - numprocs, N_catl_vec, low_ind, work_path, exp_id, date_time, obs_bias) - - ! output the obs_bias restarts - ! - ! draper, Aug 29 2013 - - implicit none - - integer, intent(in) :: N_obs_param, N_obsbias_max - integer, intent(in) :: N_catl, N_catf, numprocs - - integer, intent(in), dimension(numprocs) :: N_catl_vec, low_ind - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - type(date_time_type), intent(in) :: date_time - - type(obs_bias_type), intent(in), dimension(N_catl,N_obs_param,N_obsbias_max) :: & - obs_bias - - ! local variables - - type(obs_bias_type), dimension(:,:,:), allocatable :: obs_bias_f - - integer :: i,j - - if (root_proc) allocate(obs_bias_f(N_catf,N_obs_param, N_obsbias_max)) - -#ifdef LDAS_MPI - - do i=1,N_obs_param - do j=1,N_obsbias_max - - call MPI_GATHERV( & - obs_bias(:,i,j), N_catl, MPI_obs_bias_type, & - obs_bias_f( :,i,j), N_catl_vec, low_ind-1, MPI_obs_bias_type, & - 0, mpicomm, mpierr ) - - end do - end do - - call MPI_BARRIER( mpicomm, mpierr ) - -#else - - obs_bias_f = obs_bias - -#endif - - if (root_proc) then - - call io_rstrt_obs_bias( & - 'w', work_path, exp_id, date_time, N_catf, & - N_obs_param, N_obsbias_max, obs_bias_f ) - - deallocate(obs_bias_f) - - end if - - end subroutine output_obs_bias - - ! ******************************************************************** - - subroutine obs_bias_corr_obs(date_time, N_catl, N_catf, N_obsl, N_obs_param, & - N_obsbias_max, f2l, obs_param, obs_bias, Observations, obsbias_ok) - - ! correct observations to remove the obs_bias (obs = obs minus obs_bias) - ! set obsbias_ok flag to indicate whether have confidence in obs_bias estimate - - ! draper, Apr 2013. - - implicit none - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catl, N_catf, N_obsl - integer, intent(in) :: N_obs_param - integer, intent(in) :: N_obsbias_max - - integer, intent(in), dimension(N_catf) :: f2l - - type(obs_param_type), intent(in), dimension(N_obs_param) :: obs_param - - type(obs_bias_type), intent(in), dimension(N_catl, N_obs_param, N_obsbias_max) :: & - obs_bias - - type(obs_type), intent(inout), dimension(N_obsl) :: Observations - - logical, intent(inout), dimension(N_obsl) :: obsbias_ok - - ! local variables - - integer :: i, ind_catl, ind_spec, tcount2 - - integer, dimension(N_obs_param) :: indv_time - - ! ---------------------------------------------------------- - - ! get species-dependent time of day index - - do i=1,N_obs_param - - indv_time(i)=bias_time_of_day_index( date_time,obs_param(i)%bias_Npar ) - - end do - - do i=1,N_obsl - - ind_spec = Observations(i)%species - - if (obs_param(ind_spec)%bias_Npar > 0) then - - ind_catl = f2l(Observations(i)%tilenum) - - ! correct Observation(i) for bias - - Observations(i)%obs = ( & - Observations(i)%obs - & - obs_bias(ind_catl, ind_spec, indv_time(ind_spec))%bias ) - - if (Observations(i)%assim) then - - ! determine of obs bias correction is good enough for use of - ! obs in state update - - tcount2 = obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%tcount(2) - - if ( tcount2 < obs_param(ind_spec)%bias_tcut ) then - - ! obsbias is good, keep assim flag true, set obsbias_ok - - obsbias_ok(i) = .TRUE. - - else - - ! obsbias is not good: switch assim flag to false, leave obsbias_ok as is - - Observations(i)%assim = .FALSE. - - end if - - end if - - end if - - end do - - end subroutine obs_bias_corr_obs - - ! ******************************************************************** - - subroutine obs_bias_upd_bias_and_Obs( & - date_time, N_catl, N_catf, N_obs, & - N_ens, N_obs_param, N_obsbias_max, f2l, obs_param, & - Obs_pred, obs_bias, Observations ) - - ! calculate the bias increment, and use to update obs_bias and the Observations - ! - ! delta_b = b+ - b_= lambda(y - - b-) - ! - ! lambda = 1 - exp( -Delta_time_since_last_ob/trelax ) - ! - ! draper+reichle, Sep 2013. - - implicit none - - ! ----------------------------------------------------------- - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catl, N_catf - integer, intent(in) :: N_obs, N_ens - integer, intent(in) :: N_obs_param - integer, intent(in) :: N_obsbias_max - - integer, intent(in), dimension(N_catf) :: f2l - - type(obs_param_type), intent(in), dimension(N_obs_param) :: obs_param - - real, intent(in), dimension(N_obs, N_ens) :: Obs_pred - - type(obs_bias_type), intent(inout), dimension(N_catl, N_obs_param, N_obsbias_max) :: & - obs_bias - - type(obs_type), intent(inout), dimension(N_obs) :: Observations - - ! local variables - - real :: lambda, bias_incr - - integer :: i, ind_catl, ind_spec, tcount1, trel - - integer, dimension(N_obs_param) :: indv_time - - ! --------------------------------------------------------------------- - - ! get species-dependent time of day index - - do i=1,N_obs_param - - indv_time(i) = bias_time_of_day_index( date_time, obs_param(i)%bias_Npar ) - - end do - - ! update obs_bias - - do i=1,N_obs - - ind_spec = Observations(i)%species - - if (obs_param(ind_spec)%bias_Npar > 0) then - - ind_catl = f2l(Observations(i)%tilenum) - - tcount1 = obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%tcount(1) - - trel = obs_param(ind_spec)%bias_trel - - lambda = (1. - exp(-real(tcount1)/real(trel))) - - ! get the bias increment - - bias_incr = & - lambda*(Observations(i)%obs - sum(Obs_pred(i,1:N_ens))/real(N_ens)) - - ! update the bias with the bias increment - - obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%bias = & - obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%bias + bias_incr - - ! update the obs with the bias increment - - Observations(i)%obs = Observations(i)%obs - bias_incr - - end if - - end do - - end subroutine obs_bias_upd_bias_and_Obs - - ! ******************************************************************** - - subroutine obs_bias_upd_tcount(date_time, dtstep, N_catf, N_catl, N_Obs, & - N_obs_param, N_obsbias_max, f2l, obs_param, Observations, obs_bias ) - ! - ! update counter recording the time since the last two observations - ! (times are relevant at start of next assim cycle) - ! - ! draper, apr 2013 - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep - integer, intent(in) :: N_catf, N_catl, N_obs - integer, intent(in) :: N_obs_param, N_obsbias_max - - integer, intent(in), dimension(N_catf) :: f2l - - type(obs_param_type), intent(in), dimension(N_obs_param) :: obs_param - type(obs_type), intent(in), dimension(N_obs) :: Observations - - type(obs_bias_type), intent(inout), dimension(N_catl, N_obs_param, N_obsbias_max) :: & - obs_bias - - ! local variables - - integer :: ind_catl, ind_spec, i, j, k, t - integer, dimension(N_obs_param) :: indv_time - - ! ------------------------------------------------------------------ - ! - ! add tstep to tcount - - do i=1,N_catl - do j=1,N_obs_param - do k=1,obs_param(j)%bias_Npar - do t=1,2 - - obs_bias(i,j,k)%tcount(t) = & - min( obs_bias(i,j,k)%tcount(t)+dtstep, max_tcount ) - - end do - end do - end do - end do - - ! shift bias tcounts if had an observation - - do i=1, N_obs_param - indv_time(i)=bias_time_of_day_index( date_time,obs_param(i)%bias_Npar ) - end do - - do i=1, N_obs - - ind_spec=Observations(i)%species - - if (obs_param(ind_spec)%bias_Npar > 0) then - - ind_catl = f2l(Observations(i)%tilenum) - - ! tcount(2) = tcount(1) - - obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%tcount(2) = & - obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%tcount(1) - - ! reinitialize tcount(1) - - obs_bias(ind_catl,ind_spec,indv_time(ind_spec))%tcount(1) = dtstep - - end if - - end do - - end subroutine obs_bias_upd_tcount - - ! ------------------------------------------------------------------- - ! - ! SHARED (OBS/CAT BIAS) ROUTINES - ! - !------------------------------------------------------------------- - - integer function bias_time_of_day_index( date_time, Nparam ) - - implicit none - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: Nparam - - ! local variables - - integer :: tmpint, dtstep_tmp - - ! ----------------------------------------------- - - dtstep_tmp = 86400/Nparam - - ! seconds-in-day - - tmpint = date_time%hour*3600 + date_time%min*60 + date_time%sec - - ! add half of dtstep_assim (to center interval around nominal time) - - tmpint = tmpint + dtstep_tmp/2 - - ! modulus calculation (yields tmpint ranging from 1 to N+1) - - tmpint = tmpint/dtstep_tmp + 1 - - ! fix "N+1" with another modulus calculation - - bias_time_of_day_index = mod( tmpint-1, 86400/dtstep_tmp) + 1 - - end function bias_time_of_day_index - - ! ****************************************************************************** - -end module clsm_bias_routines - -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- - -! test programs - -#if 0 - -program test_bias_time_helper - - ! ifort date_time_util.o tmp.F90 - - use date_time_util - use leap_year - - implicit none - - type(date_time_type) :: date_time - - integer :: dtstep_assim(5), time_ind_bias, dtstep, n, k, tmpintvec(5), ttt - - real, dimension(8) :: const_param - - date_time%year = 2008 - date_time%month = 8 - date_time%day = 18 - date_time%hour = 20 - date_time%min = 0 - date_time%sec = 0 - - dtstep_assim(1) = 86400 - dtstep_assim(2) = 43200 - dtstep_assim(3) = 21600 - dtstep_assim(4) = 10800 - dtstep_assim(5) = 3600 - - dtstep = 1200 - - do ttt=1,100 - - call augment_date_time(dtstep, date_time) - - do n=1,5 - - call bias_time_helper( date_time, dtstep_assim(n), & - const_param, time_ind_bias ) - - tmpintvec(n)=time_ind_bias - - end do - - write (*,'(7i5)') date_time%hour, date_time%min, tmpintvec(1:5) - write (999,'(7i5)') date_time%hour, date_time%min, tmpintvec(1:5) - - end do - -end program test_bias_time_helper - -#endif - -! ====================== EOF ============================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_drv_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_drv_routines.F90 deleted file mode 100644 index a5d417a6..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_drv_routines.F90 +++ /dev/null @@ -1,398 +0,0 @@ - - -module clsm_ensdrv_drv_routines - - ! collection of subroutines for enkf_driver written in f90 - ! reichle, 10 May 2005 - ! - ! reichle, 13 Aug 2008 - moved forcing subroutines into - ! clsm_ensdrv_force_routines.F90 - ! reichle, 28 Oct 2008 - added soilcls30 and soilcls100 - ! - optimized restart-to-exp-domain mapping in initialize_model() - ! reichle, 5 Apr 2013 - revised treatment of output collections - - use MAPL_ConstantsMod, ONLY: & - Tzero => MAPL_TICE - - use catch_constants, ONLY: & - N_snow => CATCH_N_SNOW, & - N_gt => CATCH_N_GT - - use catch_incr, ONLY: & - check_catch_progn - - use catch_types, ONLY: & - cat_param_type, & - cat_progn_type, & - cat_diagS_type, & - catprogn2wesn, & - catprogn2htsn, & - catprogn2sndz, & - catprogn2ghtcnt - - - use LDAS_ensdrv_mpi, ONLY: & - mpicomm, & - mpierr, & - numprocs - - use catchment_model, ONLY: & - catch_calc_tsurf - - use lsm_routines, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp - - use StieglitzSnow, ONLY: & - StieglitzSnow_calc_asnow, & - StieglitzSnow_calc_tpsnow - - - implicit none - - include 'mpif.h' - - private - - public :: check_cat_progn - public :: recompute_diagS - public :: l2f_real - public :: f2l_real - public :: f2l_real8 - public :: f2l_logical - - character(10), private :: tmpstring10 - character(40), private :: tmpstring40 - -contains - - ! ******************************************************************** - - subroutine check_cat_progn( check_snow, N_cat, cat_param, cat_progn ) - - ! wrapper for subroutine check_catch_progn() which has been - ! moved to "catch_iau.F90" in GEOScatch_GridComp - reichle, 3 Apr 2012 - - implicit none - - logical, intent(in) :: check_snow - - integer, intent(in) :: N_cat - - type(cat_param_type), dimension(N_cat), intent(in) :: cat_param - - type(cat_progn_type), dimension(N_cat), intent(inout) :: cat_progn - - ! ---------------------------------------------------------------- - - ! local variables - - integer :: k - - real, dimension(N_snow,N_cat) :: wesn - real, dimension(N_snow,N_cat) :: htsn - real, dimension(N_snow,N_cat) :: sndz - - real, dimension(N_gt, N_cat) :: ghtcnt - - ! ---------------------------------------------------------------- - - ! copy select cat_progn fields into 2-d arrays - - do k=1,N_gt - - GHTCNT(k,:) = cat_progn%ght(k) - - end do - - do k=1,N_snow - - WESN(k,:) = cat_progn%wesn(k) - HTSN(k,:) = cat_progn%htsn(k) - SNDZ(k,:) = cat_progn%sndz(k) - - end do - - ! check for consistency and unphysical values - - call check_catch_progn( N_cat, cat_param%dzsf, & - cat_param%vgwmax, cat_param%cdcr1, cat_param%cdcr2, & - cat_param%psis, cat_param%bee, cat_param%poros, cat_param%wpwet, & - cat_param%ars1, cat_param%ars2, cat_param%ars3, & - cat_param%ara1, cat_param%ara2, cat_param%ara3, cat_param%ara4, & - cat_param%arw1, cat_param%arw2, cat_param%arw3, cat_param%arw4, & - cat_param%bf1, cat_param%bf2, & - cat_progn%tc1, cat_progn%tc2, cat_progn%tc4, & - cat_progn%qa1, cat_progn%qa2, cat_progn%qa4, & - cat_progn%capac, cat_progn%catdef, & - cat_progn%rzexc, cat_progn%srfexc, & - ghtcnt, wesn, htsn, sndz, & - check_snow=check_snow) - - ! copy 2-d arrays back into cat_progn fields - - do k=1,N_gt - - cat_progn%ght(k) = ghtcnt(k,:) - - end do - - do k=1,N_snow - - cat_progn%wesn(k) = WESN(k,:) - cat_progn%htsn(k) = HTSN(k,:) - cat_progn%sndz(k) = SNDZ(k,:) - - end do - - end subroutine check_cat_progn - - ! ********************************************************************* - - subroutine recompute_diagS( N_catd, cat_param, cat_progn, cat_diagS ) - - ! replace cat_diagS with updated diagnostics - ! - ! typically called after prognostics perturbations, EnKF update, and/or cat - ! bias correction - ! - ! IMPORTANT: cat_progn is intent(inout) because srfexc, rzexc, and catdef - ! fields *might* be changed! Such changes can be prevented by first calling - ! subroutine check_cat_progn(). - ! - ! reichle, 20 Oct 2004 - ! reichle, 14 Feb 2013 - added recomputation of soil temperature - ! reichle, 30 Oct 2013 - moved from clsm_ensupd_upd_routines.F90 - ! - removed dependency on "update_type" - ! - added recompute of snow diagnostics - - integer, intent(in) :: N_catd - - ! note: cat_progn must be "inout" because call to calc_soil_moist - ! might reset inconsistent sets of srfexc, rzexc, catdef - - type(cat_param_type), dimension(N_catd), intent(in) :: cat_param - type(cat_progn_type), dimension(N_catd), intent(inout) :: cat_progn - type(cat_diagS_type), dimension(N_catd), intent(inout) :: cat_diagS - - ! local variables - - integer :: ii - - real, dimension( N_catd) :: ar4, fices - - real, dimension(N_gt,N_catd) :: tp - - ! ------------------------------------------------------------------ - - ! update soil moisture diagnostics - - ! note that the call to calc_soil_moist resets srfexc, rzexc, and - ! catdef if they are not consistent! - - ! updated to new interface - reichle, 3 Apr 2012 - - call catch_calc_soil_moist( & - N_catd, cat_param%dzsf, cat_param%vgwmax, & - cat_param%cdcr1, cat_param%cdcr2, cat_param%psis, & - cat_param%bee, cat_param%poros, cat_param%wpwet, & - cat_param%ars1, cat_param%ars2, cat_param%ars3, & - cat_param%ara1, cat_param%ara2, cat_param%ara3, & - cat_param%ara4, cat_param%arw1, cat_param%arw2, & - cat_param%arw3, cat_param%arw4, & - cat_param%bf1, cat_param%bf2, & - cat_progn%srfexc, cat_progn%rzexc, cat_progn%catdef, & - cat_diagS%ar1, cat_diagS%ar2, ar4, & - cat_diagS%sfmc, cat_diagS%rzmc, cat_diagS%prmc) - - - ! update snow cover fraction and snow temperatures - - call StieglitzSnow_calc_asnow( & - N_snow, N_catd, catprogn2wesn(N_catd,cat_progn), cat_diagS%asnow ) - - do ii=1,N_snow - - call StieglitzSnow_calc_tpsnow( N_catd, & - cat_progn(1:N_catd)%htsn(ii), & - cat_progn(1:N_catd)%wesn(ii), & - cat_diagS(1:N_catd)%tpsn(ii), & - fices ) - - cat_diagS%tpsn(ii) = cat_diagS%tpsn(ii) + Tzero ! convert to Kelvin - - end do - - ! update surface temperature - - ! updated to new interface, - ! need ar1, ar2, ar4 from call to catch_calc_soil_moist() above - ! - reichle, 3 Apr 2012 - - call catch_calc_tsurf( N_catd, & - cat_progn%tc1, cat_progn%tc2, cat_progn%tc4, & - catprogn2wesn(N_catd,cat_progn), & - catprogn2htsn(N_catd,cat_progn), & - cat_diagS%ar1, cat_diagS%ar2, ar4, & - cat_diagS%tsurf ) - - ! update soil temperature - - ! NOTE: "tp" is returned in CELSIUS [for consistency w/ catchment.F90] - - call catch_calc_tp( N_catd, cat_param%poros, & - catprogn2ghtcnt(N_catd,cat_progn), tp ) - - do ii=1,N_gt - - cat_diagS(:)%tp(ii) = tp(ii,:) - - end do - - end subroutine recompute_diagS - - ! ******************************************************************** - - subroutine l2f_real( N_l, N_f, N_l_vec, low_ind, data_l, data_f) - - ! wrapper for MPI_GATHERV applied to MPI_REAL vector - - ! reichle, 23 Dec 2011 - - implicit none - - integer, intent(in) :: N_l, N_f - integer, dimension(numprocs), intent(in) :: N_l_vec, low_ind - real, dimension(N_l), intent(in) :: data_l - real, dimension(N_f), intent(out) :: data_f - -#ifdef LDAS_MPI - call MPI_GATHERV( & - data_l, N_l, MPI_REAL, & - data_f, N_l_vec, low_ind-1, MPI_REAL, & - 0, mpicomm, mpierr ) - - call MPI_BARRIER( mpicomm, mpierr ) -#else - data_f = data_l -#endif - - end subroutine l2f_real - - ! ************************************************************* - - subroutine l2f_real8( N_l, N_f, N_l_vec, low_ind, data_l, data_f) - - ! wrapper for MPI_GATHERV applied to MPI_REAL8 vector - - ! reichle, 31 Jan 2014 - - implicit none - - integer, intent(in) :: N_l, N_f - integer, dimension(numprocs), intent(in) :: N_l_vec, low_ind - real*8, dimension(N_l), intent(in) :: data_l - real*8, dimension(N_f), intent(out) :: data_f - -#ifdef LDAS_MPI - call MPI_GATHERV( & - data_l, N_l, MPI_REAL8, & - data_f, N_l_vec, low_ind-1, MPI_REAL8, & - 0, mpicomm, mpierr ) - - call MPI_BARRIER( mpicomm, mpierr ) -#else - data_f = data_l -#endif - - end subroutine l2f_real8 - - ! ************************************************************* - - subroutine f2l_real( N_f, N_l, N_l_vec, low_ind, data_f, data_l) - - ! wrapper for MPI_SCATTERV applied to MPI_REAL vector - - ! reichle, 25 Jul 2013 - - implicit none - - integer, intent(in) :: N_f, N_l - integer, dimension(numprocs), intent(in) :: N_l_vec, low_ind - real, dimension(N_f), intent(in) :: data_f - real, dimension(N_l), intent(out) :: data_l - -#ifdef LDAS_MPI - call MPI_SCATTERV( & - data_f, N_l_vec, low_ind-1, MPI_REAL, & - data_l, N_l, MPI_REAL, & - 0, mpicomm, mpierr ) - - call MPI_BARRIER( mpicomm, mpierr ) -#else - data_l = data_f -#endif - - end subroutine f2l_real - - ! ************************************************************* - - subroutine f2l_real8( N_f, N_l, N_l_vec, low_ind, data_f, data_l) - - ! wrapper for MPI_SCATTERV applied to MPI_REAL8 vector - - ! reichle, 31 Jan 2014 - - implicit none - - integer, intent(in) :: N_f, N_l - integer, dimension(numprocs), intent(in) :: N_l_vec, low_ind - real*8, dimension(N_f), intent(in) :: data_f - real*8, dimension(N_l), intent(out) :: data_l - -#ifdef LDAS_MPI - call MPI_SCATTERV( & - data_f, N_l_vec, low_ind-1, MPI_REAL8, & - data_l, N_l, MPI_REAL8, & - 0, mpicomm, mpierr ) - - call MPI_BARRIER( mpicomm, mpierr ) -#else - data_l = data_f -#endif - - end subroutine f2l_real8 - - ! ************************************************************* - - subroutine f2l_logical( N_f, N_l, N_l_vec, low_ind, data_f, data_l) - - ! wrapper for MPI_SCATTERV applied to MPI_LOGICAL vector - - ! reichle, 6 Jun 2016 - - implicit none - - integer, intent(in) :: N_f, N_l - integer, dimension(numprocs), intent(in) :: N_l_vec, low_ind - logical, dimension(N_f), intent(in) :: data_f - logical, dimension(N_l), intent(out) :: data_l - -#ifdef LDAS_MPI - call MPI_SCATTERV( & - data_f, N_l_vec, low_ind-1, MPI_LOGICAL, & - data_l, N_l, MPI_LOGICAL, & - 0, mpicomm, mpierr ) - - call MPI_BARRIER( mpicomm, mpierr ) -#else - data_l = data_f -#endif - - end subroutine f2l_logical - - ! ************************************************************* - -end module CLSM_ensdrv_drv_routines - -! *********** EOF ************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_out_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_out_routines.F90 deleted file mode 100644 index ddcab716..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensdrv_out_routines.F90 +++ /dev/null @@ -1,293 +0,0 @@ -#include "MAPL_Generic.h" - -module clsm_ensdrv_out_routines - - ! collection of LDASsa output subroutines - ! - ! (originally in clsm_ensdrv_drv_routines.F90) - ! - ! reichle, 22 Aug 2014 - - use ESMF - USE MAPL_MOD - use LDAS_ensdrv_globals, ONLY: & - log_root_only, & - logunit, & - logit - - use catch_types, ONLY: & - cat_param_type, & - assignment (=), & - operator (+), & - operator (/) - - use catch_constants, ONLY: & - CATCH_DZTSURF - - use LDAS_TileCoordType, ONLY: & - tile_coord_type - - use mwRTM_types, ONLY: & - mwRTM_param_type - - use LDAS_ensdrv_mpi, ONLY: & - root_proc, & - numprocs - - use LDAS_DateTimeMod, ONLY: & - date_time_type - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use, intrinsic :: iso_fortran_env, only : output_unit - - implicit none - - private - - public :: init_log - public :: GEOS_output_smapL4SMlmc - -contains - - ! ******************************************************************** - - subroutine init_log( myid, numprocs, root_proc ) - - ! open file for output log, write a few things - - ! changed logic so that error messages generated before init_log() - ! has completed do not get lost - ! - reichle, 29 Aug 2014 - - implicit none - - integer, intent(in) :: myid, numprocs - logical, intent(in) :: root_proc - - ! ------------------------------------------------------------------------ - ! - ! local variables - - type(date_time_type) :: start_time - - integer :: istat - - character(300) :: fname - character(200) :: work_path, io_path - character(40) :: exp_domain, exp_id, dir_name, file_tag, file_ext - - character(4) :: myid_string - - character(8) :: date_string - character(10) :: time_string - - character(len=*), parameter :: Iam = 'init_log' - character(len=400) :: err_msg - - ! ----------------------------------------------------------------------- - - ! interpret parameters from clsm_ensdrv_glob_param - - if (log_root_only .and. (.not. root_proc)) then - - logit = .false. - - else - - logit = .true. - - end if - - ! stop if logunit is stdout and output is requested for *all* processors - - if ( (.not. log_root_only) .and. (logunit==output_unit) ) then - - err_msg = 'logunit=output_unit (stdout) together with logging *all* procs is disabled' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! if requested, open a log file that is different from stdout - ! (this would typically be needed if a separate log files - ! is requested for each processor) - - if (logit) then - - if (logunit/=output_unit) then - - err_msg = 'logunit/=output_unit (stdout) - this should never happen per module LDAS_ensdrv_Globals' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - else - - write (logunit,*) - write (logunit,*) 'using stdout for log messages' - - end if - - write (logunit,*) - write (logunit,*) 'Offline ensemble driver for Catchment model' - write (logunit,*) - - ! echo wall clock - - call date_and_time(date_string, time_string) - - write (logunit,*) 'started at ', date_string, ', ', time_string - write (logunit,*) - - ! echo MPI environment - - write (logunit,*) "process ", myid, " of ", numprocs, " is alive" - write (logunit,*) - write (logunit,*) "process ", myid, ": root_proc=", root_proc - write (logunit,*) - - end if ! if (logit) - - end subroutine init_log - - ! ******************************************************************** - - subroutine GEOS_output_smapL4SMlmc( GC, date_time, work_path, exp_id, & - N_catl, tile_coord_l, cat_param, mwRTM_param ) - - ! write SMAP L4_SM "lmc" (land model constants) file collection - ! as binary, tile-space output - ! - ! requires "full" domain inputs - ! - ! reichle, 26 Apr 2012 - ! reichle, 27 May 2014: - changed wilting point output from "clsm_wpwet" to "clsm_wp" - ! - ! ------------------------------------------------------------------- - - implicit none - type(ESMF_GridComp),intent(inout) :: GC - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: work_path - - character(*), intent(in) :: exp_id - - integer, intent(in) :: N_catl - - type(tile_coord_type), dimension(:), intent(in) :: tile_coord_l - - type(cat_param_type), dimension(:), intent(in) :: cat_param - - type(mwRTM_param_type), dimension(:), intent(in) :: mwRTM_param - - ! ---------------------------- - - ! local variables - - character(300) :: fname - character( 40) :: file_tag, dir_name - - integer :: n - - real, dimension(N_catl) :: dztsurf, clsm_wp - - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - type(ESMF_Grid) :: TILEGRID - integer, pointer :: mask(:) - integer :: rc, status,unit - character(*),parameter :: Iam="GEOS_output_smapL4SMlmc" - - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - - call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TileMaskGet(tilegrid, mask, rc=status) - VERIFY_(STATUS) - - ! ------------------------------------------------------------------ - ! - ! compute dztsurf - - dztsurf = CATCH_DZTSURF ! now 0.05 m everywhere due to revised CSOIL_2 in subroutine catchment() - - ! convert wilting point from wetness units to volumetric units - - clsm_wp = cat_param%wpwet * cat_param%poros - - ! ------------------- - - file_tag = 'ldas_smapL4SMlmc' - dir_name = 'rc_out' - - fname = get_io_filename( work_path, exp_id, file_tag, & - date_time=date_time, dir_name=dir_name ) - - unit = GETFILE( trim(fname), form="unformatted", RC=STATUS ) - VERIFY_(STATUS) - - if (logit) write (logunit,'(400A)') 'Writing SMAP L4_SM lmc file ' // trim(fname) - - ! -------------------- - call MAPL_VarWrite(unit, tilegrid,tile_coord_l(:)%frac_cell, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,tile_coord_l(:)%elev , mask=mask, rc=status); VERIFY_(STATUS) - ! for dzsf, dzrz, and dzpr change units from mm (or kg/m2) to m - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzsf/1000. , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzrz/1000. , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzpr/1000. , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,dztsurf(:) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(1) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(2) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(3) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(4) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(5) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%dzgt(6) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%poros , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,clsm_wp(:) , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%cdcr1 , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%cdcr2 , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%vegcls, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%soilcls , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%sand , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%clay , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%poros , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%wang_wt , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%wang_wp , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_hmin , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_hmax , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_wmin , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_wmax , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_Nrh , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_Nrv , mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%rgh_polmix, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%omega, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%bh, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%bv, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,mwRTM_param(:)%lewt, mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid,cat_param(:)%veghght, mask=mask, rc=status); VERIFY_(STATUS) - - ! Note: Since mwrtm_param%vegopacity is time-varying, it is not included in lmc output and written - ! into gph instead. - - call FREE_FILE(unit, RC=STATUS); VERIFY_(STATUS) - - if (logit) write (logunit,*) 'done writing' - if (logit) write (logunit,*) - - end subroutine GEOS_output_smapL4SMlmc - - ! ******************************************************************** - -end module clsm_ensdrv_out_routines - -! *********** EOF ****************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_enkf_update.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_enkf_update.F90 deleted file mode 100644 index ea0be949..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_enkf_update.F90 +++ /dev/null @@ -1,2883 +0,0 @@ - -!*********************************************************************** -! -! land EnKF update for off-line CLSM ensemble driver -! -! Rolf Reichle, 18 Jul 2005 -! -!*********************************************************************** - -module clsm_ensupd_enkf_update - - use MAPL_SortMod, ONLY: & - MAPL_Sort - - use MAPL_ConstantsMod, ONLY: & - MAPL_TICE - - USE CATCH_CONSTANTS, ONLY : & - N_gt => CATCH_N_GT, & - N_snow => CATCH_N_SNOW - - use catchment_model, ONLY: & - catch_calc_tsurf - - use lsm_routines, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp - - use LDAS_ensdrv_globals, ONLY: & - logit, & - logunit, & - nodata_generic, & - nodata_tolfrac_generic - - use LDAS_DateTimeMod, ONLY: & - date_time_type, & - date_time2string - - use enkf_types, ONLY: & - obs_param_type, & - obs_type - - use LDAS_DriverTypes, ONLY: & - met_force_type - - use catch_types, ONLY: & - cat_param_type, & - cat_progn_type, & - catprogn2wesn, & - catprogn2htsn, & - catprogn2ghtcnt, & - assignment (=), & - operator (+), & - operator (/) - - use mwRTM_types, ONLY: & - mwRTM_param_type - - use LDAS_PertTypes, ONLY: & - pert_param_type - - use LDAS_TilecoordType, ONLY: & - tile_coord_type, & - grid_def_type - - use catch_bias_types, ONLY: & - obs_bias_type - - use LDAS_TilecoordRoutines, ONLY: & - get_number_of_tiles_in_cell_ij, & - get_tile_num_in_cell_ij, & - grid2tile - - use nr_ran2_gasdev, ONLY: & - NRANDSEED - - use ease_conv, ONLY: & - ease_convert - - use my_matrix_functions, ONLY: & - row_std - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - use clsm_ensdrv_drv_routines, ONLY: & - check_cat_progn, & - l2f_real - - use clsm_ensupd_upd_routines, ONLY: & - get_obs_pred, & - get_halo_obs, & - get_obs_pert, & - cat_enkf_increments, & - get_ind_obs_assim, & - get_ind_obs_lat_lon_box, & - halo_type, & - FOV_threshold, & - get_halo_around_tile, & - TileNnzObs - - use clsm_ensupd_read_obs, ONLY: & - collect_obs - - use clsm_bias_routines, ONLY: & - obs_bias_upd_tcount, & - obs_bias_corr_obs, & - obs_bias_upd_bias_and_Obs - - use clsm_adapt_routines, ONLY: & - apply_adapt_R - - use LDAS_ensdrv_mpi, ONLY: & - MPI_met_force_type, & - MPI_cat_param_type, & - MPI_cat_progn_type, & - root_proc, & - numprocs, & - myid, & - mpierr, & - mpicomm, & - MPI_obs_type, & - mpistatus - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - include 'mpif.h' - - private - - public :: get_enkf_increments - public :: apply_enkf_increments - public :: output_ObsFcstAna_wrapper - public :: write_smapL4SMaup - -contains - - subroutine get_enkf_increments( & - date_time, & - N_ens, N_catl, N_catf, N_obsl_max, & - work_path, exp_id, & - met_force, lai, cat_param, mwRTM_param, & - tile_coord_l, tile_coord_f, & - tile_grid_g, pert_grid_f, pert_grid_g, & - N_catl_vec, low_ind, l2f, f2l, & - update_type, & - dtstep_assim, & - xcompact, ycompact, fcsterr_inflation_fac, & - N_obs_param, obs_param, N_obsbias_max, & - out_obslog, out_smapL4SMaup, & - cat_progn, & - Pert_rseed, obs_bias, & - cat_progn_incr, fresh_incr, & - N_obsf, N_obsl, Observations_l, & - N_adapt_R, obs_pert_adapt_param, Pert_adapt_R, & - Obs_pert ) - - ! ------------------------------------------------------------- - - ! return increments instead of updated cat_progn - ! reichle, 18 Oct 2005 - - implicit none - - ! ---------------------------------------------------------------- - ! - ! inputs (via argument list, command line, or namelist file, TBD) - - type(date_time_type), intent(in) :: date_time ! current date, time - - integer, intent(in) :: N_ens ! number of ensemble members - integer, intent(in) :: N_catl ! # tiles in *l*ocal procs subdomain - integer, intent(in) :: N_catf ! # tiles in *f*ull domain - integer, intent(in) :: N_obsl_max ! max number of observations allowed - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - - ! Meteorological forcings, Catchment model and microwave RTM parameters - - type(met_force_type), dimension(N_catl), intent(in) :: met_force - real, dimension(N_catl), intent(in) :: lai - type(cat_param_type), dimension(N_catl), intent(in) :: cat_param - - type(mwRTM_param_type), dimension(N_catl), intent(in) :: mwRTM_param - - ! grid and tile coordinate variables - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l, tile_coord_f ! input - - type(grid_def_type), intent(in) :: tile_grid_g, pert_grid_f, pert_grid_g - - integer, intent(in), dimension(numprocs) :: N_catl_vec, low_ind - - integer, intent(in), dimension(N_catl) :: l2f - - integer, intent(in), dimension(N_catf) :: f2l - - integer, intent(in) :: update_type, dtstep_assim - - real, intent(in) :: xcompact, ycompact, fcsterr_inflation_fac - - integer, intent(in) :: N_obs_param - - integer, intent(in) :: N_obsbias_max ! max number of obs bias parameters (bias_Npar) - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - logical, intent(in) :: out_obslog - logical, intent(in) :: out_smapL4SMaup - - type(cat_progn_type), dimension(N_catl,N_ens), intent(in) :: cat_progn - - ! intent(inout) variables: - - integer, dimension(NRANDSEED,N_ens), intent(inout) :: Pert_rseed - - type(obs_bias_type), dimension(N_catl,N_obs_param,N_obsbias_max), intent(inout) :: & - obs_bias - - ! intent(out) variables: - - type(cat_progn_type),dimension(N_catl,N_ens),intent(out) :: cat_progn_incr - - logical, intent(inout) :: fresh_incr - - type(obs_type), dimension(:), pointer :: Observations_l ! output - - integer, intent(out) :: N_obsf, N_obsl - - ! must always have some variables for adaptive filtering - ! (GNUMakefile setup does not permit C-preprocessor directives) - - integer, intent(in) :: N_adapt_R - - integer, dimension(N_obs_param), intent(in) :: obs_pert_adapt_param - - real, dimension(N_adapt_R,N_catl), intent(in) :: Pert_adapt_R - - real, dimension(N_obsl_max,N_ens), intent(out), optional :: Obs_pert - - ! ---------------------------------------------- - - ! local variables - - logical :: found_obs_f, assimflag - - type(obs_type), dimension(:), pointer :: Observations_lH => null() ! obs w/in halo - - ! matrix of measurement predictions - - real, dimension(:,:), pointer :: Obs_pred_l => null() - real, dimension(:,:), pointer :: Obs_pred_lH => null() - - ! random realization of measurement error - - real, allocatable, dimension(:,:) :: Obs_pert_tmp - - ! variables for echoing wall clock time - - character(8) :: date_string - character(10) :: time_string - - ! additional grid/tile information that is needed for mapping observations - ! to tiles - - integer, dimension(:,:), pointer :: N_tile_in_cell_ij_f - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij_f - - integer :: i, n, n_e - - ! obs bias variables - - logical, dimension(:), allocatable :: obsbias_ok - - ! pchakrab: variables for analysis load balance (AnaLoadBal) - - type varLenIntArr ! used to store indices on each processor - integer, dimension(:), allocatable :: ind - end type varLenIntArr - integer :: N_select_species ! input to get_ind_obs_lat_lon_box() - integer, dimension(:), allocatable :: select_species ! input to get_ind_obs_lat_lon_box() and TileNnzObs() - type(halo_type) :: halo - integer :: N_selected_obs - integer, dimension(numprocs) :: tmp_low_ind ! tmp_low_ind-1 is the displs vector for Gatherv/Scatterv - - ! tiles related - integer :: nTiles_l, nTilesl_vec(numprocs), nTiles_f - integer :: nTiles_ana, nTilesAna_vec(numprocs) - integer, dimension(:), allocatable :: indTiles_l, indTiles_f, indTiles_ana - type(varLenIntArr) :: indTilesAna_vec(numprocs) - - type(tile_coord_type), dimension(:), pointer :: tile_coord_ana ! input to cat_enkf_increment() is a pointer - - type(met_force_type), dimension(:), allocatable :: met_force_f, met_force_ana - type(cat_param_type), dimension(:), allocatable :: cat_param_f, cat_param_ana - - type(cat_progn_type), allocatable :: cat_progn_f(:), cat_progn_ana(:,:) - type(cat_progn_type), allocatable :: tmp_cat_progn_ana(:) - type(cat_progn_type), allocatable :: cat_progn_incr_f(:), cat_progn_incr_ana(:,:) - type(cat_progn_type), allocatable :: recvBuf(:) - - ! obs related - integer :: nObs_ana - integer :: nObsAna_vec(numprocs) - integer :: N_obsf_assim, N_obsl_assim - integer :: N_obsl_assim_vec(numprocs) - integer, dimension(:), allocatable :: indObs_ana - integer, dimension(:), allocatable, target :: ind_obsl_assim - integer, dimension(:), pointer :: ptr2indx => null() - type(varLenIntArr) :: indObsAna_vec(numprocs) - integer, dimension(:), allocatable :: tmp_ind_obs - type(obs_type), dimension(:), allocatable :: Obs_f_assim, Obs_ana ! collect obs before distributing for ana - real, allocatable :: Obs_pred_f_assim(:), Obs_pred_ana(:,:) - - ! odds and ends - real :: t_start, t_end, tmax, tmin ! for timing routines - integer :: iTile, iproc, iEns, ctr ! counters - integer :: quotient, remainder - integer :: dest, src, sendct, recvct, sendtag, recvtag - - character(12) :: tmpstr12 - - character(len=*), parameter :: Iam = 'get_enkf_increments' - character(len=400) :: err_msg - - ! ********************************************************************** - ! - ! END OF DECLARATIONS - ! - ! *********************************************************************** - - ! nullify all pointers - ! (good practice; necessary on halem when -omp is used) - - nullify(N_tile_in_cell_ij_f, tile_num_in_cell_ij_f) - nullify(Observations_lH,Obs_pred_l,Obs_pred_lH) - - ! ************************************************************************* - - ! initialize - - fresh_incr = .false. - - N_obsl = 0 - N_obsf = 0 - - do n=1,N_catl - do n_e=1,N_ens - cat_progn_incr(n,n_e) = 0. - end do - end do - - ! check if update is needed at all - - if (update_type==0) then - - if (logit) write (logunit,*) 'no EnKF increments b/c update_type=0' - - return ! nothing else to be done here - - end if - - ! echo analysis time and wall clock time - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - if (logit) write (logunit,*) 'get_enkf_increments(): enter at ', & - date_string, ', ', time_string - if (logit) write (logunit,*) 'get_enkf_increments(): enter at anal time ', & - date_time2string(date_time) - - if (.true.) then ! replace obsolete check for analysis time with "if true" to keep indents - - ! proceed with update - - ! ----------------------------------------------------------------- - ! - ! Get additional grid/tile information that is needed to map obs - ! from lat/lon to tiles. This needs to be done: - ! - by root process (because of call to read_obs() in collect_obs()) - ! - by all processes if FOV>~0 ("tile_num_in_circle" needed in get_obs_pred()) - if ( (root_proc) .or. & - (any(obs_param(1:N_obs_param)%FOV>FOV_threshold)) ) then - - allocate(N_tile_in_cell_ij_f(pert_grid_f%N_lon,pert_grid_f%N_lat)) - - ! first call: count how many tiles are in each pert_grid_f cell - call get_number_of_tiles_in_cell_ij( N_catf, & - tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, & - pert_grid_f, N_tile_in_cell_ij_f ) - ! second call: find out which tiles are in each pert_grid_f cell - - call get_tile_num_in_cell_ij( N_catf, & - tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, & - pert_grid_f, maxval(N_tile_in_cell_ij_f), tile_num_in_cell_ij_f ) - else - allocate(N_tile_in_cell_ij_f(0,0)) ! for debugging - end if - - ! ********************************************************************* - ! - ! collect observations - ! - ! ********************************************************************* - - ! write original (unscaled) SMAP Tb observations into SMAP L4_SM aup file - ! - ! NOTE: this requires a call to collect_obs() within output_smapL4SMaup() - - if (out_smapL4SMaup) & - call output_smapL4SMaup( date_time, work_path, exp_id, dtstep_assim, & - N_ens, N_catl, N_catf, N_obsl_max, & - tile_coord_f, tile_grid_g, pert_grid_f, & - N_catl_vec, low_ind, l2f, N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - N_obs_param, obs_param, Observations_l, cat_param, cat_progn ) - - ! check for observations, found_obs_f=.true. if obs availalbe - - call collect_obs( & - work_path, exp_id, date_time, dtstep_assim, & - N_catl, & - N_catf, tile_coord_f, pert_grid_f, & - N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - N_catl_vec, low_ind, l2f, & - N_obs_param, obs_param, N_obsl_max, out_obslog, & - N_obsl, Observations_l, found_obs_f ) - - - ! -------------------------------------------------------------------- - - if (found_obs_f) then - - ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! - ! *** Obs bias algorithm *** - ! - ! Draper, Aug 2013 - ! - ! Obs bias update equations: - ! i) b^+ = b^- + l (y - Hx^- - b^- ) for all obs - ! ii) x^+ = x^- + K| (y| - b^+ -H| x^- ) - ! y|,H|,K| for obs only where bias estimate is good - ! - ! B1. Adjust observation to remove the prior bias (y'=(y - b^-)) - ! Determine whether have good obs_bias estimate based on time - ! since last bias update - ! -> set obsbias_ok and Observations%assim flags on each obs - ! (get_obs_pred call is here - has some post model-based QC) - ! B2. Calculate the obs_bias incr (b+ - b-) - ! a Update the obs_bias with obs_bias incr to get posterior bias - ! b Update the obs with with obs_bias incr (y - b+ = y' - (b^+ - b^-) - ! - ! Note: get_halo_obs() screens for obs%assim flag, so only obs - ! that have assim==.T. will be used in state update - ! - ! CAUTION: observed value (Observations%obs) is now bias-corrected!!! - ! (and written out as such) - - allocate(obsbias_ok(N_obsl)) - - if (N_obsl>0) obsbias_ok = .false. ! initialize - - if ( (N_obsl>0) .and. (N_obsbias_max>0) ) then - - ! B1. Adjust observations to remove the obs bias - ! and set obsbias_ok flag - - call obs_bias_corr_obs(date_time, N_catl, N_catf, & - N_obsl , N_obs_param, N_obsbias_max, f2l, obs_param, & - obs_bias, Observations_l, obsbias_ok) - - end if - - ! ++++++++++++++++++++++++++++++++++++++++++++++++++++ - - ! adapt obs error covariance R - - ! not yet implemented for MPI - - if (N_adapt_R>0) & - call apply_adapt_R( N_obsl, N_obs_param, obs_pert_adapt_param, & - N_adapt_R, N_catl, Pert_adapt_R, Observations_l ) - - ! ****************************************************************** - ! - ! compute innovations (O-F) - ! - ! ****************************************************************** - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - if (logit) write (logunit,'(400A)') 'computing innovations starting at ' // & - date_string // ', ' // time_string - - ! compute model forecast of observations - ! (ensemble mean "obs_pred" is also stored in Observations_l%fcst) - - ! incl. obs bias estimation - - call get_obs_pred( & - .true., & ! -> before EnKF update - N_obs_param, N_ens, & - N_catl, tile_coord_l, & - N_catf, tile_coord_f, f2l, & - N_catl_vec, low_ind, pert_grid_g, & - obs_param, & - met_force, lai, cat_param, cat_progn, mwRTM_param, & - N_obsl, Observations_l, Obs_pred_l, obsbias_ok, & - fcsterr_inflation_fac ) - - if (allocated(obsbias_ok)) deallocate(obsbias_ok) - - ! IF NEEDED, INCLUDE WITHHOLDING SUBROUTINE HERE. - ! SUCH A SUBROUTINE SHOULD CHANGE Observations(i)%assim TO FALSE - ! IF THE OBSERVATION IS TO BE WITHHELD - ! - ! call withhold_obs() - - - ! count observations across all processors that are left after - ! model-based QC (done within get_obs_pred()) - -#ifdef LDAS_MPI - - call MPI_AllReduce( & - N_obsl, N_obsf, 1, MPI_integer, MPI_SUM, & - mpicomm, mpierr ) - -#else - N_obsf = N_obsl -#endif - - ! check whether any "assim" flag is set in obs_param - - ! CSD - if want to skip cat_enkf_incr and apply_incr blocks - ! in instances where obs bias correction has discared all obs - ! (first few cycles of avail. obs), would need to test here - ! for whether obs on any processors are being assimilated. - - assimflag = .false. - - do i=1,N_obs_param - - if (obs_param(i)%assim) assimflag = .true. - - end do - - ! ++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! - ! Obs bias - ! - ! B2. Update obs_bias and Observations with the obs bias increment - - if ( (N_obsl>0) .and. (N_obsbias_max>0) ) & - call obs_bias_upd_bias_and_Obs(date_time, N_catl, N_catf, & - N_obsl, N_ens, N_obs_param, N_obsbias_max, f2l, obs_param, & - Obs_pred_l(1:N_obsl,1:N_ens), obs_bias, Observations_l(1:N_obsl) ) - - ! ++++++++++++++++++++++++++++++++++++++++++++++++++++ - - end if ! found_obs_f==.true. - - - ! ****************************************************************** - ! - ! assimilate (EnKF state update) - ! - ! ****************************************************************** - - if ( (N_obsf>0) .and. assimflag ) then - -#ifdef LDAS_MPI - - ! AnaLoadBal (Analysis Load Balance) - ! - ! pchakrab: 03/25/2014 - ! - ! Issue: Load imbalance of cat_enkf_increment. For single-sensor - ! assimilation (e.g., SMAP) the assimilated obs end up on only a few - ! processors and the majority of processors sit idle. - ! - ! Solution: Collect and distribute tiles with a non-zero (nnz) number of - ! assimilated obs evenly among processors. This is not the ideal solution since - ! the number of obs still varies considerably from processor to - ! processor, but is a major improvement. A 24-hr run (with 24 - ! ensembles and simulated SMAP data using the SMAP S/W Delivery 5 CVS tag) - ! on 128 Sandybridge processors went from 4h:40m (original code) - ! to 1h:10m (load balanced code). On 64 processors the same run took 1h:40m. - ! - ! Outline of algorithm: The load balancing is done in 5 steps. - ! - ! Prereq - ! ------ - ! Step 1: Combine Observations_l (obs w/ %assim==.true.) into - ! Obs_f_assim (available on all processors). Obs_f_assim is needed - ! to identify the (local) tiles with nnz obs. - ! NOTE: N_obsf: number of all obs - ! N_obsf_assim: number of obs w/ assim==.true. - ! - ! Decomposition (2 steps) - ! ----------------------- - ! Step 2: Each processor identifies the local tiles with nnz obs, - ! indTiles_l, collects them on root, indTiles_f, and distributes - ! them evenly among all procs, indTiles_ana. The corresponding - ! numbers are nTiles_l, nTiles_f, nTiles_ana. Root needs - ! nTilesAna_vec, indTilesAna_vec (list of nTiles_ana, - ! indTiles_ana on each proc) to distribute cat_param, cat_progn, etc. - ! - ! IMPORTANT: Regardless of update_type, obs from *all* species are - ! considered (ie, N_select_species=0). This could result in - ! poor load balancing if different species are present, - ! which will need to be addressed in future. - ! - wjiang+reichle, 13 Oct 2020 - ! - ! Step 3: Each processor computes nObs_ana and indObs_ana, - ! the number and indices of obs affecting tiles in indTiles_ana. - ! Root needs nObsAna_vec, indObsAna_vec to distribute Obs_pred_l. - ! - ! Distribute input - ! ---------------- - ! Step 4: On each proc, create tile_coord_ana, Obs_ana etc. the - ! load-balanced versions of tile_coord_l, Observations_l etc. - ! (input to cat_enkf_increments). - ! - ! call to cat_enkf_increments w/ load-balanced data - ! - ! Collect output - ! -------------- - ! Step 5: Output of cat_enkf_increment() is cat_progn_incr_ana - ! which is then massaged into its 'local' counterpart - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - if (logit) write(logunit,'(400A)') & - 'Dynamic load balancing and analysis (AnaLoadBal) starting at ' // & - date_string // ', ' // time_string - - !-AnaLoadBal-Prereq-starts-here- - ! Step 1a: identify obs w/ obs%assim==.true. - allocate(ind_obsl_assim(N_obsl), source=-99) - call get_ind_obs_assim(N_obsl, Observations_l%assim, N_obsl_assim, ind_obsl_assim) - ! its easier to write ptr2indx than ind_obsl_assim(1:N_obsl_assim) - ptr2indx => ind_obsl_assim(1:N_obsl_assim) - - ! Step 1b: Observations_l(obs%assim=.true.) -> Obs_f_assim (on all processors) - ! NOTE: For MPI_Allgatherv, we need N_obsl_assim_vec and tmp_low_ind on all procs - call MPI_AllGather(N_obsl_assim,1,MPI_INTEGER, & - N_obsl_assim_vec,1,MPI_INTEGER,mpicomm,mpierr ) - N_obsf_assim = sum(N_obsl_assim_vec) - if (logit) then - write (tmpstr12,'(i12)') N_obsf ! convert integer to string - write(logunit,'(400A)') 'Total number of obs: ' // & - tmpstr12, ' [after model-based QC]' - write (tmpstr12,'(i12)') N_obsf_assim ! convert integer to string - write(logunit,'(400A)') 'Total number of assimilated obs: ' // & - tmpstr12, ' [after "assim_flag==true"]' - end if - allocate(Obs_f_assim(N_obsf_assim)) - tmp_low_ind(1) = 1 - do n=1,numprocs-1 - tmp_low_ind(n+1) = tmp_low_ind(n) + N_obsl_assim_vec(n) - end do - call MPI_Allgatherv( & - Observations_l(ptr2indx), N_obsl_assim, MPI_obs_type, & - Obs_f_assim, N_obsl_assim_vec, tmp_low_ind-1, MPI_obs_type, & - mpicomm, mpierr) - !-AnaLoadBal-Prereq-ends-here- - - !-AnaLodaBal-Decomposition-starts-here - ! Step 2a: compute nTiles_l, indTiles_l, nTilesl_vec (on root), nTiles_f (on root) - ! NOTE: loop over tile_coord_l, if tile has nnz obs, store the 'full' index - call cpu_time(t_start) - allocate(indTiles_l(N_catl), source=-99) - N_select_species=0 ! include *all* obs species - allocate(select_species(N_select_species)) ! allocate() needed for gcc10 - nTiles_l = 0 - do iTile=1,N_catl - halo = get_halo_around_tile(tile_coord_l(iTile), xcompact, ycompact) - if (TileNnzObs(Obs_f_assim, halo, select_species)) then - nTiles_l = nTiles_l + 1 ! num of tiles w/ nnz obs - indTiles_l(nTiles_l) = l2f(iTile) ! 'full' index of tile w/ nnz obs - end if - end do - call MPI_Gather(nTiles_l,1,MPI_INTEGER, & - nTilesl_vec,1,MPI_INTEGER,0,mpicomm,mpierr) - if (root_proc) nTiles_f = sum(nTilesl_vec) - call MPI_Bcast(nTiles_f,1,MPI_INTEGER,0,mpicomm,mpierr) - if (logit) then - write (tmpstr12,'(i12)') nTiles_f ! convert integer to string - write(logunit,'(400A)') & - 'AnaLoadBal: Total number of tiles in EnKF analysis: ' // tmpstr12 - end if - - ! Step 2b: indTiles_l -> indTiles_f (on root) - if (root_proc) then - allocate(indTiles_f(nTiles_f), source=-99) - else - allocate(indTiles_f(0)) ! for debugging mode - endif - - if (root_proc) then - tmp_low_ind(1) = 1 - do iproc=1,numprocs-1 - tmp_low_ind(iproc+1) = tmp_low_ind(iproc) + nTilesl_vec(iproc) - end do - end if - call MPI_Gatherv( & - indTiles_l(1:nTiles_l), nTiles_l, MPI_INTEGER, & - indTiles_f, nTilesl_vec, tmp_low_ind-1, MPI_INTEGER, & - 0, mpicomm, mpierr) - if (allocated(indTiles_l)) deallocate(indTiles_l) - - ! Step 2c: compute nTiles_ana, indTiles_f -> indTiles_ana - quotient = nTiles_f/numprocs - remainder = mod(nTiles_f,numprocs) - - do iproc=1,numprocs - nTilesAna_vec(iproc) = quotient - if (iproc<=remainder) nTilesAna_vec(iproc) = nTilesAna_vec(iproc) + 1 - end do - - nTiles_ana = nTilesAna_vec(myid+1) ! shorthand - allocate(indTiles_ana(nTiles_ana), source=-99) - tmp_low_ind(1) = 1 - do iproc=1,numprocs-1 - tmp_low_ind(iproc+1) = tmp_low_ind(iproc) + nTilesAna_vec(iproc) - end do - - call MPI_Scatterv( & - indTiles_f, nTilesAna_vec, tmp_low_ind-1, MPI_INTEGER, & - indTiles_ana, nTiles_ana, MPI_INTEGER, & - 0, mpicomm, mpierr) - if (allocated(indTiles_f)) deallocate(indTiles_f) - - ! Step 2d: indTiles_ana -> indTilesAna_vec (on root) - ! root needs indTiles_ana from each proc to distribute cat_param, cat_progn, etc. - if (root_proc) then - do iproc=1,numprocs - allocate(indTilesAna_vec(iproc)%ind(nTilesAna_vec(iproc))) - end do - end if - if (root_proc) then - indTilesAna_vec(1)%ind = indTiles_ana ! copy contribution from root - do src=1,numprocs-1 - recvct = nTilesAna_vec(src+1) - recvtag = src - call MPI_Recv(indTilesAna_vec(src+1)%ind,recvct,MPI_INTEGER, & - src,recvtag,mpicomm,mpistatus,mpierr) - end do - else - sendtag = myid - sendct = nTiles_ana - call MPI_Send(indTiles_ana,sendct,MPI_INTEGER,0,sendtag,mpicomm,mpierr) - end if - call cpu_time(t_end) - - ! Step 2: timing info - call MPI_Reduce(t_end-t_start,tmax,1,MPI_REAL,MPI_MAX,0,mpicomm,mpierr) - call MPI_Reduce(t_end-t_start,tmin,1,MPI_REAL,MPI_MIN,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,ES10.3,A,ES10.3)') & - 'AnaLoadBal: Step 2 time taken (create indTiles_ana): ', & - ' max =', tmax, ', min =', tmin - - ! Step 3a: for each proc create nObs_ana, indObs_ana and Obs_ana - ! [we still have Obs_f_assim in each proc] - call cpu_time(t_start) - allocate(indObs_ana(N_obsf_assim), source=-99) - allocate(tmp_ind_obs(N_obsf_assim), source=-99) - nObs_ana = 0 - do ctr=1,nTiles_ana - iTile = indTiles_ana(ctr) ! 'full' index - halo = get_halo_around_tile(tile_coord_f(iTile), xcompact, ycompact) - tmp_ind_obs = -1 - call get_ind_obs_lat_lon_box( & - N_obsf_assim, Obs_f_assim, & - halo%minlon, halo%maxlon, halo%minlat, halo%maxlat, & - N_select_species, select_species, & ! incl. *all* obs species (N_select_species=0) - N_selected_obs, tmp_ind_obs ) - ! add N_selected_obs indices to indObs_ana. CAREFUL not to duplicate indices - if (N_selected_obs>0) & - call addUniqueInts(tmp_ind_obs(1:N_selected_obs),indObs_ana,nObs_ana) - end do - if (allocated(tmp_ind_obs)) deallocate(tmp_ind_obs) - if (allocated(select_species)) deallocate(select_species) - ! sort obs indices (for layout independence) - if (nObs_ana>1) call MAPL_Sort(indObs_ana(1:nObs_ana)) - - ! Step 3b: nObs_ana -> nObsAna_vec (on root) - call MPI_Gather(nObs_ana,1,MPI_INTEGER, & - nObsAna_vec,1,MPI_INTEGER,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,I7,A,I7)') & - 'AnaLoadBal: nObs_ana statistics: ', & - 'max =', maxval(nObsAna_vec), ', min =', minval(nObsAna_vec) - - ! Step 3c: indObs_ana -> indObsAna_vec (on root) - ! root needs indObs_ana from each proc (to distribute Obs_pred_l) - if (root_proc) then - do iproc=1,numprocs - allocate(indObsAna_vec(iproc)%ind(nObsAna_vec(iproc))) - end do - end if - if (root_proc) then - indObsAna_vec(1)%ind = indObs_ana(1:nObs_ana) ! copy contribution from root - do src=1,numprocs-1 - recvct = nObsAna_vec(src+1) - recvtag = src - call MPI_Recv(indObsAna_vec(src+1)%ind,recvct,MPI_INTEGER, & - src,recvtag,mpicomm,mpistatus,mpierr) - end do - else - sendtag = myid - sendct = nObs_ana - call MPI_Send(indObs_ana,sendct,MPI_INTEGER, & - 0,sendtag,mpicomm,mpierr) - end if - call cpu_time(t_end) - - ! Step 3: timing info - call MPI_Reduce(t_end-t_start,tmax,1,MPI_REAL,MPI_MAX,0,mpicomm,mpierr) - call MPI_Reduce(t_end-t_start,tmin,1,MPI_REAL,MPI_MIN,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,ES10.3,A,ES10.3)') & - 'AnaLoadBal: Step 3 time taken (create indObs_ana): ', & - ' max =', tmax, ', min =', tmin - !-AnaLodaBal-decomposition-ends-here - - !-AnaLoadBal-Input-Distribution-starts-here - ! Step 4a: Obs_ana - call cpu_time(t_start) - allocate(Obs_ana(nObs_ana)) - Obs_ana = Obs_f_assim(indObs_ana(1:nObs_ana)) - if (allocated(Obs_f_assim)) deallocate(Obs_f_assim) - - ! Step 4b: tile_coord_ana - allocate(tile_coord_ana(nTiles_ana)) - tile_coord_ana = tile_coord_f(indTiles_ana) - - ! Step 4c: met_force(N_catl) -> met_force_f (on root) -> met_force_ana - if (root_proc) then - allocate(met_force_f(N_catf)) - else - allocate(met_force_f(0)) ! for debugging mode - endif - call MPI_Gatherv( & - met_force, N_catl, MPI_met_force_type, & - met_force_f, N_catl_vec, low_ind-1, MPI_met_force_type, & - 0, mpicomm, mpierr ) - allocate(met_force_ana(nTiles_ana)) - if (root_proc) then - met_force_ana = met_force_f(indTilesAna_vec(1)%ind) - do dest=1,numprocs-1 - sendtag = dest - sendct = nTilesAna_vec(dest+1) - call MPI_Send(met_force_f(indTilesAna_vec(dest+1)%ind), & - sendct,MPI_met_force_type, & - dest,sendtag,mpicomm,mpierr) - end do - else - ! source = 0 - recvtag = myid - recvct = nTiles_ana - call MPI_Recv(met_force_ana,recvct,MPI_met_force_type, & - 0,recvtag,mpicomm,mpistatus,mpierr) - end if - if (allocated(met_force_f)) deallocate(met_force_f) - - ! Step 4d: cat_param(N_catl) -> cat_param_f (on root) -> cat_param_ana - if (root_proc) then - allocate(cat_param_f(N_catf)) - else - allocate(cat_param_f(0)) ! for debugging mode - endif - call MPI_Gatherv( & - cat_param, N_catl, MPI_cat_param_type, & - cat_param_f, N_catl_vec, low_ind-1, MPI_cat_param_type, & - 0, mpicomm, mpierr ) - allocate(cat_param_ana(nTiles_ana)) - if (root_proc) then - cat_param_ana = cat_param_f(indTilesAna_vec(1)%ind) - do dest=1,numprocs-1 - sendtag = dest - sendct = nTilesAna_vec(dest+1) - call MPI_Send(cat_param_f(indTilesAna_vec(dest+1)%ind), & - sendct,MPI_cat_param_type, & - dest,sendtag,mpicomm,mpierr) - end do - else - ! source = 0 - recvtag = myid - recvct = nTiles_ana - call MPI_Recv(cat_param_ana,recvct,MPI_cat_param_type, & - 0,recvtag,mpicomm,mpistatus,mpierr) - end if - if (allocated(cat_param_f)) deallocate(cat_param_f) - - ! Step 4e: cat_progn -> cat_progn_f (on root) -> cat_progn_ana - ! one ensemble at a time - if (root_proc) then - allocate(cat_progn_f(N_catf)) - else - allocate(cat_progn_f(0)) ! for debugging mode - endif - - allocate(cat_progn_ana(nTiles_ana,N_ens)) - allocate(tmp_cat_progn_ana(nTiles_ana)) ! CSD-BUGFIX - - do iEns=1,N_ens - ! cat_progn_ana(:,iEns) -> cat_progn_f (on root) - call MPI_Gatherv( & - cat_progn(:,iEns), N_catl, MPI_cat_progn_type, & - cat_progn_f, N_catl_vec, low_ind-1, MPI_cat_progn_type, & - 0, mpicomm, mpierr ) - if (root_proc) then - cat_progn_ana(:,iEns) = cat_progn_f(indTilesAna_vec(1)%ind) - do dest=1, numprocs-1 - sendtag = dest - sendct = nTilesAna_vec(dest+1) ! send count - call MPI_Send(cat_progn_f(indTilesAna_vec(dest+1)%ind), & - sendct,MPI_cat_progn_type, & - dest,sendtag,mpicomm,mpierr) - end do - else - ! source = 0 (root) - recvtag = myid - recvct = nTiles_ana - - ! CSD-BUGFIX (adopted by reichle, 7 Oct 2015) - ! MPI crashed here if given a zero index first dimension, combined with a non-zero length - ! second dimension, and recvct=0, as it inteprets the array as having length 1. - ! Reading into a zero length vector is OK though - ! - !call MPI_Recv(cat_progn_ana(:,iEns),recvct,MPI_cat_progn_type, & - ! 0,recvtag,mpicomm,mpistatus,mpierr) - ! - ! Solution: Use MPI_Recv with 1d array, then copy into 2d array. - - call MPI_Recv(tmp_cat_progn_ana,recvct,MPI_cat_progn_type, & - 0,recvtag,mpicomm,mpistatus,mpierr) - - cat_progn_ana(:,iEns)=tmp_cat_progn_ana - - end if - end do - - if (allocated( tmp_cat_progn_ana)) deallocate(tmp_cat_progn_ana) - if (allocated(cat_progn_f)) deallocate(cat_progn_f) - - ! Step 4f: Obs_pred_l (obs%assim=.true.) -> Obs_pred_f_assim (on root) -> Obs_pred_ana - ! one ensemble at a time - if (root_proc) then - allocate(Obs_pred_f_assim(N_obsf_assim)) - else - allocate(Obs_pred_f_assim(0)) ! for debugging mode - endif - allocate(Obs_pred_ana(nObs_ana,N_ens), source=0.) - if (root_proc) then - tmp_low_ind(1) = 1 - do iproc=1,numprocs-1 - tmp_low_ind(iproc+1) = tmp_low_ind(iproc) + N_obsl_assim_vec(iproc) - end do - end if - do iEns=1,N_ens - ! Obs_pred_l(:,iEns) -> Obs_pred_f_assim (on root) [only for obs%assim=.true.] - call MPI_Gatherv( & - Obs_pred_l(ptr2indx,iEns), N_obsl_assim, MPI_REAL, & - Obs_pred_f_assim, N_obsl_assim_vec, tmp_low_ind-1, MPI_REAL, & - 0, mpicomm, mpierr ) - ! Obs_pred_f_assim (on root) -> Obs_pred_ana - if (root_proc) then - ! copy Obs_pred_ana for root - Obs_pred_ana(:,iEns) = Obs_pred_f_assim(indObsAna_vec(1)%ind) - ! communicate - do dest=1, numprocs-1 - sendtag = dest - sendct = nObsAna_vec(dest+1) ! send count - call MPI_Send(Obs_pred_f_assim(indObsAna_vec(dest+1)%ind(1:sendct)), & - sendct,MPI_REAL, & - dest,sendtag,mpicomm,mpierr) - end do - else - ! source = 0 (root) - recvtag = myid - recvct = nObs_ana - call MPI_Recv(Obs_pred_ana(:,iEns),recvct,MPI_REAL, & - 0,recvtag,mpicomm,mpistatus,mpierr) - end if - end do - if (allocated(Obs_pred_f_assim)) deallocate(Obs_pred_f_assim) - if (allocated(ind_obsl_assim)) deallocate(ind_obsl_assim) - nullify(ptr2indx) - call cpu_time(t_end) - - ! Step 4: timing info - call MPI_Reduce(t_end-t_start,tmax,1,MPI_REAL,MPI_MAX,0,mpicomm,mpierr) - call MPI_Reduce(t_end-t_start,tmin,1,MPI_REAL,MPI_MIN,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,ES10.3,A,ES10.3)') & - 'AnaLoadBal: Step 4 time taken (distribute inputs): ', & - ' max =', tmax, ', min =', tmin - !-AnaLoadBal-Input-Distribution-ends-here - -#else - - ! collect observations (within halo) that should be assimilated - ! (ie, ONLY collect obs with flag assim==.true.) - ! - ! NOTE: make sure to pass into get_halo_obs() only the portion - ! of Observations_l and Obs_pred_l that are "good" - ! [allocation of these arrays in get_obs_pred() is larger - ! than eventual size] - - call get_halo_obs( N_ens, N_obsl, & - Observations_l(1:N_obsl), Obs_pred_l(1:N_obsl,1:N_ens), & - tile_coord_l, xcompact, ycompact, & - N_obslH, Observations_lH, Obs_pred_lH ) - -#endif - - ! get observations perturbations for all ensemble members - -#ifdef LDAS_MPI - - ! MPI: input full domain pert_grid_f because *_pert_ntrmdt - ! corresponds to full domain - ! input local nObs_ana and Obs_ana because *_pert_tile_* - ! is diagnosed for the local domain only - ! ALL processors MUST call this subroutine (even if nObs_ana==0) - ! to keep Pert_rseed consistent across processors - - allocate(Obs_pert_tmp(nObs_ana,N_ens)) - call get_obs_pert( N_ens, nObs_ana, N_obs_param, & - pert_grid_f, & - obs_param, Obs_ana, & - Pert_rseed, & - Obs_pert_tmp ) - -#else - - allocate(Obs_pert_tmp(N_obslH,N_ens)) - call get_obs_pert( N_ens, N_obslH, N_obs_param, & - pert_grid_f, & - obs_param, Observations_lH, & - Pert_rseed, & - Obs_pert_tmp ) -#endif - - ! fill optional outputs if needed - - if (present(Obs_pert)) then - - ! Obs_pert must be returned for adaptive filter - ! but this has not yet been implemented for MPI - ! version - - !! Obs_pert(1:N_obslH,1:N_ens) = Obs_pert_tmp - - err_msg = 'ERROR with Obs_pert output - optional ' // & - 'output variable Obs_pert not yet implemented' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! get assimilation increments - -#ifdef LDAS_MPI - allocate(cat_progn_incr_ana(nTiles_ana,N_ens)) - - call cpu_time(t_start) - call cat_enkf_increments( & - N_ens, nObs_ana, nTiles_ana, N_obs_param, & - update_type, obs_param, & - tile_coord_ana, indTiles_ana, & ! indTiles_ana is essentially ana2f - Obs_ana, & ! size: nObs_ana - Obs_pred_ana, & ! size: (nObs_ana,N_ens) - Obs_pert_tmp, & - met_force_ana, & - cat_param_ana, & - xcompact, ycompact, fcsterr_inflation_fac, & - cat_progn_ana, cat_progn_incr_ana) - call cpu_time(t_end) - - - ! we need this for correct timing info - call MPI_Barrier(mpicomm, mpierr) - - ! cat_enkf_incr timinig info - call MPI_Reduce(t_end-t_start,tmax,1,MPI_REAL,MPI_MAX,0,mpicomm,mpierr) - call MPI_Reduce(t_end-t_start,tmin,1,MPI_REAL,MPI_MIN,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,ES10.3,A,ES10.3)') & - 'Time taken by cat_enkf_increments: ', & - ' max =', tmax, ', min =', tmin -#else - ! NOTE: make sure to pass into cat_enkf_increments() only the - ! "valid" sub-arrays of Observations_lH and Obs_pred_lH - ! [allocation of these arrays in get_halo_obs() is larger - ! than eventual size] - - call cat_enkf_increments( & - N_ens, N_obslH, N_catl, N_obs_param, & - update_type, obs_param, & - tile_coord_l, l2f, & - Observations_lH(1:N_obslH), & - Obs_pred_lH(1:N_obslH,1:N_ens), & - Obs_pert_tmp, & - met_force, & - cat_param, & - xcompact, ycompact, fcsterr_inflation_fac, & - cat_progn, cat_progn_incr, met_force ) -#endif - -#ifdef LDAS_MPI - !-AnaLoadBal-Output-Collection-starts-here- - ! Step 5: do the reverse for cat_progn_incr - ! cat_progn_incr_ana -> cat_progn_incr_f -> cat_progn_incr - ! WE PROBABLY SHOULD DO AWAY WITH recvBuf - call cpu_time(t_start) - if (root_proc) then - allocate(cat_progn_incr_f(N_catf)) - allocate(recvBuf(maxval(nTilesAna_vec))) ! temp storage of incoming data - else - allocate(cat_progn_incr_f(0)) ! for debugging - end if - do iEns=1,N_ens - ! cat_progn_incr_ana -> cat_progn_incr_f - if (root_proc) then - do iTile=1,N_catf ! cannot do cat_progn_incr_f = 0. - cat_progn_incr_f(iTile) = 0. ! initialize - end do - ! copy contribution from root - cat_progn_incr_f(indTilesAna_vec(1)%ind(1:nTilesAna_vec(1))) = & - cat_progn_incr_ana(:,iEns) - ! communicate - do src=1,numprocs-1 - recvct = nTilesAna_vec(src+1) - recvtag = src - call MPI_Recv(recvBuf,recvct,MPI_cat_progn_type, & - src,recvtag,mpicomm,mpistatus,mpierr) - ! unpack cat_progn_incr_tmp into cat_progn_incr - cat_progn_incr_f(indTilesAna_vec(src+1)%ind(1:recvct))=recvBuf(1:recvct) - end do - else - sendtag = myid - sendct = nTiles_ana - call MPI_Send(cat_progn_incr_ana(:,iEns),sendct,MPI_cat_progn_type, & - 0,sendtag,mpicomm,mpierr) - end if - ! cat_progn_incr_f -> cat_progn_incr - call MPI_Scatterv( & - cat_progn_incr_f, N_catl_vec, low_ind-1, MPI_cat_progn_type, & - cat_progn_incr(:,iEns), N_catl, MPI_cat_progn_type, & - 0, mpicomm, mpierr) - end do - if (allocated(recvBuf)) deallocate(recvBuf) - if (allocated(cat_progn_incr_f)) deallocate(cat_progn_incr_f) - call cpu_time(t_end) - - ! Step 5: timing info - call MPI_Reduce(t_end-t_start,tmax,1,MPI_REAL,MPI_MAX,0,mpicomm,mpierr) - call MPI_Reduce(t_end-t_start,tmin,1,MPI_REAL,MPI_MIN,0,mpicomm,mpierr) - if (root_proc .and. logit) write (logunit,'(2A,ES10.3,A,ES10.3)') & - 'AnaLoadBal: Step 5 time taken (collect increments): ', & - ' max =', tmax, ', min =', tmin - !-AnaLoadBal-Output-Collection-ends-here- -#endif - - ! set flag that fresh increments are available - - fresh_incr = .true. - - ! cleanup - - if (allocated( Obs_pert_tmp)) deallocate(Obs_pert_tmp) - -#ifdef LDAS_MPI - if (allocated( cat_progn_incr_ana)) deallocate(cat_progn_incr_ana) - if (allocated( Obs_pred_ana)) deallocate(Obs_pred_ana) - do iproc=1,numprocs - if (allocated(indObsAna_vec(iproc)%ind)) & - deallocate(indObsAna_vec(iproc)%ind) - end do - if (allocated( Obs_ana)) deallocate(Obs_ana) - if (allocated( indObs_ana)) deallocate(indObs_ana) - if (allocated( cat_progn_ana)) deallocate(cat_progn_ana) - if (allocated( cat_param_ana)) deallocate(cat_param_ana) - if (allocated( met_force_ana)) deallocate(met_force_ana) - do iproc=1,numprocs - if (allocated(indTilesAna_vec(iproc)%ind)) & - deallocate(indTilesAna_vec(iproc)%ind) - end do - if (associated(tile_coord_ana)) deallocate(tile_coord_ana) - if (allocated( indTiles_ana)) deallocate(indTiles_ana) -#else - if (associated(Obs_pred_lH)) deallocate(Obs_pred_lH) - -#endif - - end if ! (N_obsf>0) .and. assimflag - - ! -------------------------------------------------------------- - ! - ! Obs bias - ! - ! B4. Update the bias tcount for latest obs - - if (N_obsbias_max > 0) & - call obs_bias_upd_tcount(date_time,dtstep_assim, & - N_catf, N_catl, N_obsl, N_obs_param, N_obsbias_max, f2l, & - obs_param, Observations_l(1:N_obsl), & - obs_bias) - - ! -------------------------------------------------------------- - - ! clean up - - if (associated(Obs_pred_l )) deallocate(Obs_pred_l) - - if (associated(N_tile_in_cell_ij_f)) deallocate(N_tile_in_cell_ij_f) - if (associated(tile_num_in_cell_ij_f)) deallocate(tile_num_in_cell_ij_f) - - ! write assimilated (scaled) SMAP Tb observations and select forecast states - ! into SMAP L4_SM aup file - - if (out_smapL4SMaup) & - call write_smapL4SMaup( 'obs_fcst', date_time, exp_id, N_ens, & - N_catl, N_catf, N_obsl, tile_coord_f, tile_grid_g, N_catl_vec, low_ind, & - N_obs_param, obs_param, Observations_l, cat_param, cat_progn ) - - end if ! end if (.true.) - - call date_and_time(date_string, time_string) - - if (logit) write (logunit,*) 'get_enkf_increments(): exit at ', & - date_string, ', ', time_string - - end subroutine get_enkf_increments - - ! ******************************************************************** - - subroutine addUniqueInts(src, dest, n_dest) - - ! add integers from the src array to the dest arr - ! provided that they don't already exist in dest - ! upon input, n_dest is the number of existing - ! entries. both n_dest and dest are updated - - ! input/output - integer, intent(in) :: src(:) - integer, intent(inout) :: n_dest - integer, intent(inout) :: dest(:) - - ! local - integer :: iInt, nInts - - nInts = size(src) - - if (n_dest==0) then - dest(1:nInts) = src - n_dest = nInts - else - do iInt=1,nInts - if(any(dest(1:n_dest)==src(iInt))) then - ! src(iInt) exists in dset(1:n_dset) - cycle - else - n_dest = n_dest + 1 - dest(n_dest) = src(iInt) - end if - end do - end if - - end subroutine addUniqueInts - - ! ******************************************************************** - - subroutine apply_enkf_increments( N_catd, N_ens, update_type, & - cat_param, cat_progn_incr, cat_progn ) - - implicit none - - ! reichle, 19 Oct 2005 - - ! removed call to subroutine recompute_diagnostics() - ! -reichle+csdraper, 30 Oct 2013 - - integer, intent(in) :: N_catd, N_ens, update_type - - type(cat_param_type), dimension(N_catd), intent(in) :: cat_param - - type(cat_progn_type), dimension(N_catd,N_ens), intent(in) :: cat_progn_incr - - type(cat_progn_type), dimension(N_catd,N_ens), intent(inout) :: cat_progn - - ! ----------------- - - integer :: n, n_e, ii - - logical :: cat_progn_has_changed, check_snow - - character(len=*), parameter :: Iam = 'apply_enkf_increments' - - ! ---------------------------------------------------------------- - ! - ! apply increments - - cat_progn_has_changed = .true. ! conservative initialization - - check_snow = .true. ! conservative initialization - - select_update_type: select case (update_type) - - case (1,2) select_update_type ! soil moisture update - - if (logit) write (logunit,*) & - 'apply_enkf_increments(): applying soil moisture increments' - - do n=1,N_catd - do n_e=1,N_ens - - cat_progn(n,n_e)%srfexc = & - cat_progn(n,n_e)%srfexc + cat_progn_incr(n,n_e)%srfexc - cat_progn(n,n_e)%rzexc = & - cat_progn(n,n_e)%rzexc + cat_progn_incr(n,n_e)%rzexc - cat_progn(n,n_e)%catdef = & - cat_progn(n,n_e)%catdef + cat_progn_incr(n,n_e)%catdef - - end do - end do - - cat_progn_has_changed = .true. - - case (3) select_update_type ! Tskin update - - if (logit) write (logunit,*) & - 'apply_enkf_increments(): NOT applying Tskin increments' - - cat_progn_has_changed = .false. - - case (4,7) select_update_type ! Tskin/ght1 update - - if (logit) write (logunit,*) & - 'apply_enkf_increments(): applying Tskin/ght1 increments' - - do n=1,N_catd - do n_e=1,N_ens - - cat_progn(n,n_e)%tc1 = & - cat_progn(n,n_e)%tc1 + cat_progn_incr(n,n_e)%tc1 - cat_progn(n,n_e)%tc2 = & - cat_progn(n,n_e)%tc2 + cat_progn_incr(n,n_e)%tc2 - cat_progn(n,n_e)%tc4 = & - cat_progn(n,n_e)%tc4 + cat_progn_incr(n,n_e)%tc4 - cat_progn(n,n_e)%ght(1) = & - cat_progn(n,n_e)%ght(1) + cat_progn_incr(n,n_e)%ght(1) - - end do - end do - - cat_progn_has_changed = .true. - - case (5) select_update_type ! Tskin/ght1 update - - if (logit) write (logunit,*) & - 'apply_enkf_increments(): NOT applying Tskin/ght1 increments' - - cat_progn_has_changed = .false. - - case (6,8,9,10,13) select_update_type ! soil moisture and temperature update - - ! some of the increments fields below may be zero by design - ! (e.g., tc[X]=ght(1)=0 in update_type=13 when only sfmc or sfds obs are assimilated; - ! or catdef=0 in update_type 10 or 13 when tile has mineral soil) - - if (logit) write (logunit,*) & - 'apply_enkf_increments(): applying soil moisture and Tskin/ght1 increments' - - do n=1,N_catd - do n_e=1,N_ens - - cat_progn(n,n_e)%srfexc = & - cat_progn(n,n_e)%srfexc + cat_progn_incr(n,n_e)%srfexc - cat_progn(n,n_e)%rzexc = & - cat_progn(n,n_e)%rzexc + cat_progn_incr(n,n_e)%rzexc - cat_progn(n,n_e)%catdef = & - cat_progn(n,n_e)%catdef + cat_progn_incr(n,n_e)%catdef - - cat_progn(n,n_e)%tc1 = & - cat_progn(n,n_e)%tc1 + cat_progn_incr(n,n_e)%tc1 - cat_progn(n,n_e)%tc2 = & - cat_progn(n,n_e)%tc2 + cat_progn_incr(n,n_e)%tc2 - cat_progn(n,n_e)%tc4 = & - cat_progn(n,n_e)%tc4 + cat_progn_incr(n,n_e)%tc4 - - cat_progn(n,n_e)%ght(1) = & - cat_progn(n,n_e)%ght(1) + cat_progn_incr(n,n_e)%ght(1) - - end do - end do - - cat_progn_has_changed = .true. - - check_snow = .false. ! turn off for now to maintain 0-diff w/ SMAP Tb DA test case - - case(11) select_update_type ! empirical MODIS SCF update - - do n=1,N_catd ! for each tile - - do n_e=1,N_ens ! for each ensemble member - - do ii=1,N_snow ! for each snow layer - - cat_progn(n,n_e)%wesn(ii) = & - cat_progn(n,n_e)%wesn(ii) + cat_progn_incr(n,n_e)%wesn(ii) - - cat_progn(n,n_e)%sndz(ii) = & - cat_progn(n,n_e)%sndz(ii) + cat_progn_incr(n,n_e)%sndz(ii) - - cat_progn(n,n_e)%htsn(ii) = & - cat_progn(n,n_e)%htsn(ii) + cat_progn_incr(n,n_e)%htsn(ii) - - end do - end do - end do - - cat_progn_has_changed = .true. - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown update_type') - - end select select_update_type - - ! ------------------------------------------------------------------ - ! - ! check (and possibly fix) cat_progn - - if (cat_progn_has_changed) then - - do n_e=1,N_ens - - call check_cat_progn( check_snow, N_catd, cat_param, cat_progn(:,n_e) ) - - end do - - end if - - end subroutine apply_enkf_increments - - ! ******************************************************************** - - subroutine output_ObsFcstAna(date_time, exp_id, & - N_obsl, Observations_l, N_obs_param, rf2f) - - ! obs space output: observations, obs space forecast, obs space analysis, and - ! associated error variances - ! - ! - reichle, 16 Jun 2011 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: exp_id - - integer, intent(in) :: N_obsl, N_obs_param - - - type(obs_type), dimension(N_obsl), intent(in) :: Observations_l - - integer, dimension(:), optional, intent(in) :: rf2f - - ! --------------------- - - ! locals - - character(40), parameter :: file_tag = 'ldas_ObsFcstAna' - character(40), parameter :: dir_name = 'ana' - - type(obs_type), dimension(:), allocatable :: Observations_f, Observations_tmp - - integer :: n, N_obsf - integer, dimension(:), allocatable :: rf_tilenums, tilenums - - integer, dimension(numprocs) :: N_obsl_vec, tmp_low_ind - - character(300) :: fname - -#ifdef LDAS_MPI - - integer :: this_species, ind_tmp, j - - integer, dimension(N_obs_param) :: N_per_species - integer, dimension(N_obs_param) :: species_low_ind - integer, dimension(N_obs_param) :: ind_within_species - -#endif - - ! -------------------------------------------------------------------- - - if (logit) write (logunit,*) 'writing ' // trim(file_tag) //' file' - - ! --------------------------------------------- - ! - ! gather local obs - -#ifdef LDAS_MPI - - call MPI_Gather( & - N_obsl, 1, MPI_integer, & - N_obsl_vec, 1, MPI_integer, & - 0, mpicomm, mpierr ) - -#else - - N_obsl_vec(1) = N_obsl - -#endif - - if (root_proc) then - - N_obsf = sum(N_obsl_vec) - - allocate(Observations_f(N_obsf)) - - tmp_low_ind(1) = 1 - - do n=1,numprocs-1 - - tmp_low_ind(n+1) = tmp_low_ind(n) + N_obsl_vec(n) - - end do - else - allocate(Observations_f(0)) - end if - -#ifdef LDAS_MPI - - call MPI_GATHERV( & - Observations_l, N_obsl, MPI_obs_type, & - Observations_f, N_obsl_vec, tmp_low_ind-1, MPI_obs_type, & - 0, mpicomm, mpierr ) - -#else - - Observations_f = Observations_l - -#endif - - ! -------------------------------------------------------------- - ! - ! write to file - - if (root_proc) then - -#ifdef LDAS_MPI - - ! sort observations according to species so that the ObsFcstAna - ! file looks the same regardless of the MPI configuration - ! - ! NOTE: within each species, observations should already be sorted according - ! to tilenum because of the loop through species in collect_obs() - - ! first loop: count how many obs there are per species - - N_per_species(1:N_obs_param) = 0 - - do n=1,N_obsf - - this_species = Observations_f(n)%species - - N_per_species(this_species) = N_per_species(this_species) + 1 - - end do - - ! get starting index of each species in sorted vector Observations_f - - species_low_ind(1) = 1 - - do j=1,N_obs_param-1 - - species_low_ind(j+1) = species_low_ind(j) + N_per_species(j) - - end do - - ! second loop: re-order Observations_f into Observations_tmp - - allocate(Observations_tmp(N_obsf)) - - ind_within_species(1:N_obs_param) = 0 - - do n=1,N_obsf - - this_species = Observations_f(n)%species - - ind_tmp = species_low_ind(this_species) + ind_within_species(this_species) - - Observations_tmp(ind_tmp) = Observations_f(n) - - ! NOTE: ind_within_species is "zero-based" - - ind_within_species(this_species) = ind_within_species(this_species) + 1 - - end do - - ! copy back into Observations_f - - do n=1,N_obsf - - Observations_f(n) = Observations_tmp(n) - - end do - - - deallocate(Observations_tmp) - -#endif ! LDAS_MPI - - ! reorder tilenum, so it is consistent with the order in tile_coord.bin file - if(present(rf2f)) then - allocate(rf_tilenums(N_obsf), tilenums(N_obsf)) - rf_tilenums = Observations_f(:)%tilenum - tilenums = rf2f(rf_tilenums) - Observations_f(:)%tilenum =tilenums - deallocate(rf_tilenums, tilenums) - endif - - ! write to file - - fname = get_io_filename( './', exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=-1, no_subdirs=.true. ) - - open( 10, file=fname, form='unformatted', action='write') - - ! write header - - write (10) N_obsf, date_time%year, date_time%month, & - date_time%day, date_time%hour, date_time%min, date_time%sec, & - date_time%dofyr, date_time%pentad - - ! write data - - ! Assuming a linear model and uncorrelated obs/model errors, - ! - ! the expected var of OminusF is HPHt + R, and - ! the expected var of OminusA is R - HAHt, where - ! - ! P = prior state error covariance - ! A = posterior state error covariance - ! H = observation operator - - write (10) (Observations_f(n)%assim, n=1,N_obsf) - write (10) (Observations_f(n)%species, n=1,N_obsf) - - write (10) (Observations_f(n)%tilenum, n=1,N_obsf) - - write (10) (Observations_f(n)%lon, n=1,N_obsf) - write (10) (Observations_f(n)%lat, n=1,N_obsf) - - write (10) (Observations_f(n)%obs, n=1,N_obsf) - write (10) (Observations_f(n)%obsvar, n=1,N_obsf) ! R - - write (10) (Observations_f(n)%fcst, n=1,N_obsf) - write (10) (Observations_f(n)%fcstvar, n=1,N_obsf) ! HPHt - - write (10) (Observations_f(n)%ana, n=1,N_obsf) - write (10) (Observations_f(n)%anavar, n=1,N_obsf) ! HAHt - - close(10,status='keep') - - end if - if (allocated(Observations_f)) deallocate(Observations_f) - - end subroutine output_ObsFcstAna - - ! ********************************************************************** - - subroutine output_ObsFcstAna_wrapper( out_ObsFcstAna, & - date_time, exp_id, & - N_obsl, N_obs_param, N_ens, & - N_catl, tile_coord_l, & - N_catf, tile_coord_f, pert_grid_g, & - N_catl_vec, low_ind, f2l, & - obs_param, & - met_force, lai, cat_param, cat_progn, mwRTM_param, & - Observations_l, rf2f ) - - implicit none - - ! reichle, 5 Jun 2006 - - ! changed intent of Observations for adaptive filtering - ! - reichle, 15 Dec 2006 - - ! major revisions for new obs handling and MPI - - logical, intent(in) :: out_ObsFcstAna - - - type(date_time_type), intent(in) :: date_time - - character(len=*), intent(in) :: exp_id - - integer, intent(in) :: N_obsl, N_obs_param, N_ens, N_catl, N_catf - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l ! input - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! input - - type(grid_def_type), intent(in) :: pert_grid_g - - integer, dimension(numprocs), intent(in) :: N_catl_vec, low_ind - - integer, dimension(N_catf), intent(in) :: f2l - - type(obs_param_type), dimension(N_obs_param), intent(in) :: & - obs_param - - type(met_force_type), dimension(N_catl), intent(in) :: met_force - - real, dimension(N_catl), intent(in) :: lai - - type(cat_param_type), dimension(N_catl), intent(in) :: cat_param - type(cat_progn_type), dimension(N_catl,N_ens), intent(in) :: cat_progn - - type(mwRTM_param_type), dimension(N_catl), intent(in) :: mwRTM_param - - - type(obs_type), dimension(:), pointer :: Observations_l ! inout - - integer, dimension(N_catf), optional, intent(in) :: rf2f ! re-ordered to LDASsa - - ! local variables - - real, dimension(:,:), pointer :: Obs_pred_l => null() - - integer :: N_obsl_tmp - - - character(len=*), parameter :: Iam = 'output_ObsFcstAna_wrapper' - - ! -------------------------------------------------------------- - - nullify(Obs_pred_l) - - ! output "O-A" (obs - analysis) whenever innovations are output - - if (out_ObsFcstAna) then - - ! compute model forecast of observations - - N_obsl_tmp = N_obsl ! cannot pass N_obsl into get_obs_pred() b/c of intent(in) - - call get_obs_pred( & - .false., & ! -> after EnKF update - N_obs_param, N_ens, & - N_catl, tile_coord_l, & - N_catf, tile_coord_f, f2l, & - N_catl_vec, low_ind, pert_grid_g, & - obs_param, & - met_force, lai, cat_param, cat_progn, mwRTM_param, & - N_obsl_tmp, Observations_l, Obs_pred_l ) - - ! clean up - - if (associated(Obs_pred_l)) deallocate(Obs_pred_l) - - ! write out model, observations, and "OminusA" information - - call output_ObsFcstAna( date_time, exp_id, N_obsl, & - Observations_l(1:N_obsl), N_obs_param, rf2f=rf2f ) - - end if - - end subroutine output_ObsFcstAna_wrapper - - ! ********************************************************************** - - subroutine output_smapL4SMaup( date_time, work_path, exp_id, dtstep_assim, & - N_ens, N_catl, N_catf, N_obsl_max, & - tile_coord_f, tile_grid_g, pert_grid_f, & - N_catl_vec, low_ind, l2f, N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - N_obs_param, obs_param, Observations_l, cat_param, cat_progn ) - - ! wrapper for output of original (unscaled) SMAP Tb observations into - ! SMAP L4_SM "aup" (analysis update) - ! - ! see subroutine write_smapL4SMaup() for details - ! - ! reichle, 2 May 2013 - ! reichle, 11 Dec 2013 - added 'SMOS_fit_Tb*' obs species - ! (needed for L4_SM_SMOS prototype product) - ! - ! ------------------------------------------------------------------- - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - integer, intent(in) :: dtstep_assim - integer, intent(in) :: N_ens, N_catl, N_catf - integer, intent(in) :: N_obsl_max, N_obs_param - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! input - - type(grid_def_type), intent(in) :: tile_grid_g - type(grid_def_type), intent(in) :: pert_grid_f - - integer, dimension(numprocs), intent(in) :: N_catl_vec - integer, dimension(numprocs), intent(in) :: low_ind - - integer, dimension(N_catl), intent(in) :: l2f - - ! N_tile_in_cell_ij and tile_num_in_cell_ij are on the "full" domain - ! and guaranteed to be allocated ONLY for the root_proc - ! (but may be allocated on all processors depending on obs_param%FOV) - - integer, dimension(:,:), pointer :: N_tile_in_cell_ij_f ! input - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij_f ! input - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(obs_type), dimension(:), pointer :: Observations_l ! input - - type(cat_param_type), dimension(N_catl), intent(in) :: cat_param - type(cat_progn_type), dimension(N_catl,N_ens), intent(in) :: cat_progn - - ! ------------------------------------------ - - ! local variables - - logical :: found_obs_f - - integer :: j, n, N_obs_param_tmp, N_obsl_tmp - - type(obs_param_type), dimension(N_obs_param) :: obs_param_tmp - - ! --------------------------------------------------------------------- - - ! create custom obs_param_tmp that contains only relevant SMAP obs - ! and disables scaling - - j = 0 - - do n=1,N_obs_param - - select case (trim(obs_param(n)%descr)) - - case('SMAP_L2AP_Tbh_D','SMAP_L2AP_Tbv_D', & - 'SMAP_L2AP_Tbh_A','SMAP_L2AP_Tbv_A', & - 'SMAP_L1C_Tbh_D', 'SMAP_L1C_Tbv_D', & - 'SMAP_L1C_Tbh_A', 'SMAP_L1C_Tbv_A', & - 'SMAP_L1C_Tbh_E09_D', 'SMAP_L1C_Tbv_E09_D', & - 'SMAP_L1C_Tbh_E09_A', 'SMAP_L1C_Tbv_E09_A', & - 'SMAP_L1C_Tbh_E27_D', 'SMAP_L1C_Tbv_E27_D', & - 'SMAP_L1C_Tbh_E27_A', 'SMAP_L1C_Tbv_E27_A', & - 'SMOS_fit_Tbh_D', 'SMOS_fit_Tbv_D', & - 'SMOS_fit_Tbh_A', 'SMOS_fit_Tbv_A' & - ) - - j = j + 1 - - obs_param_tmp(j) = obs_param(n) - - obs_param_tmp(j)%scale = .false. ! disable scaling - - case default - - ! do nothing - - end select - - end do - - N_obs_param_tmp = j - - ! collect relevant observations (note: out_obslog=.false. in this case) - - call collect_obs( & - work_path, exp_id, date_time, dtstep_assim, & - N_catl, & - N_catf, tile_coord_f, pert_grid_f, & - N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - N_catl_vec, low_ind, l2f, & - N_obs_param_tmp, obs_param_tmp(1:N_obs_param_tmp), N_obsl_max, .false., & - N_obsl_tmp, Observations_l, found_obs_f ) - - ! write appropriate fields (according to 'option') into file - - call write_smapL4SMaup( 'orig_obs', date_time, exp_id, N_ens, & - N_catl, N_catf, N_obsl_tmp, tile_coord_f, tile_grid_g, & - N_catl_vec, low_ind, & - N_obs_param_tmp, obs_param_tmp(1:N_obs_param_tmp), Observations_l, & - cat_param, cat_progn ) - - end subroutine output_smapL4SMaup - - ! ********************************************************************** - - subroutine write_smapL4SMaup( option, date_time, exp_id, N_ens, & - N_catl, N_catf, N_obsl, tile_coord_f, tile_grid_g, N_catl_vec, low_ind, & - N_obs_param, obs_param, Observations_l, cat_param, cat_progn ) - - ! output of custom collection for SMAP L4_SM "aup" (analysis update) - ! - ! can be used with "SMAP_L*_Tb*" or "SMOS_fit_Tb*" obs species, but *not* with - ! both simultaneously, which is checked in subroutine read_ens_upd_inputs() - ! - ! "aup" files are written in three stages (controlled by "option"): - ! - ! option = 'orig_obs' : write original obs (before scaling) into output file - ! - ! - tb_h_obs_time_sec ! real*8 - ! - tb_v_obs_time_sec ! real*8 - ! - tb_h_resolution_flag ! integer - ! - tb_v_resolution_flag ! integer - ! - tb_h_orbit_flag ! integer - ! - tb_v_orbit_flag ! integer - ! - tb_h_obs - ! - tb_v_obs - ! - ! option = 'obs_fcst' : append assimilated (scaled) obs and select fcst - ! fields into output file - ! - ! - tb_h_obs_assim - ! - tb_v_obs_assim - ! - tb_h_obs_errstd - ! - tb_v_obs_errstd - ! - ! - tb_h_forecast - ! - tb_v_forecast - ! - tb_h_forecast_ensstd - ! - tb_v_forecast_ensstd - ! - ! - sm_surface_forecast - ! - sm_rootzone_forecast - ! - sm_profile_forecast - ! - surface_temp_forecast - ! - soil_temp_layer1_forecast - - ! option = 'analysis' : append select analysis fields into output file - ! - ! - sm_surface_analysis - ! - sm_rootzone_analysis - ! - sm_profile_analysis - ! - surface_temp_analysis - ! - soil_temp_layer1_analysis - ! - ! - sm_surface_analysis_ensstd - ! - sm_rootzone_analysis_ensstd - ! - sm_profile_analysis_ensstd - ! - surface_temp_analysis_ensstd - ! - soil_temp_layer1_analysis_ensstd - ! - ! - ! reichle, 26 Apr 2013 - ! reichle, 11 Dec 2013 - added 'SMOS_fit_Tb*' obs species - ! (needed for L4_SM_SMOS prototype product) - ! reichle, 3 Feb 2014 - added output: "tb_[h/v]_obs_time_sec", "tb_[h/v]_orbit_flag" - ! reichle, 20 Nov 2014 - changed units of soil moisture output to [m3/m3] - ! reichle, 6 Jun 2016 - added Tb forecast for obs that cannot be scaled (and are not - ! assimilated) - ! - ! ------------------------------------------------------------------------------ - - implicit none - - character(*), intent(in) :: option - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: exp_id - - integer, intent(in) :: N_ens, N_catl, N_catf - integer, intent(in) :: N_obsl, N_obs_param - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! input - - type(grid_def_type), intent(in) :: tile_grid_g - - integer, dimension(numprocs), intent(in) :: N_catl_vec - integer, dimension(numprocs), intent(in) :: low_ind - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(obs_type), dimension(:), pointer :: Observations_l ! input - - type(cat_param_type), dimension(N_catl), intent(in) :: cat_param - type(cat_progn_type), dimension(N_catl,N_ens), intent(in) :: cat_progn - - ! -------------------------------------------------------------- - - ! local variables - - integer, parameter :: unitnum = 10 - - character(40), parameter :: file_tag = 'ldas_tile_inst_smapL4SMaup' - character(40), parameter :: dir_name = 'ana' - - logical :: use_real8, is_orbit, is_obsassim - - integer :: j, k, m, n, n_e, kmax - integer :: N_obsf, this_species - - real :: this_lat, this_lon, col_ind, row_ind - real :: nodatavalue, tol, existing_orbflag - - character(300) :: fname - character(40) :: position - - integer, dimension(numprocs) :: N_obsl_vec, tmp_low_ind - - type(obs_type), dimension(:), allocatable :: Observations_f - - integer, dimension(:), allocatable :: col_beg_9km, col_end_9km - integer, dimension(:), allocatable :: row_beg_9km, row_end_9km - - real, dimension(:), allocatable :: Obs_f_resflag - real, dimension(:), allocatable :: Obs_f_orbflag - real, dimension(:), allocatable :: Obs_f_tmpdata - real*8, dimension(:), allocatable :: Obs_f_tmpdata_8 - - real, dimension(:,:), allocatable :: data_h_9km_grid, data_v_9km_grid - real, dimension(:), allocatable :: data_h_9km_tile, data_v_9km_tile - - real*8, dimension(:,:), allocatable :: data_h_9km_grid_8, data_v_9km_grid_8 - real*8, dimension(:), allocatable :: data_h_9km_tile_8, data_v_9km_tile_8 - - integer, dimension(:,:), allocatable :: ndata_h_9km_grid, ndata_v_9km_grid - - real, dimension(:), allocatable :: tile_data_f - - real, dimension( N_catl) :: srfexc, rzexc, catdef - real, dimension( N_catl) :: ar1, ar2, ar4 - - real, dimension(N_gt, N_catl) :: tp - - real, dimension( N_catl, N_ens) :: sfmc, rzmc, prmc, tsurf, tp1 - - real, dimension( N_catl, 5) :: tile_mean_l, tile_std_l - - character(len=*), parameter :: Iam = 'write_smapL4SMaup' - character(len=400) :: err_msg - character(len=10) :: gridname_tmp - - ! -------------------------------------------------------------- - ! - ! smapL4SMaup output only works for 9 km EASE grids - - if ( index(tile_grid_g%gridtype, 'M09') == 0 ) then - err_msg = 'out_smapL4SMaup requires tile-space for 9 km EASEv1 or EASEv2 grid' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! -------------------------------------------------------------- - ! - ! assemble file name and open file - - if (root_proc) then - - fname = get_io_filename( './', exp_id, file_tag, & - date_time=date_time, dir_name=dir_name, ens_id=-1, no_subdirs=.true.) - - if (option=='orig_obs') then - - position='rewind' ! open file at the beginning - - elseif (option=='obs_fcst' .or. option=='analysis') then - - position='append' ! append to file - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown option') - - end if - - open(unitnum, file=fname, form='unformatted', action='write', & - position=position) - - end if - - ! -------------------------------------------------------------- - ! - ! observation-space output - - if (option=='orig_obs' .or. option=='obs_fcst') then - - ! gather local obs - -#ifdef LDAS_MPI - - call MPI_Gather( & - N_obsl, 1, MPI_integer, & - N_obsl_vec, 1, MPI_integer, & - 0, mpicomm, mpierr ) - -#else - - N_obsl_vec(1) = N_obsl - -#endif - - if (root_proc) then - - N_obsf = sum(N_obsl_vec) - - allocate(Observations_f(N_obsf)) - - tmp_low_ind(1) = 1 - - do n=1,numprocs-1 - - tmp_low_ind(n+1) = tmp_low_ind(n) + N_obsl_vec(n) - - end do - else - allocate(Observations_f(0)) - end if - -#ifdef LDAS_MPI - - call MPI_GATHERV( & - Observations_l, N_obsl, MPI_obs_type, & - Observations_f, N_obsl_vec, tmp_low_ind-1, MPI_obs_type, & - 0, mpicomm, mpierr ) - -#else - - Observations_f = Observations_l - -#endif - - ! ----------------------------------------------------- - - if (root_proc) then - - ! determine mapping from Observations vector onto global 9 km EASE grid - - allocate(col_beg_9km( N_obsf)) - allocate(col_end_9km( N_obsf)) - allocate(row_beg_9km( N_obsf)) - allocate(row_end_9km( N_obsf)) - - allocate(Obs_f_resflag(N_obsf)) - allocate(Obs_f_orbflag(N_obsf)) - - col_beg_9km = -8888 - col_end_9km = -8888 - row_beg_9km = -8888 - row_end_9km = -8888 - - Obs_f_resflag = nodata_generic - Obs_f_orbflag = nodata_generic - - do n=1,N_obsf - - this_species = Observations_f(n)%species - - this_lat = Observations_f(n)%lat - this_lon = Observations_f(n)%lon - - ! obtain i,j index range of this obs on global 9 km EASE grid - - select case (trim(obs_param(this_species)%descr)) - - case('SMAP_L2AP_Tbh_D', 'SMAP_L2AP_Tbv_D', & - 'SMAP_L2AP_Tbh_A', 'SMAP_L2AP_Tbv_A', & - 'SMAP_L1C_Tbh_E09_D', 'SMAP_L1C_Tbv_E09_D', & - 'SMAP_L1C_Tbh_E09_A', 'SMAP_L1C_Tbv_E09_A' & - ) - - if (index(tile_grid_g%gridtype, 'M09') /=0) then - call ease_convert(trim(tile_grid_g%gridtype), this_lat, this_lon, col_ind, row_ind) - endif - - ! col_ind and row_ind are zero-based, need one-based index here - - col_beg_9km(n) = nint(col_ind)+1 - col_end_9km(n) = col_beg_9km(n) - - row_beg_9km(n) = nint(row_ind)+1 - row_end_9km(n) = row_beg_9km(n) - - Obs_f_resflag(n) = 2 - Obs_f_orbflag(n) = obs_param(this_species)%orbit - - case('SMAP_L1C_Tbh_E27_D', 'SMAP_L1C_Tbv_E27_D', & - 'SMAP_L1C_Tbh_E27_A', 'SMAP_L1C_Tbv_E27_A' & - ) - - if (index(tile_grid_g%gridtype, 'M09') /=0) then - call ease_convert(trim(tile_grid_g%gridtype), this_lat, this_lon, col_ind, row_ind) - endif - - ! col_ind and row_ind are zero-based, need one-based index here - ! L1C E27 spacing is one every three in each direction (~27-km spacing) - - col_beg_9km(n) = max( (nint(col_ind)-1)+1, 1) - col_end_9km(n) = min( col_beg_9km(n)+2, 3856) - - row_beg_9km(n) = max( (nint(row_ind)-1)+1, 1) - row_end_9km(n) = min( row_beg_9km(n)+2, 1624) - - Obs_f_resflag(n) = 3 - Obs_f_orbflag(n) = obs_param(this_species)%orbit - - case('SMAP_L1C_Tbh_D', 'SMAP_L1C_Tbv_D', & - 'SMAP_L1C_Tbh_A', 'SMAP_L1C_Tbv_A', & - 'SMOS_fit_Tbh_D', 'SMOS_fit_Tbv_D', & - 'SMOS_fit_Tbh_A', 'SMOS_fit_Tbv_A' & - ) - - if (index(tile_grid_g%gridtype, 'M09') /=0) then - ! subindex (1:7) to get the string EASEvx_ - gridname_tmp = tile_grid_g%gridtype(1:7)//'M36' - call ease_convert(gridname_tmp, this_lat, this_lon, col_ind, row_ind) - endif - - ! col_ind and row_ind are zero-based, need one-based index here - - col_beg_9km(n) = nint(col_ind) *4 + 1 - col_end_9km(n) = (nint(col_ind)+1)*4 - - row_beg_9km(n) = nint(row_ind) *4 + 1 - row_end_9km(n) = (nint(row_ind)+1)*4 - - Obs_f_resflag(n) = 1 - Obs_f_orbflag(n) = obs_param(this_species)%orbit - - case default - - ! do nothing - - end select - - end do ! loop through Observations_f - - ! ---------------------------------------- - - ! map Observations%[xx] fields onto global 9km EASE grid, - - allocate(ndata_h_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - allocate(ndata_v_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - - if (option=='orig_obs') then - - kmax = 4 - - ! for "orig_obs" and k==1, need real*8 - ! (switch to regular real within "k=1,kmax" loop when "k==2") - - use_real8 = .true. - - allocate(Obs_f_tmpdata_8(N_obsf)) - - allocate(data_h_9km_grid_8(tile_grid_g%N_lon,tile_grid_g%N_lat)) - allocate(data_v_9km_grid_8(tile_grid_g%N_lon,tile_grid_g%N_lat)) - - allocate(data_h_9km_tile_8(N_catf)) - allocate(data_v_9km_tile_8(N_catf)) - - else ! "obs_fcst" - - kmax = 4 - - use_real8 = .false. - - allocate(Obs_f_tmpdata(N_obsf)) - - allocate(data_h_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - allocate(data_v_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - - allocate(data_h_9km_tile(N_catf)) - allocate(data_v_9km_tile(N_catf)) - - end if - - ! loop through individual output fields - - do k=1,kmax - - if (option=='orig_obs') then - - if (k==2) then - - ! switch allocatable arrays to default type for real - ! (real*8 were needed only for k==1) - - use_real8 = .false. - - deallocate(Obs_f_tmpdata_8) - - deallocate(data_h_9km_grid_8) - deallocate(data_v_9km_grid_8) - - deallocate(data_h_9km_tile_8) - deallocate(data_v_9km_tile_8) - - allocate(Obs_f_tmpdata(N_obsf)) - - allocate(data_h_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - allocate(data_v_9km_grid(tile_grid_g%N_lon,tile_grid_g%N_lat)) - - allocate(data_h_9km_tile(N_catf)) - allocate(data_v_9km_tile(N_catf)) - - end if - - ! "orig_obs" - - is_obsassim = .false. - - select case (k) - - case(1); Obs_f_tmpdata_8 = Observations_f(1:N_obsf)%time; is_orbit = .false. - case(2); Obs_f_tmpdata = Obs_f_resflag; is_orbit = .false. - case(3); Obs_f_tmpdata = Obs_f_orbflag; is_orbit = .true. - case(4); Obs_f_tmpdata = Observations_f(1:N_obsf)%obs; is_orbit = .false. - - end select - - else ! "obs_fcst" - - is_orbit = .false. - - select case (k) - - case(1); Obs_f_tmpdata = Observations_f(1:N_obsf)%obs; is_obsassim = .true. - case(2); Obs_f_tmpdata = Observations_f(1:N_obsf)%obsvar; is_obsassim = .true. ! see sqrt below - case(3); Obs_f_tmpdata = Observations_f(1:N_obsf)%fcst; is_obsassim = .false. - case(4); Obs_f_tmpdata = Observations_f(1:N_obsf)%fcstvar; is_obsassim = .false. ! see sqrt below - - end select - - ! convert *var into *std (but preserve no-data-values) - - if (k==2 .or. k==4) then - - do m=1,N_obsf - - nodatavalue = obs_param(Observations_f(m)%species)%nodata - - tol = abs(nodatavalue*nodata_tolfrac_generic) - - if (abs(Obs_f_tmpdata(m)-nodatavalue)>tol) & - Obs_f_tmpdata(m) = sqrt(Obs_f_tmpdata(m)) - - end do - - end if - - end if - - ! map "Obs_f_tmpdata" onto global 9 km EASE grid - - ndata_h_9km_grid = 0 - ndata_v_9km_grid = 0 - - if (use_real8) then - - data_h_9km_grid_8 = 0.0D0 - data_v_9km_grid_8 = 0.0D0 - - else - - data_h_9km_grid = 0. - data_v_9km_grid = 0. - - end if - - ! orbit flag requires special case - - if (is_orbit) then - - data_h_9km_grid = nodata_generic - data_v_9km_grid = nodata_generic - - tol = abs(nodata_generic*nodata_tolfrac_generic) - - end if - - do n=1,N_obsf - - ! write "obs_assim" (and obsvar) only if assimilated - - if ( (is_obsassim .and. Observations_f(n)%assim) .or. (.not. is_obsassim) ) then - - this_species = Observations_f(n)%species - - select case (trim(obs_param(this_species)%descr)) - - case('SMAP_L1C_Tbh_D', 'SMAP_L1C_Tbh_A', & - 'SMAP_L1C_Tbh_E09_D', 'SMAP_L1C_Tbh_E09_A', & - 'SMAP_L1C_Tbh_E27_D', 'SMAP_L1C_Tbh_E27_A', & - 'SMAP_L2AP_Tbh_D', 'SMAP_L2AP_Tbh_A', & - 'SMOS_fit_Tbh_D', 'SMOS_fit_Tbh_A' ) - - ! H-pol species - - if (is_orbit) then ! orbit flag - - ! determine existing orbit flag (scalar) - - existing_orbflag = data_h_9km_grid(col_beg_9km(n),row_beg_9km(n)) - - ! if the obs covers more than one 9 km grid cell, - ! make sure (existing) orbit flags are the same for all - ! 9 km grid cells in question - - if ( (col_beg_9km(n) < col_end_9km(n)) .or. & - (row_beg_9km(n) < row_end_9km(n)) ) then - - if (any( & - abs(data_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) ) & - - existing_orbflag) > 0.01 )) then - err_msg = 'orbit flags differ for 9 km grid cells (H-pol)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - ! set orbit flag of 9 km grid cells in question - - if (abs(existing_orbflag - nodata_generic) tol) then - - ! existing orbit flag differs from current, set to 0 - ! (indicating that obs in aup output were averaged - ! across different orbit directions) - - data_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = 0. - - end if - - else ! all fields *except* orbit flag - - ! ndata_grid(ind) = ndata_grid(ind) + 1 - - ndata_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - ndata_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + 1 - - ! data_grid(ind) = data_grid(ind) + Obs_f_tmpdata(n) - - if (use_real8) then - - data_h_9km_grid_8( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - data_h_9km_grid_8( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + Obs_f_tmpdata_8(n) - - else - - data_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - data_h_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + Obs_f_tmpdata(n) - - end if - - end if - - case('SMAP_L1C_Tbv_D', 'SMAP_L1C_Tbv_A', & - 'SMAP_L1C_Tbv_E09_D', 'SMAP_L1C_Tbv_E09_A', & - 'SMAP_L1C_Tbv_E27_D', 'SMAP_L1C_Tbv_E27_A', & - 'SMAP_L2AP_Tbv_D', 'SMAP_L2AP_Tbv_A', & - 'SMOS_fit_Tbv_D', 'SMOS_fit_Tbv_A' ) - - ! V-pol species - - if (is_orbit) then ! orbit flag - - ! determine existing orbit flag (scalar) - - existing_orbflag = data_v_9km_grid(col_beg_9km(n),row_beg_9km(n)) - - ! if the obs covers more than one 9 km grid cell, - ! make sure (existing) orbit flags are the same for all - ! 9 km grid cells in question - - if ( (col_beg_9km(n) < col_end_9km(n)) .or. & - (row_beg_9km(n) < row_end_9km(n)) ) then - - if (any( & - abs(data_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) ) & - - existing_orbflag) > 0.01 )) then - err_msg = 'orbit flags differ for 9 km grid cells (V-pol)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - end if - - ! set orbit flag of 9 km grid cells in question - - if (abs(existing_orbflag - nodata_generic) tol) then - - ! existing orbit flag differs from current, set to 0 - ! (indicating that obs in aup output were averaged - ! across different orbit directions) - - data_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = 0. - - end if - - else ! all fields *except* orbit flag - - ! ndata_grid(ind) = ndata_grid(ind) + 1 - - ndata_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - ndata_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + 1 - - ! data_grid(ind) = data_grid(ind) + Obs_f_tmpdata(n) - - if (use_real8) then - - data_v_9km_grid_8( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - data_v_9km_grid_8( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + Obs_f_tmpdata_8(n) - - else - - data_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - = & - data_v_9km_grid( & - col_beg_9km(n):col_end_9km(n), & - row_beg_9km(n):row_end_9km(n) & - ) & - + Obs_f_tmpdata(n) - - end if - - end if - - case default - - ! do nothing - - end select - - end if ! write "obs_assim" (and obsvar) only if assimilated - - end do ! n=1,N_obsf - - ! normalize and set to nodata as needed - - if (.not. is_orbit) then - - ! H-pol species - - if (use_real8) then - - where (ndata_h_9km_grid>1) - - data_h_9km_grid_8 = data_h_9km_grid_8/real(ndata_h_9km_grid,kind(0.0D0)) - - elsewhere (ndata_h_9km_grid==0) - - data_h_9km_grid_8 = real(nodata_generic,kind(0.0D0)) - - end where - - else - - where (ndata_h_9km_grid>1) - - data_h_9km_grid = data_h_9km_grid /real(ndata_h_9km_grid) - - elsewhere (ndata_h_9km_grid==0) - - data_h_9km_grid = nodata_generic - - end where - - end if - - ! V-pol species - - if (use_real8) then - - where (ndata_v_9km_grid>1) - - data_v_9km_grid_8 = data_v_9km_grid_8/real(ndata_v_9km_grid,kind(0.0D0)) - - elsewhere (ndata_v_9km_grid==0) - - data_v_9km_grid_8 = real(nodata_generic,kind(0.0D0)) - - end where - - else - - where (ndata_v_9km_grid>1) - - data_v_9km_grid = data_v_9km_grid /real(ndata_v_9km_grid) - - elsewhere (ndata_v_9km_grid==0) - - data_v_9km_grid = nodata_generic - - end where - - end if - - end if ! (.not. is_orbit) - - ! done mapping to 9 km grid - - ! ----------------------------------- - ! - ! map to tile space - - if (use_real8) then - - data_h_9km_tile_8 = real(nodata_generic,kind(0.0D0)) ! init (not in grid2tile!) - data_v_9km_tile_8 = real(nodata_generic,kind(0.0D0)) ! init (not in grid2tile!) - - call grid2tile( tile_grid_g, N_catf, tile_coord_f%i_indg, tile_coord_f%j_indg, data_h_9km_grid_8, & - data_h_9km_tile_8 ) - - call grid2tile( tile_grid_g, N_catf, tile_coord_f%i_indg, tile_coord_f%j_indg, data_v_9km_grid_8, & - data_v_9km_tile_8 ) - - ! write into file - - write (unitnum) ( data_h_9km_tile_8(n) , n=1,N_catf) - write (unitnum) ( data_v_9km_tile_8(n) , n=1,N_catf) - - else - - data_h_9km_tile = nodata_generic ! initialize (not done in grid2tile!) - data_v_9km_tile = nodata_generic ! initialize (not done in grid2tile!) - - call grid2tile( tile_grid_g, N_catf, tile_coord_f%i_indg,tile_coord_f%j_indg, data_h_9km_grid, & - data_h_9km_tile ) - - call grid2tile( tile_grid_g, N_catf, tile_coord_f%i_indg,tile_coord_f%j_indg, data_v_9km_grid, & - data_v_9km_tile ) - - ! write into file - - if (option=='orig_obs' .and. (k==2 .or. k==3)) then - - ! convert to integer before writing to file - - write (unitnum) (nint(data_h_9km_tile(n)), n=1,N_catf) - write (unitnum) (nint(data_v_9km_tile(n)), n=1,N_catf) - - else - - write (unitnum) ( data_h_9km_tile(n) , n=1,N_catf) - write (unitnum) ( data_v_9km_tile(n) , n=1,N_catf) - - end if - - end if - - end do ! loop through k=1,kmax - - ! clean up - - - deallocate(col_beg_9km) - deallocate(col_end_9km) - deallocate(row_beg_9km) - deallocate(row_end_9km) - - deallocate(Obs_f_resflag) - deallocate(Obs_f_orbflag) - - deallocate(ndata_h_9km_grid) - deallocate(ndata_v_9km_grid) - - deallocate(Obs_f_tmpdata) - - deallocate(data_h_9km_grid) - deallocate(data_v_9km_grid) - - deallocate(data_h_9km_tile) - deallocate(data_v_9km_tile) - - end if ! root_proc - - if(allocated(Observations_f)) deallocate(Observations_f) - - end if ! (option=='orig_obs' .or. option=='obs_fcst') - - ! -------------------------------------------------------------- - ! - ! assemble state-space data for writing as needed - - if (option=='obs_fcst' .or. option=='analysis') then - - ! diagnose variables of interest for the ensemble - - do n_e=1,N_ens - - srfexc = cat_progn(:,n_e)%srfexc - rzexc = cat_progn(:,n_e)%rzexc - catdef = cat_progn(:,n_e)%catdef - - call catch_calc_soil_moist( & - N_catl, cat_param%dzsf, cat_param%vgwmax, & - cat_param%cdcr1, cat_param%cdcr2, cat_param%psis, & - cat_param%bee, cat_param%poros, cat_param%wpwet, & - cat_param%ars1, cat_param%ars2, cat_param%ars3, & - cat_param%ara1, cat_param%ara2, cat_param%ara3, & - cat_param%ara4, cat_param%arw1, cat_param%arw2, & - cat_param%arw3, cat_param%arw4, & - cat_param%bf1, cat_param%bf2, & - srfexc, rzexc, catdef, & - ar1, ar2, ar4, sfmc(:,n_e), rzmc(:,n_e), prmc(:,n_e) ) - - call catch_calc_tsurf( N_catl, & - cat_progn(:,n_e)%tc1, cat_progn(:,n_e)%tc2, cat_progn(:,n_e)%tc4, & - catprogn2wesn(N_catl,cat_progn(:,n_e)), & - catprogn2htsn(N_catl,cat_progn(:,n_e)), & - ar1, ar2, ar4, & - tsurf(:,n_e) ) - - ! NOTE: "tp" is returned in CELSIUS [for consistency w/ catchment.F90] - - call catch_calc_tp( N_catl, cat_param%poros, & - catprogn2ghtcnt(N_catl,cat_progn(:,n_e)), tp ) - - tp1(:,n_e) = tp(1,:) + MAPL_TICE - - end do - - ! compute ensemble mean values and std-dev - - call row_std( N_catl, N_ens, sfmc, tile_std_l(:,1), tile_mean_l(:,1) ) - call row_std( N_catl, N_ens, rzmc, tile_std_l(:,2), tile_mean_l(:,2) ) - call row_std( N_catl, N_ens, prmc, tile_std_l(:,3), tile_mean_l(:,3) ) - call row_std( N_catl, N_ens, tsurf, tile_std_l(:,4), tile_mean_l(:,4) ) - call row_std( N_catl, N_ens, tp1, tile_std_l(:,5), tile_mean_l(:,5) ) - - ! make sure mean *mc values are between 0. and porosity - - do j=1,N_catl - - tile_mean_l(j,1) = max( min( tile_mean_l(j,1), cat_param(j)%poros), 0.) - tile_mean_l(j,2) = max( min( tile_mean_l(j,2), cat_param(j)%poros), 0.) - tile_mean_l(j,3) = max( min( tile_mean_l(j,3), cat_param(j)%poros), 0.) - - end do - - ! make sure std-dev values are non-negative - - tile_std_l = max( tile_std_l, 0.) - - ! write out (append) ensemble mean values - ! - ! 1: sm_surface_[forecast/analysis] [m3 m-3] - ! 2: sm_rootzone_[forecast/analysis] [m3 m-3] - ! 3: sm_profile_[forecast/analysis] [m3 m-3] - ! 4: surface_temp_[forecast/analysis] [K] - ! 5: soil_temp_layer1_[forecast/analysis] [K] - - allocate(tile_data_f(N_catf)) - - do k=1,5 ! write output one field at a time - - ! gatherv tile data from local to full domain and map to grid - - call l2f_real( N_catl, N_catf, N_catl_vec, low_ind, & - tile_mean_l(:,k), tile_data_f) - - if (root_proc) write(unitnum) (tile_data_f(n), n=1,N_catf) - - end do - - if (option=='analysis') then - - ! write out (append) ensstd fields for analysis - - ! 1: sm_surface_analysis_ensstd [m3 m-3] - ! 2: sm_rootzone_analysis_ensstd [m3 m-3] - ! 3: sm_profile_analysis_ensstd [m3 m-3] - ! 4: surface_temp_analysis_ensstd [K] - ! 5: soil_temp_layer1_analysis_ensstd [K] - - do k=1,5 ! write output one field at a time - - ! gatherv tile data from local to full domain and map to grid - - call l2f_real( N_catl, N_catf, N_catl_vec, low_ind, & - tile_std_l(:,k), tile_data_f) - - if (root_proc) write(unitnum) (tile_data_f(n), n=1,N_catf) - - end do - - end if ! (option=='analysis') - - deallocate(tile_data_f) - - end if ! (option=='obs_fcst' .or. option=='analysis') - - ! -------------------------------------------------------------- - ! - ! close output file - - if (root_proc) close(unitnum,status='keep') - - end subroutine write_smapL4SMaup - - ! ----------------------------------------------------------------- - -end module clsm_ensupd_enkf_update - -! ============ EOF ========================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_glob_param.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_glob_param.F90 deleted file mode 100644 index 678a0978..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_glob_param.F90 +++ /dev/null @@ -1,176 +0,0 @@ - -module clsm_ensupd_glob_param - - ! global parameters for CLSM ens driver update - ! - ! must re-compile if any of these change - ! - ! reichle, 18 Jul 2005 - ! reichle, 14 Apr 2006 - "update_type" now in nml - - use MAPL_ConstantsMod, ONLY: MAPL_TICE - - implicit none - - private - - public :: N_obs_species_nml - public :: N_state_per_cat - public :: unitnum_obslog - public :: scale_temp - public :: scale_qa - public :: scale_capac - public :: scale_catdef - public :: scale_rzexc - public :: scale_srfexc - public :: scale_ght1 - public :: scale_ght2 - public :: scale_ght3 - public :: scale_ght4 - public :: scale_ght5 - public :: scale_ght6 - public :: scale_wesn - public :: scale_htsn - public :: scale_sndz - public :: FT_ANA_FT_THRESHOLD - public :: FT_ANA_LOWERBOUND_ASNOW - public :: FT_ANA_LOWERBOUND_TEFF - public :: FT_ANA_UPPERBOUND_TEFF - public :: SCF_ANA_ALPHA - public :: SCF_ANA_BETA - public :: SCF_ANA_MAXINCRSWE - public :: SCF_ANA_MINFCSTSWE - - public :: echo_clsm_ensupd_glob_param - - ! ----------------------------------------------------------------------- - ! - ! total number of all obs species defined in "ensupd" namelist file - ! (regardless of whether "assim" flag is true or false) - - integer, parameter :: N_obs_species_nml = 53 - - ! ---------------------------------------------------------------------- - ! - ! state and measurement dimensions - - integer, parameter :: N_state_per_cat = 25 - - ! ---------------------------------------------------------------------- - ! - ! unit number for obslog file - - integer, parameter :: unitnum_obslog = 4567 - - ! ---------------------------------------------------------------------- - ! - ! scaling parameters for states - ! - ! Catchment prognostic variables have very different scales. - ! The parameters below attempt to have all elements of the - ! State vector vary on a comparable scale (roughly 0-1) - - real, parameter :: scale_temp = 273.16 - - real, parameter :: scale_qa = 1.e-2 - - real, parameter :: scale_capac = .5 - - real, parameter :: scale_catdef = 500. - real, parameter :: scale_rzexc = 50. - real, parameter :: scale_srfexc = 5. - - ! for non-frozen conditions, ght(i) ~ 2.e6*dzgt(i)*tp(i) [deg C] - ! - ! assuming tp ~ 10 deg C, e.g. scale_ght1 = 2.e6 (with dzgt(1)~0.1 m) - - real, parameter :: scale_ght1 = 2.e6 - real, parameter :: scale_ght2 = 4.e6 - real, parameter :: scale_ght3 = 1.e7 - real, parameter :: scale_ght4 = 2.e7 - real, parameter :: scale_ght5 = 3.e7 - real, parameter :: scale_ght6 = 2.e8 - - real, parameter :: scale_wesn = 1. ! needs work - real, parameter :: scale_htsn = 1. ! needs work - real, parameter :: scale_sndz = 1. ! needs work - - ! ---------------------------------------------------------------- - ! - ! parameters for freeze/thaw (FT) analysis - - real, parameter :: FT_ANA_FT_THRESHOLD = 0.5 - - real, parameter :: FT_ANA_LOWERBOUND_ASNOW = 0.15 - - real, parameter :: FT_ANA_LOWERBOUND_TEFF = -1.0 + MAPL_TICE ! [Kelvin] - real, parameter :: FT_ANA_UPPERBOUND_TEFF = +1.0 + MAPL_TICE ! [Kelvin] - - ! ---------------------------------------------------------------- - ! - ! parameters for snow cover area fraction (SCF) analysis (modified from Toure et al. 2018) - - real, parameter :: SCF_ANA_ALPHA = 0.60 ! [-] add snow if asnow_fcst < asnow_obs*SCF_ANA_alpha (w/ "bias" adjustment for obs) - real, parameter :: SCF_ANA_BETA = 0.55 ! [-] remove snow if asnow_fcst >= asnow_obs*SCF_ANA_alpha .AND. asnow_obs < SCF_ANA_beta - real, parameter :: SCF_ANA_MAXINCRSWE = 5.0 ! [kg/m2] max total SWE increment - real, parameter :: SCF_ANA_MINFCSTSWE = 0.01 ! [kg/m2] threshold below which the ratio of swe_ana/swe_fcst becomes unreasonable - - ! ---------------------------------------------------------------- - -contains - - subroutine echo_clsm_ensupd_glob_param(unitnum) - - implicit none - - integer, intent(in) :: unitnum - - ! echo all global parameters - - write (unitnum,*) - write (unitnum,*) '--------------------------------------------------------' - write (unitnum,*) 'echo_clsm_ensupd_glob_param():' - write (unitnum,*) - write (unitnum,*) 'N_obs_species_nml = ', N_obs_species_nml - write (unitnum,*) - write (unitnum,*) 'N_state_per_cat = ', N_state_per_cat - write (unitnum,*) - write (unitnum,*) 'unitnum_obslog = ', unitnum_obslog - write (unitnum,*) - write (unitnum,*) 'scale_temp = ', scale_temp - write (unitnum,*) - write (unitnum,*) 'scale_qa = ', scale_qa - write (unitnum,*) - write (unitnum,*) 'scale_capac = ', scale_capac - write (unitnum,*) - write (unitnum,*) 'scale_catdef = ', scale_catdef - write (unitnum,*) 'scale_rzexc = ', scale_rzexc - write (unitnum,*) 'scale_srfexc = ', scale_srfexc - write (unitnum,*) - write (unitnum,*) 'scale_ght1 = ', scale_ght1 - write (unitnum,*) 'scale_ght2 = ', scale_ght2 - write (unitnum,*) 'scale_ght3 = ', scale_ght3 - write (unitnum,*) 'scale_ght4 = ', scale_ght4 - write (unitnum,*) 'scale_ght5 = ', scale_ght5 - write (unitnum,*) 'scale_ght6 = ', scale_ght6 - write (unitnum,*) - write (unitnum,*) 'scale_wesn = ', scale_wesn - write (unitnum,*) 'scale_htsn = ', scale_htsn - write (unitnum,*) 'scale_sndz = ', scale_sndz - write (unitnum,*) - - write (unitnum,*) 'FT_ANA_FT_THRESHOLD = ', FT_ANA_FT_THRESHOLD - write (unitnum,*) 'FT_ANA_LOWERBOUND_ASNOW = ', FT_ANA_LOWERBOUND_ASNOW - write (unitnum,*) 'FT_ANA_LOWERBOUND_TEFF = ', FT_ANA_LOWERBOUND_TEFF - write (unitnum,*) 'FT_ANA_UPPERBOUND_TEFF = ', FT_ANA_UPPERBOUND_TEFF - - write (unitnum,*) 'end echo_clsm_ensupd_glob_param()' - write (unitnum,*) '--------------------------------------------------------' - write (unitnum,*) - - end subroutine echo_clsm_ensupd_glob_param - -end module clsm_ensupd_glob_param - - -!======== EOF ============================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_read_obs.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_read_obs.F90 deleted file mode 100644 index e87b3df4..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_read_obs.F90 +++ /dev/null @@ -1,10448 +0,0 @@ -! -! this file contains subroutines for reading and processing observations -! for the GEOS5 land EnKF update algorithm -! -! reichle, 27 Jan 2005 -! reichle, 10 Jan 2011 - replaced "UVA" with "LPRM" -! reichle, 1 Jul 2015 - clarified definition of obs time stamp -! (J2000 seconds w/ 'TT12' epoch) -! lcandre2, 10 Jul 2021 - confirmed and cleaned up MODIS obs - -! added work_path to inputs of many subroutines so that "tmpfname" -! (needed several times for reading AMSR-E hdf files) is distinct for each job -! reichle, 27 Aug 2005 - -! ********************************************************************* - -module clsm_ensupd_read_obs - - use MAPL_BaseMod, ONLY: & - MAPL_UNDEF - - use MAPL_ConstantsMod, ONLY: & - MAPL_TICE - - use io_hdf5, ONLY: & - hdf5read - - use EASE_conv, ONLY: & - ease_convert, & - ease_extent - - use LDAS_ensdrv_globals, ONLY: & - logit, & - logunit, & - nodata_tolfrac_generic - - use clsm_ensupd_glob_param, ONLY: & - unitnum_obslog - - use LDAS_DateTimeMod, ONLY: & - date_time_type, & - augment_date_time, & - get_dofyr_pentad, & - datetime_le_refdatetime, & - datetime_lt_refdatetime, & - date_time2string, & - datetime_to_J2000seconds - - use enkf_types, ONLY: & - obs_type, & - obs_param_type - - use LDAS_TilecoordType, ONLY: & - tile_coord_type, & - grid_def_type - - use clsm_ensdrv_drv_routines, ONLY: & - f2l_real, & - f2l_real8, & - f2l_logical - - use LDAS_TilecoordRoutines, ONLY: & - get_tile_num_from_latlon - - use LDAS_ensdrv_mpi, ONLY: & - root_proc, & - numprocs, & - mpicomm, & - MPI_obs_type, & - mpierr - - use LDAS_exceptionsMod, ONLY: & - ldas_abort, & - ldas_warn, & - LDAS_GENERIC_ERROR, & - LDAS_GENERIC_WARNING - - use clsm_ensupd_upd_routines, ONLY: & - dist_km2deg - - implicit none - - include 'mpif.h' - - private - - public :: collect_obs - -contains - - ! ***************************************************************** - - subroutine read_ae_l2_sm_hdf( & - N_files, fnames, N_data, lon, lat, ae_l2_sm, ease_col, ease_row ) - - ! read soil moisture data from one or more AMSR-E Land hdf files - ! - ! return ONLY valid data points (ie. excluding no-data-values) - ! that also pass initial QC (based on "Surface Type" QC flag and on - ! Heterogeneity_Index ) - ! - ! reichle, 20 Sep 2005 - added "Surface Type" QC flag - ! reichle, 17 Nov 2005 - replace hdp with call to hdf library - ! reichle, 8 Feb 2006 - optionally read EASE row- and column index - ! - added Heterogeneity_Index QC - ! reichle, 10 Jan 2011 - revised "Surface Type" QC flag - - implicit none - - integer, intent(in) :: N_files - - character(*), dimension(N_files), intent(in) :: fnames - - integer, intent(out) :: N_data - - real, dimension(:), pointer :: lon, lat, ae_l2_sm ! output - - integer, dimension(:), pointer, optional :: ease_col, ease_row ! output - - ! local parameters - - integer, parameter :: N_fields = 7 - - character(19), dimension(N_fields), parameter :: field_names = (/ & - 'Longitude ', & ! 1 - 'Latitude ', & ! 2 - 'Surface_Type ', & ! 3 - 'Soil_Moisture ', & ! 4 - 'Row_Index ', & ! 5 - 'Column_Index ', & ! 6 - 'Heterogeneity_Index' /) ! 7 - - real, parameter :: scale_fac_Soil_Moisture = 1000.0; - - integer, parameter :: nodata = -9999 ! NOTE: integer - - ! Initial QC: - ! - ! "Surface_Type": Only "low vegetation" or "moderate vegetation" (and no precip, - ! frozen ground, etc) passes. - ! - ! "Heterogeneity_Index": Discard all pixels with - ! Heterogeneity_Index>max_Heterogeneity_Index - ! because they are likely mixed land/water pixels. See matlab code - ! "detect_coast_in_AMSRE_Land.m" - ! in land01:/home/reichle/NSIPP/AMSR/AMSR_E_Land/matlab/ - ! In this subroutine, Heterogeneity_Index is used on its raw form and - ! never scaled into units of Kelvin. - ! - ! Further info: - ! http://nsidc.org/data/docs/daac/ae_land_l2b_soil_moisture.gd.html - ! http://nsidc.org/data/amsre/versions.html - ! -reichle, 20 Sep 2005 - ! -reichle, 8 Feb 2006 - - integer, parameter :: max_Heterogeneity_Index = 500 ! = 5 Kelvin - - ! declarations of hdf functions - - integer :: hopen, vfstart, vsfatch, vsqfnelt, vsfseek, vsfsfld, vsfread - integer :: vsfdtch, vfend, hclose - - - ! declarations of hdf-related parameters and variables - - integer, dimension(N_files) :: file_id, vdata_id - - integer :: status, n_read, n_records, record_pos - - integer, parameter :: num_dds_block = 0 ! only important for writing hdf - - integer, parameter :: vdata_ref = 7 ! works for AMSRE_L2_Land - - integer, parameter :: DFACC_READ = 1 ! from hdf.inc - integer, parameter :: FULL_INTERLACE = 0 ! from hdf.inc - - ! local variables - - logical :: must_stop - - integer, dimension(N_files) :: N_data_tmp - - integer :: i, j, k, k_off - - integer, dimension(:), allocatable :: surface_type_qc_flag - integer, dimension(:), allocatable :: Heterogeneity_Index - - integer*2, dimension(:), allocatable :: tmpint2vec - real, dimension(:), allocatable :: tmprealvec - - character(len=*), parameter :: Iam = 'read_ae_l2_sm_hdf' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - ! determine number of data to be read from each file - - do j=1,N_files - - ! open and "start" hdf file - - file_id(j) = hopen( fnames(j), DFACC_READ, num_dds_block ) - - status = vfstart(file_id(j)) - - ! select vdata block that contains fields of interest - - vdata_id(j) = vsfatch(file_id(j), vdata_ref, 'r') - - ! determine number of records in vdata - - status = vsqfnelt(vdata_id(j), n_records) - - N_data_tmp(j) = n_records - - end do - - ! allocate pointers (must be deallocated outside this subroutine) - - must_stop = .false. - - if ( associated(lon) .or. associated(lat) .or. associated(ae_l2_sm) ) then - must_stop = .true. - end if - - if ( present(ease_col) ) then - if (associated(ease_col)) must_stop = .true. - end if - - if ( present(ease_row) ) then - if (associated(ease_row)) must_stop = .true. - end if - - if (must_stop) then - err_msg = 'output pointers must not be associated/allocated on input.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - N_data = sum(N_data_tmp) - - allocate(lon(N_data)) - allocate(lat(N_data)) - if (present(ease_col)) allocate(ease_col(N_data)) - if (present(ease_row)) allocate(ease_row(N_data)) - allocate(ae_l2_sm(N_data)) - - allocate(surface_type_qc_flag(N_data)) - allocate(Heterogeneity_Index(N_data)) - - ! read hdf data into arrays, concatenate data from N_files files - - k_off = 0 - - do j=1,N_files - - allocate(tmprealvec(N_data_tmp(j))) - allocate(tmpint2vec(N_data_tmp(j))) - - do i=1,N_fields - - ! go to start of record (zero-based count) - - record_pos = vsfseek(vdata_id(j), 0) - - ! pick the field to be read - - status = vsfsfld(vdata_id(j), field_names(i)) - - ! read data - - select case (i) - - case (1) - - n_read = vsfread( vdata_id(j), tmprealvec, & - N_data_tmp(j), FULL_INTERLACE) - - lon(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - case (2) - - n_read = vsfread( vdata_id(j), tmprealvec, & - N_data_tmp(j), FULL_INTERLACE) - - lat(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - case (3) - - n_read = vsfread( vdata_id(j) ,tmpint2vec, & - N_data_tmp(j), FULL_INTERLACE) - - surface_type_qc_flag(k_off+1:k_off+N_data_tmp(j)) = tmpint2vec - - ! overwrite surface_type_qc_flag with common pass/fail - ! (negative number -1 means fail) - - do k=1,N_data_tmp(j) - - ! keep only data with - ! - ! surface_type_qc_flag=128 ("moderate veg", and no other bits set) - ! surface_type_qc_flag=256 ("low veg", and no other bits set) - ! - ! http://nsidc.org/data/docs/daac/ae_land_l2b_soil_moisture.gd.html - - if (.not. ( & - (surface_type_qc_flag(k+k_off)==128) .or. & - (surface_type_qc_flag(k+k_off)==256) ) ) & - surface_type_qc_flag(k+k_off) = -1 - - end do - - case (4) - - n_read = vsfread(vdata_id(j), tmpint2vec, & - N_data_tmp(j), FULL_INTERLACE) - - do k=1,N_data_tmp(j) - if (tmpint2vec(k)/=nodata) then - ae_l2_sm(k+k_off) = real(tmpint2vec(k)) / & - scale_fac_Soil_Moisture - else - ae_l2_sm(k+k_off) = real(tmpint2vec(k)) - end if - end do - - case (5) - - if (present(ease_row)) then - - n_read = vsfread( vdata_id(j) ,tmpint2vec, & - N_data_tmp(j), FULL_INTERLACE) - - ease_row(k_off+1:k_off+N_data_tmp(j)) = tmpint2vec - - end if - - case (6) - - if (present(ease_col)) then - - n_read = vsfread( vdata_id(j) ,tmpint2vec, & - N_data_tmp(j), FULL_INTERLACE) - - ease_col(k_off+1:k_off+N_data_tmp(j)) = tmpint2vec - - end if - - case (7) - - n_read = vsfread( vdata_id(j) ,tmpint2vec, & - N_data_tmp(j), FULL_INTERLACE) - - Heterogeneity_Index(k_off+1:k_off+N_data_tmp(j)) = tmpint2vec - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown case') - - end select - - if (n_read/=N_data_tmp(j)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'ERROR reading hdf') - end if - - end do - - ! clean up - - deallocate(tmprealvec) - deallocate(tmpint2vec) - - ! close hdf files - - status = vsfdtch(vdata_id(j)) - - status = vfend(file_id(j)) - - status = hclose(file_id(j)) - - ! prepare next j - - k_off = k_off + N_data_tmp(j) - - end do - - ! ------------------------------------- - ! - ! eliminate no-data-values and data that fail initial QC - - j = 0 - - do i=1,N_data - - if ( (ae_l2_sm(i)>0.) .and. & ! any neg is nodata - (surface_type_qc_flag(i)>=0) .and. & ! any neg is fail - (Heterogeneity_Index(i)<=max_Heterogeneity_Index) & - ) then - - j=j+1 - - ae_l2_sm(j) = ae_l2_sm(i) - lon(j) = lon(i) - lat(j) = lat(i) - if (present(ease_col)) ease_col(j) = ease_col(i) - if (present(ease_row)) ease_row(j) = ease_row(i) - - end if - - end do - - N_data = j - - deallocate(surface_type_qc_flag) - deallocate(Heterogeneity_Index) - - end subroutine read_ae_l2_sm_hdf - - ! ***************************************************************** - - subroutine read_obs_ae_l2_sm( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, ae_l2_sm, std_ae_l2_sm ) - - ! Read observations of surface soil moisture from AMSR-E L2 files - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! If there are N > 1 observations in a given tile, - ! a "super-observation" is computed by averaging the N observations - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 25 Jul 2005 - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: ae_l2_sm - real, intent(out), dimension(N_catd) :: std_ae_l2_sm - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! AMSR_E_L2_Land files are available for approximately 50min periods - ! covering one ascending or descending swath. The filename indicates - ! the start time of the swath - ! "ae_time_offset" is used to find the mean time of the the interval - ! which is approximately the time of the equator overpass. - ! This time is assigned to all observations of the swath. - - integer, parameter :: ae_time_offset = 1500 ! 25 minutes in seconds - - character(4) :: DDHH - character(6) :: YYYYMM - character(8) :: date_string - character(10) :: time_string - character(300) :: tmpfname, tmpfname2 - character(400) :: cmd - - type(date_time_type) :: date_time_tmp - - integer :: i, ind, N_tmp, N_files - - character(300), dimension(:), allocatable :: fnames - - real, dimension(:), pointer :: tmp_obs, tmp_lat, tmp_lon - integer, dimension(:), pointer :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - character(len=*), parameter :: Iam = 'read_obs_ae_l2_sm' - - ! ------------------------------------------------------------------- - - nullify( tmp_obs, tmp_lat, tmp_lon, tmp_tile_num ) - - ! --------------- - - ! initialize - - found_obs = .false. - - ! find files that are within half-open interval - ! [date_time-dtstep_assim/2,date_time+dtstep_assim/2) - - date_time_tmp = date_time - - call augment_date_time( -(dtstep_assim/2 + ae_time_offset), date_time_tmp ) - - ! get tmp file name and remove file if it exists - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - tmpfname = trim(work_path) // '/' // 'tmp.' // trim(exp_id) & - // '.' // date_string // time_string - - cmd = '/bin/rm -f ' // tmpfname - - call Execute_command_line(trim(cmd)) - - ! identify all files within current assimilation interval - ! (list all files within hourly intervals) - - do i=1,(dtstep_assim/3600) - - write (YYYYMM,'(i6.6)') date_time_tmp%year*100 + date_time_tmp%month - write (DDHH, '(i4.4)') date_time_tmp%day *100 + date_time_tmp%hour - - cmd = 'ls ' // trim(this_obs_param%path) // '/' // YYYYMM(1:4) // & - '/M' // YYYYMM(5:6) // '/' // trim(this_obs_param%name) & - // '*' // YYYYMM // DDHH // '*' - - if (trim(this_obs_param%descr)=='ae_l2_sm_a') then - - cmd = trim(cmd) // '_A.hdf' - - elseif (trim(this_obs_param%descr)=='ae_l2_sm_d') then - - cmd = trim(cmd) // '_D.hdf' - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown descr') - - end if - - cmd = trim(cmd) // ' >> ' // trim(tmpfname) - - call Execute_command_line(trim(cmd)) - - call augment_date_time( 3600, date_time_tmp ) - - end do - - ! find out how many need to be read - - tmpfname2 = trim(tmpfname) // '.wc' - - cmd = 'wc -w ' // trim(tmpfname) // ' > ' // trim(tmpfname2) - - call Execute_command_line(trim(cmd)) - - open(10, file=tmpfname2, form='formatted', action='read') - - read(10,*) N_files - - close(10,status='delete') - - ! load file names into "fnames" - - open(10, file=tmpfname, form='formatted', action='read') - - if (N_files>0) then - - allocate(fnames(N_files)) - - do i=1,N_files - read(10,'(a)') fnames(i) - end do - - end if - - close(10,status='delete') - - ! read observations: - ! - ! 1.) read N_tmp observations and their lat/lon info from file - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! - ! ---------------------------------------------------------------- - ! - ! 1.) read N_tmp observations and their lat/lon info from file - - if (N_files>0) then - - call read_ae_l2_sm_hdf( & - N_files, fnames, & - N_tmp, tmp_lon, tmp_lat, tmp_obs ) - - if (logit) then - - write (logunit,*) 'read_obs_ae_l2_sm: read ', N_tmp, & - ' at date_time = ', date_time, ' from ' - do i=1,N_files - write (logunit,*) trim(fnames(i)) - end do - write (logunit,*) '----------' - - end if - - deallocate(fnames) - - else - - N_tmp = 0 - - end if - - ! ------------------------------------------------------------------ - - ! note QC and no-data-value block in subroutine read_ae_l2_sm_hdf() - - ! ------------------------------------------------------------------ - ! - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_tmp>0) then - - allocate(tmp_tile_num(N_tmp)) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num ) - - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - ae_l2_sm = 0. - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - ae_l2_sm(ind) = ae_l2_sm(ind) + tmp_obs(i) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - ae_l2_sm(i) = ae_l2_sm(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - ae_l2_sm(i) = this_obs_param%nodata - - end if - - end do - - ! clean up - - if (associated(tmp_tile_num)) deallocate(tmp_tile_num) - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_ae_l2_sm(i) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - ! clean up - - if (associated(tmp_obs)) deallocate(tmp_obs) - if (associated(tmp_lon)) deallocate(tmp_lon) - if (associated(tmp_lat)) deallocate(tmp_lat) - - end subroutine read_obs_ae_l2_sm - - ! *************************************************************************** - - subroutine read_ae_sm_LPRM_bin( & - this_obs_param, N_files, fnames, N_data, lon, lat, ae_sm_LPRM, ease_col, ease_row ) - - ! read soil moisture data from one or more AMSR-E LPRM bin files - ! - ! return ONLY valid data points (ie. excluding no-data-values) - ! - ! no QC in addition to what was done in matlab-preprocessing - ! - ! reichle, 20 Feb 2009 - - implicit none - - type(obs_param_type), intent(in) :: this_obs_param - - integer, intent(in) :: N_files - - character(*), dimension(N_files), intent(in) :: fnames - - integer, intent(out) :: N_data - - real, dimension(:), pointer :: lon, lat, ae_sm_LPRM ! output - - integer, dimension(:), pointer, optional :: ease_col, ease_row ! output - - ! local variables - - logical :: must_stop - - integer, dimension(N_files) :: N_data_tmp - - integer :: i, j, k_off - - integer, dimension(:), allocatable :: tmpintvec - real, dimension(:), allocatable :: tmprealvec - - character(len=*), parameter :: Iam = 'read_ae_sm_LPRM_bin' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - ! make sure pointers are not allocated or associated - - must_stop = .false. - - if ( associated(lon) .or. associated(lat) .or. associated(ae_sm_LPRM) ) then - must_stop = .true. - end if - - if ( present(ease_col) ) then - if (associated(ease_col)) must_stop = .true. - end if - - if ( present(ease_row) ) then - if (associated(ease_row)) must_stop = .true. - end if - - if (must_stop) then - err_msg = 'output pointers must not be associated/allocated on input' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! determine number of data to be read from each file - - N_data = 0 - - do j=1,N_files - - ! open file - - open( 10, file=trim(fnames(j)), form='unformatted',convert='big_endian', action='read' ) - - read( 10) N_data_tmp(j) - - close(10, status='keep') - - end do - - ! allocate pointers (must be deallocated outside this subroutine!) - - N_data = sum(N_data_tmp) - - allocate(lon(N_data)) - allocate(lat(N_data)) - if (present(ease_col)) allocate(ease_col(N_data)) - if (present(ease_row)) allocate(ease_row(N_data)) - allocate(ae_sm_LPRM(N_data)) - - ! read data into arrays, concatenate data from N_files files - - ! format of AMSR_sm_LPRM_EASE_bin files: - ! - ! record 1 -- N_data int*4 - ! record 2 -- lon( 1:N_data) real*4 - ! record 3 -- lat( 1:N_data) real*4 - ! record 4 -- sm_C( 1:N_data) real*4 - ! record 5 -- sm_X( 1:N_data) real*4 - ! record 6 -- od_C( 1:N_data) real*4 - ! record 7 -- od_X( 1:N_data) real*4 - ! record 8 -- res_C(1:N_data) real*4 - ! record 9 -- res_X(1:N_data) real*4 - ! record 10 -- ts_C( 1:N_data) real*4 - ! record 11 -- ts_X( 1:N_data) real*4 - ! record 12 -- rfi_C(1:N_data) int*4 - ! record 13 -- rfi_X(1:N_data) int*4 - ! record 14 -- ind_i(1:N_data) int*4 zero-based (!) EASE row index - ! record 15 -- ind_j(1:N_data) int*4 zero-based (!) EASE col index - ! record 16 -- time( 1:N_data) real*4 minutes since beginning of half-orbit - - k_off = 0 - - do j=1,N_files - - allocate(tmprealvec(N_data_tmp(j))) - - if (present(ease_col)) allocate(tmpintvec(N_data_tmp(j))) - - open (10, file=trim(fnames(j)), form='unformatted',convert='big_endian', action='read' ) - - ! re-read N_data - - read (10) N_data_tmp(j) - - ! read data as needed - - read (10) tmprealvec; lon(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - read (10) tmprealvec; lat(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - if (this_obs_param%descr(13:14)=='_C') then - - read (10) tmprealvec; ae_sm_LPRM(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - read (10) ! skip sm_X - - else if (this_obs_param%descr(13:14)=='_X') then - - read (10) ! skip sm_C - read (10) tmprealvec; ae_sm_LPRM(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - else - - err_msg = 'unknown descr, ' // this_obs_param%descr - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - if (present(ease_col) .and. present(ease_row)) then - - read (10) ! skip od_C - read (10) ! skip od_X - read (10) ! skip res_C - read (10) ! skip res_X - read (10) ! skip ts_C - read (10) ! skip ts_X - read (10) ! skip rfi_C - read (10) ! skip rfi_X - - read (10) tmpintvec; ease_col(k_off+1:k_off+N_data_tmp(j)) = tmpintvec - read (10) tmpintvec; ease_row(k_off+1:k_off+N_data_tmp(j)) = tmpintvec - - ! read (10) ! skip time - - end if - - ! clean up - - close(10, status='keep') - - deallocate(tmprealvec) - if (allocated(tmpintvec)) deallocate(tmpintvec) - - ! prepare next j - - k_off = k_off + N_data_tmp(j) - - end do - - ! ------------------------------------- - ! - ! eliminate no-data-values - - j = 0 - - do i=1,N_data - - if (ae_sm_LPRM(i)>0.) then ! any neg is nodata - - j=j+1 - - ae_sm_LPRM(j) = ae_sm_LPRM(i) - lon(j) = lon(i) - lat(j) = lat(i) - if (present(ease_col)) ease_col(j) = ease_col(i) - if (present(ease_row)) ease_row(j) = ease_row(i) - - end if - - end do - - N_data = j - - end subroutine read_ae_sm_LPRM_bin - - ! ***************************************************************** - - subroutine read_obs_ae_sm_LPRM( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, ae_sm_LPRM, std_ae_sm_LPRM ) - - ! Read observations of surface soil moisture from AMSR-E sm LPRM files - ! (Richard de Jeu, Vrije Universiteit Amsterdam) - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! If there are N > 1 observations in a given tile, - ! a "super-observation" is computed by averaging the N observations - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 20 Feb 2009 - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: ae_sm_LPRM - real, intent(out), dimension(N_catd) :: std_ae_sm_LPRM - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! AMSR_E_L2_Land files are available for approximately 50min periods - ! covering one ascending or descending swath. The filename indicates - ! the start time of the swath - ! "ae_time_offset" is used to find the mean time of the the interval - ! which is approximately the time of the equator overpass. - ! This time is assigned to all observations of the swath. - - integer, parameter :: ae_time_offset = 1500 ! 25 minutes in seconds - - character(4) :: DDHH - character(6) :: YYYYMM - character(8) :: date_string - character(10) :: time_string - character(300) :: tmpfname, tmpfname2 - character(400) :: cmd - - type(date_time_type) :: date_time_tmp - - integer :: i, ind, N_tmp, N_files - - character(300), dimension(:), allocatable :: fnames - - real, dimension(:), pointer :: tmp_obs, tmp_lat, tmp_lon - integer, dimension(:), pointer :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - character(len=*), parameter :: Iam = 'read_obs_ae_sm_LPRM' - - ! ------------------------------------------------------------------- - - nullify( tmp_obs, tmp_lat, tmp_lon, tmp_tile_num ) - - ! --------------- - - ! initialize - - found_obs = .false. - - ! find files that are within half-open interval - ! [date_time-dtstep_assim/2,date_time+dtstep_assim/2) - - date_time_tmp = date_time - - call augment_date_time( -(dtstep_assim/2 + ae_time_offset), date_time_tmp ) - - ! get tmp file name and remove file if it exists - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - tmpfname = trim(work_path) // '/' // 'tmp.' // trim(exp_id) & - // '.' // date_string // time_string - - cmd = '/bin/rm -f ' // tmpfname - - call Execute_command_line(trim(cmd)) - - ! identify all files within current assimilation interval - ! (list all files within hourly intervals) - - do i=1,(dtstep_assim/3600) - - write (YYYYMM,'(i6.6)') date_time_tmp%year*100 + date_time_tmp%month - write (DDHH, '(i4.4)') date_time_tmp%day *100 + date_time_tmp%hour - - cmd = 'ls ' // trim(this_obs_param%path) // '/' // YYYYMM(1:4) // & - '.' // YYYYMM(5:6) // '/' // trim(this_obs_param%name) & - // YYYYMM // DDHH(1:2) // '.' // DDHH(3:4) // '??' - - if (this_obs_param%descr(1:12)=='ae_sm_LPRM_a') then - - cmd = trim(cmd) // '_A.bin' - - elseif (this_obs_param%descr(1:12)=='ae_sm_LPRM_d') then - - cmd = trim(cmd) // '_D.bin' - - else - - !write (logunit,*) 'read_obs_ae_sm_LPRM(): unknown descr, STOPPING.' - !stop - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown descr') - - end if - - cmd = trim(cmd) // ' >> ' // trim(tmpfname) - - call Execute_command_line(trim(cmd)) - - call augment_date_time( 3600, date_time_tmp ) - - end do - - ! find out how many need to be read - - tmpfname2 = trim(tmpfname) // '.wc' - - cmd = 'wc -w ' // trim(tmpfname) // ' > ' // trim(tmpfname2) - - call Execute_command_line(trim(cmd)) - - open(10, file=tmpfname2, form='formatted', action='read') - - read(10,*) N_files - - close(10,status='delete') - - ! load file names into "fnames" - - open(10, file=tmpfname, form='formatted', action='read') - - if (N_files>0) then - - allocate(fnames(N_files)) - - do i=1,N_files - read(10,'(a)') fnames(i) - end do - - end if - - close(10,status='delete') - - ! read observations: - ! - ! 1.) read N_tmp observations and their lat/lon info from file - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! - ! ---------------------------------------------------------------- - ! - ! 1.) read N_tmp observations and their lat/lon info from file - - if (N_files>0) then - - call read_ae_sm_LPRM_bin( & - this_obs_param, N_files, fnames, & - N_tmp, tmp_lon, tmp_lat, tmp_obs ) - - if (logit) then - - write (logunit,*) 'read_obs_ae_sm_LPRM: read ', N_tmp, & - ' at date_time = ', date_time, ' from ' - do i=1,N_files - write (logunit,*) trim(fnames(i)) - end do - write (logunit,*) '----------' - - end if - - deallocate(fnames) - - else - - N_tmp = 0 - - end if - - ! ------------------------------------------------------------------ - - ! QC is done in matlab pre-processing to bin files - - ! ------------------------------------------------------------------ - ! - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_tmp>0) then - - allocate(tmp_tile_num(N_tmp)) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num ) - - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - ae_sm_LPRM = 0. - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - ae_sm_LPRM(ind) = ae_sm_LPRM(ind) + tmp_obs(i) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - ae_sm_LPRM(i) = ae_sm_LPRM(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - ae_sm_LPRM(i) = this_obs_param%nodata - - end if - - end do - - ! clean up - - if (associated(tmp_tile_num)) deallocate(tmp_tile_num) - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_ae_sm_LPRM(i) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - ! clean up - - if (associated(tmp_obs)) deallocate(tmp_obs) - if (associated(tmp_lon)) deallocate(tmp_lon) - if (associated(tmp_lat)) deallocate(tmp_lat) - - end subroutine read_obs_ae_sm_LPRM - - ! ***************************************************************** - - subroutine read_obs_sm_ASCAT( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, sm_ASCAT, std_sm_ASCAT ) - - !--------------------------------------------------------------------- - ! - ! Routine to read in ASCAT surface degree of saturation obs. - ! Output is found_obs, sm_ASCAT, std_sm_ASCAT - ! - ! Reads in obs provided by Wolfgang Wagner (TUW), converted to - ! once hourly binary files (and projected onto EASE grid). - ! Updating to the EUMETSAT BUFR (DGG) files will require a new - ! reader, and changes to file-name / time-stamping - ! - ! Draper, May 2011. - ! Based on read_obs_ae_sm_LPRM - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: sm_ASCAT - real, intent(out), dimension(N_catd) :: std_sm_ASCAT - logical, intent(out) :: found_obs - - ! --------------- - - ! For the files generated from the TUW timseries, each - ! file is time-stamped with the time of the observations, rounded - ! down to the nearest obs - ! E(minutes past hour)=30 -> use this as the offset - - ! Will need to be updated if using EUMETSAT BUFR files - - integer, parameter :: ae_time_offset = 1800 ! 30 minutes in seconds - - character(4) :: DDHH - character(6) :: YYYYMM - character(8) :: date_string - character(10) :: time_string - character(300) :: tmpfname, tmpfname2 - character(400) :: cmd - - type(date_time_type) :: date_time_tmp - - integer :: i, ind, N_tmp, N_files - - character(300), dimension(:), allocatable :: fnames - - real, dimension(:), pointer :: tmp_obs, tmp_lat, tmp_lon - integer, dimension(:), pointer :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - real, parameter :: tol = 1e-2 - - character(len=*), parameter :: Iam = 'read_obs_sm_ASCAT' - - ! ------------------------------------------------------------------- - - nullify( tmp_obs, tmp_lat, tmp_lon, tmp_tile_num ) - - ! --------------- - - ! initialize - - found_obs = .false. - - ! find files that are within half-open interval - ! [date_time-dtstep_assim/2,date_time+dtstep_assim/2) - - date_time_tmp = date_time - - call augment_date_time( -(dtstep_assim/2 + ae_time_offset), date_time_tmp ) - - ! get tmp file name and remove file if it exists - - call date_and_time(date_string, time_string) ! f90 intrinsic function - - tmpfname = trim(work_path) // '/' // 'tmp.' // trim(exp_id) & - // '.' // date_string // time_string - - cmd = '/bin/rm -f ' // tmpfname - - call Execute_command_line(trim(cmd)) - - ! identify all files within current assimilation interval - ! (list all files within hourly intervals) - - do i=1,(dtstep_assim/3600) - - write (YYYYMM,'(i6.6)') date_time_tmp%year*100 + date_time_tmp%month - write (DDHH, '(i4.4)') date_time_tmp%day *100 + date_time_tmp%hour - - ! TUW files time stamped with hour only. Update for EUMETSAT BUFR - cmd = 'ls ' // trim(this_obs_param%path) // '/' // YYYYMM(1:4) // & - '.' // YYYYMM(5:6) // '/' // trim(this_obs_param%name) & - // YYYYMM // DDHH(1:2) // '.' // DDHH(3:4) !// '??' - - if (this_obs_param%descr(1:10)=='ASCAT_SM_A') then - - cmd = trim(cmd) // '_A.bin' - - elseif (this_obs_param%descr(1:10)=='ASCAT_SM_D') then - - cmd = trim(cmd) // '_D.bin' - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown descr') - - end if - - cmd = trim(cmd) // ' >> ' // trim(tmpfname) - - call Execute_command_line(trim(cmd)) - - - call augment_date_time( 3600, date_time_tmp ) - - end do - - ! find out how many need to be read - - tmpfname2 = trim(tmpfname) // '.wc' - - cmd = 'wc -w ' // trim(tmpfname) // ' > ' // trim(tmpfname2) - - call Execute_command_line(trim(cmd)) - - open(10, file=tmpfname2, form='formatted', action='read') - - read(10,*) N_files - - close(10,status='delete') - - ! load file names into "fnames" - - open(10, file=tmpfname, form='formatted', action='read') - - if (N_files>0) then - - allocate(fnames(N_files)) - - do i=1,N_files - read(10,'(a)') fnames(i) - end do - - end if - - close(10,status='delete') - - ! read observations: - ! - ! 1.) read N_tmp observations and their lat/lon info from file - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! - ! ---------------------------------------------------------------- - ! - ! 1.) read N_tmp observations and their lat/lon info from file - - if (N_files>0) then - - call read_sm_ASCAT_bin( & - N_files, fnames, & - N_tmp, tmp_lon, tmp_lat, tmp_obs ) - - if (logit) then - - write (logunit,*) 'read_obs_sm_ASCAT: read ', N_tmp, & - ' at date_time = ', date_time, ' from ' - do i=1,N_files - write (logunit,*) trim(fnames(i)) - end do - write (logunit,*) '----------' - - end if - - deallocate(fnames) - - else - - N_tmp = 0 - - end if - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! SOME QC SHOULD BE DONE HERE!!! - ! - ! MAKE SURE no-data-values ARE DEALT WITH - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! ---------------------------------------------------------------- - ! - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_tmp>0) then - - allocate(tmp_tile_num(N_tmp)) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num ) - - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - sm_ASCAT = 0. - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - sm_ASCAT(ind) = sm_ASCAT(ind) + tmp_obs(i) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - sm_ASCAT(i) = sm_ASCAT(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - sm_ASCAT(i) = this_obs_param%nodata - - end if - - end do - - ! clean up - - if (associated(tmp_tile_num)) deallocate(tmp_tile_num) - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_sm_ASCAT(i) = this_obs_param%errstd - enddo - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - ! clean up - - if (associated(tmp_obs)) deallocate(tmp_obs) - if (associated(tmp_lon)) deallocate(tmp_lon) - if (associated(tmp_lat)) deallocate(tmp_lat) - - end subroutine read_obs_sm_ASCAT - - ! **************************************************************************** - - subroutine read_obs_sm_ASCAT_EUMET( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, ASCAT_sm, ASCAT_sm_std, ASCAT_lon, ASCAT_lat, ASCAT_time ) - - !--------------------------------------------------------------------- - ! - ! Routine to read in ASCAT surface degree of saturation (sfds) obs from - ! BUFR files for both ascending and descending passes. - ! - ! ASCAT_sm and ASCAT_sm_std outputs from this subroutine are in wetness fraction (i.e., 0-1) units! - ! - ! Read in EUMETSAT level 2 soil moisture product 25 km (SMO), PPF software version 5.0. - ! Soil moisture derived from re-sampled (spatially averaged) backscatter (sigma0) values - ! on a 25-km orbit swath grid. Input data files are in BUFR file format. - ! - ! EUMETSAT BUFR files contain data for both ascending and descending half-orbits. - ! The BUFR field DOMO ("Direction of motion of moving observing platform") could be used to - ! separate Asc and Desc. (The BUFR files do not contain any explicit orbit indicator variable.) - ! According to Pamela Schoebel-Pattiselanno, EUMETSAT User Services Helpdesk: - ! "When the value (of DOMO) is between 180 and 270 degrees, it is the descending part - ! of the orbit. When it is between 270 and 360 degrees, it is the ascending part." - ! - ! Q. Liu, Nov 2019 - based on read_obs_sm_ASCAT - ! A. Fox, reichle, Sep 2023 - updated - ! A. Fox, reichle, Feb 2024 - added ASCAT obs mask - ! - ! -------------------------------------------------------------------- - - use netcdf - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - logical, intent(out) :: found_obs - - real, intent(out), dimension(N_catd) :: ASCAT_sm ! sfds obs [fraction] (i.e., 0-1) - real, intent(out), dimension(N_catd) :: ASCAT_sm_std ! sfds obs err std [fraction] (i.e., 0-1) - real, intent(out), dimension(N_catd) :: ASCAT_lon, ASCAT_lat - real*8, intent(out), dimension(N_catd) :: ASCAT_time ! J2000 seconds - - ! --------------- - - ! Each obs file contains ~100-110 minutes (1 full orbit?) of observations (dt_ASCAT_obsfile). - ! File name indicates start time of swath. - - integer, parameter :: dt_ASCAT_obsfile = 110*60 ! seconds - - integer, parameter :: N_fnames_max = 15 ! max number of files per day - - character(4), parameter :: J2000_epoch_id = 'TT12' ! see date_time_util.F90 - - character( 15) :: str_date_time - character( 80) :: fname_of_fname_list - character(300) :: tmpfname - - type(date_time_type) :: date_time_tmp - type(date_time_type) :: date_time_low, date_time_low_fname - type(date_time_type) :: date_time_up - - integer :: ii, ind, N_tmp, N_files, kk, N_obs, N_fnames, N_fnames_tmp, obs_dir_hier - - character(300), dimension(:), allocatable :: fnames, tmpfnames - - ! -------------------- - ! - ! variables for BUFR read - - real*8, dimension(14) :: tmp_vdata - - integer, parameter :: lnbufr = 50 ! BUFR file unit number - integer, parameter :: max_rec = 50000 ! max number of obs after QC (expecting < 6 hr assim window) - integer, parameter :: max_obs = 250000 ! max number of obs read by subroutine (expecting < 6 hr assim window) - - integer :: idate, iret, ireadmg, ireadsb - - character(8) :: subset - - ! -------------------- - ! - ! variables for obs mask read - - integer(kind=1), dimension(:,:), allocatable :: mask_data - - real :: mask_ll_lon, mask_ll_lat, mask_dlon, mask_dlat - - integer :: ncid, ierr - integer :: mask_N_lon, mask_N_lat, mask_lon_ind, mask_lat_ind - integer :: lon_dimid, lat_dimid - integer :: mask_varid, ll_lon_varid, ll_lat_varid, dlon_varid, dlat_varid - - character(300) :: mask_filename - - logical :: file_exists - - ! -------------------- - - character(100), dimension(2*N_fnames_max) :: fname_list ! max 2 days of files - - real, dimension(:), allocatable :: tmp1_obs, tmp1_lat, tmp1_lon - real*8, dimension(:), allocatable :: tmp1_jtime - real*8, dimension(:,:), allocatable :: tmp_data - - real, dimension(:), pointer :: tmp_obs, tmp_lat, tmp_lon - real*8, dimension(:), pointer :: tmp_jtime - - integer, dimension(:), pointer :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - character(len=*), parameter :: Iam = 'read_obs_sm_ASCAT_EUMET' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------- - - nullify( tmp_obs, tmp_lat, tmp_lon, tmp_tile_num, tmp_jtime ) - - ! --------------- - - ! initialize - - found_obs = .false. - - ! find files that are within half-open interval - ! (date_time-dtstep_assim/2,date_time+dtstep_assim/2] - - date_time_low = date_time - call augment_date_time( -(dtstep_assim/2), date_time_low) - date_time_up = date_time - call augment_date_time( (dtstep_assim/2), date_time_up) - - ! calculate "extra" date_time_low to catch files w/ swath start time stamps before window - ! but containing relevant obs - - date_time_low_fname = date_time_low - call augment_date_time( -dt_ASCAT_obsfile, date_time_low_fname) - - ! ---------------------------------------------------------------- - ! - ! read file with list of ASCAT file names for first day - - fname_of_fname_list = 'dummy' ! make sure it is properly defined in obs_param nml - - obs_dir_hier = 1 - - call read_obs_fnames( date_time_low_fname, this_obs_param, & - fname_of_fname_list, N_fnames_max, & - N_fnames, fname_list(1:N_fnames_max), obs_dir_hier ) - - ! if needed, read file with list of ASCAT file names for second day and add - ! file names into "fname_list" - - if (date_time_low_fname%day /= date_time_up%day) then - - call read_obs_fnames( date_time_up, this_obs_param, & - fname_of_fname_list, N_fnames_max, & - N_fnames_tmp, fname_list((N_fnames+1):(N_fnames+N_fnames_max)), obs_dir_hier ) - - N_fnames = N_fnames + N_fnames_tmp - - end if - - tmpfnames = fname_list(1:N_fnames) - - ! ---------------------------------------------------------------- - ! - ! find files that have obs within assimilation window - - N_tmp = 0 - - do kk = 1,N_fnames - - tmpfname = fname_list(kk) - - ! Are we in the required assimilation window? - ! - ! e.g. Y2019/M07/M01-ASCA-ASCSMO02-NA-5.0-20190702075700.000000000Z-20190702084627-1350204.bfr - ! - ! 12345678901234567890123456789012345678901234567890123456789012345678901234567890 - ! 1 2 3 4 5 6 7 - - str_date_time = tmpfname(36:49) - - read(str_date_time( 1: 4), *) date_time_tmp%year - read(str_date_time( 5: 6), *) date_time_tmp%month - read(str_date_time( 7: 8), *) date_time_tmp%day - read(str_date_time( 9:10), *) date_time_tmp%hour - read(str_date_time(11:12), *) date_time_tmp%min - read(str_date_time(13:14), *) date_time_tmp%sec - - if ( datetime_lt_refdatetime( date_time_low_fname, date_time_tmp ) .and. & - datetime_le_refdatetime( date_time_tmp, date_time_up ) ) then - - N_tmp = N_tmp + 1 - - tmpfnames(N_tmp) = trim(this_obs_param%path) // '/' // trim(tmpfname) - - end if - - end do - - fnames = tmpfnames(1:N_tmp) - N_files = N_tmp - - ! ---------------------------------------------------------------- - ! - ! loop through files and read obs + metadata into tmp_data - - if (N_files>0) then - - ! read and process data if files are found - - allocate(tmp1_lon( max_rec )) - allocate(tmp1_lat( max_rec )) - allocate(tmp1_obs( max_rec )) - allocate(tmp1_jtime(max_rec )) - - allocate(tmp_data( max_obs,14)) - - N_obs = 0 - - do kk = 1,N_files - - ! open bufr file - - call closbf(lnbufr) ! if a file with unit number lnbufr is open in (or "linked" with) BUFR, close it - open(lnbufr, file=trim(fnames(kk)), action='read', form='unformatted') - call openbf(lnbufr, 'SEC3', lnbufr) - call mtinfo( trim(this_obs_param%path) // '/BUFR_mastertable/', lnbufr+1, lnbufr+2) - call datelen(10) ! select date/time format with 4-digit year (YYYYMMDDHH) - - msg_report: do while( ireadmg(lnbufr,subset,idate) == 0 ) - - loop_report: do while( ireadsb(lnbufr) == 0 ) - - ! columns of tmp_data: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - - call ufbint(lnbufr,tmp_vdata,14,1,iret,'YEAR MNTH DAYS HOUR MINU SECO SSOM SMPF SMCF ALFR TPCX IWFR CLATH CLONH') - - N_obs = N_obs + 1 - - if (N_obs > max_obs) then - err_msg = 'Attempting to read too many obs - how long is your assimilation window?' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - tmp_data(N_obs,:) = tmp_vdata - - end do loop_report - end do msg_report - - call closbf(lnbufr) - close(lnbufr) - - end do ! end file loop - - ! ---------------------------------------------------------------- - ! - ! read mask file for ASCAT obs (netcdf format, regular lat/lon grid) - - mask_filename = trim(this_obs_param%maskpath) // '/' // trim(this_obs_param%maskname) - - if (logit) write (logunit,'(400A)') ' reading mask for ASCAT obs from ', trim(mask_filename) - - ! check if file exists - - inquire(file=mask_filename, exist=file_exists) - - if (.not. file_exists) then - err_msg = 'Mask file for ASCAT obs not found!' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! open netCDF mask file - ierr = nf90_open(mask_filename, nf90_nowrite, ncid) - - ! get variable IDs - ierr = nf90_inq_varid(ncid, 'mask', mask_varid) - ierr = nf90_inq_varid(ncid, 'll_lon', ll_lon_varid) - ierr = nf90_inq_varid(ncid, 'll_lat', ll_lat_varid) - ierr = nf90_inq_varid(ncid, 'd_lon', dlon_varid) - ierr = nf90_inq_varid(ncid, 'd_lat', dlat_varid) - - ! get variable dimension IDs - ierr = nf90_inq_dimid(ncid, 'lon', lon_dimid) - ierr = nf90_inq_dimid(ncid, 'lat', lat_dimid) - - ! get dimension size - ierr = nf90_inquire_dimension(ncid, lon_dimid, len=mask_N_lon) - ierr = nf90_inquire_dimension(ncid, lat_dimid, len=mask_N_lat) - - ! read grid parameters - ierr = nf90_get_var(ncid, ll_lon_varid, mask_ll_lon) - ierr = nf90_get_var(ncid, ll_lat_varid, mask_ll_lat) - ierr = nf90_get_var(ncid, dlon_varid, mask_dlon) - ierr = nf90_get_var(ncid, dlat_varid, mask_dlat) - - ! allocate memory for mask - allocate(mask_data(mask_N_lon, mask_N_lat)) ! note: lon-by-lat - - ! read mask - ierr = nf90_get_var(ncid, mask_varid, mask_data) - - ! close netCDF mask file - ierr = nf90_close(ncid) - - ! ---------------------------------------------------------------- - ! - ! select obs within assimilation window and from desired orbit direction; apply basic QC based on obs info - - N_tmp = 0 - - do kk = 1,N_obs - - date_time_tmp%year = int(tmp_data(kk, 1)) - date_time_tmp%month = int(tmp_data(kk, 2)) - date_time_tmp%day = int(tmp_data(kk, 3)) - date_time_tmp%hour = int(tmp_data(kk, 4)) - date_time_tmp%min = int(tmp_data(kk, 5)) - date_time_tmp%sec = int(tmp_data(kk, 6)) - - ! skip if record outside of current assim window - if ( datetime_lt_refdatetime( date_time_tmp, date_time_low ) .and. & - datetime_le_refdatetime( date_time_up, date_time_tmp ) ) cycle - - ! skip if record contains invalid soil moisture value - if ( tmp_data(kk, 7) > 100. .or. tmp_data(kk, 7) < 0. ) cycle - - ! to distinguish orbit directions, must read "DOMO" from BUFR file - ! - ! 180 <= DOMO < 270 : descending - ! 270 < DOMO <= 360 : ascending - ! - ! if (index(this_obs_param%descr,'_A') /=0 .and. (tmp_data(kk, 8) < 270 .or. tmp_data(kk, 8) > 360)) cycle - ! if (index(this_obs_param%descr,'_D') /=0 .and. (tmp_data(kk, 8) < 180 .or. tmp_data(kk, 8) >= 270)) cycle - - ! skip if processing flag is set - if(int(tmp_data(kk, 8)) /= 0) cycle - - ! skip if correction flag is set ("good" values are 0 and 4) - if (.not. ( (int(tmp_data(kk, 9)) == 0) .or. (int(tmp_data(kk, 9)) == 4)) ) cycle - - ! skip if land fraction is missing or < 0.9 - if(tmp_data(kk, 10) > 1. .or. tmp_data(kk, 10) < 0.9 ) cycle - - ! skip if topographic complexity > 10% - if(tmp_data(kk, 11) > 10.) cycle - - ! skip if inundation and wetland fraction > 10% - if(tmp_data(kk, 12) > 10.) cycle - - ! find lat/lon indices of ASCAT mask for this observation lat/lon - mask_lat_ind = max( min( ceiling((tmp_data(kk, 13) - mask_ll_lat)/mask_dlat), mask_N_lat ), 1) - mask_lon_ind = max( min( ceiling((tmp_data(kk, 14) - mask_ll_lon)/mask_dlon), mask_N_lon ), 1) - - ! skip if masked - if (mask_data( mask_lon_ind, mask_lat_ind ) /= 0) cycle ! note: lon-by-lat - - N_tmp = N_tmp + 1 ! passed all QC - - if (N_tmp > max_rec) then - err_msg = 'Too many obs have passed QC - how long is your assimilation window?' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - tmp1_jtime(N_tmp) = datetime_to_J2000seconds( date_time_tmp, J2000_epoch_id ) - - tmp1_lat( N_tmp) = tmp_data(kk, 13) - tmp1_lon( N_tmp) = tmp_data(kk, 14) - - tmp1_obs( N_tmp) = tmp_data(kk, 7)/100. ! change units from percent (0-100) to fraction (0-1) - - end do - - if (logit) then - - write (logunit,*) 'read_obs_sm_ASCAT_EUMET: read ', N_tmp, ' at date_time = ', date_time, ' from:' - do ii=1,N_files - write (logunit,*) trim(fnames(ii)) - end do - write (logunit,*) '----------' - write (logunit,*) 'max(obs)=',maxval(tmp1_obs(1:N_tmp)), ', min(obs)=',minval(tmp1_obs(1:N_tmp)), & - ', avg(obs)=',sum(tmp1_obs(1:N_tmp))/N_tmp - - end if - - deallocate(fnames) - - ! copy "good" obs with lat/lon/time into tmp_* (pointers) - - allocate(tmp_jtime(N_tmp)) - allocate(tmp_lon( N_tmp)) - allocate(tmp_lat( N_tmp)) - allocate(tmp_obs( N_tmp)) - - tmp_jtime = tmp1_jtime(1:N_tmp) - tmp_lon = tmp1_lon( 1:N_tmp) - tmp_lat = tmp1_lat( 1:N_tmp) - tmp_obs = tmp1_obs( 1:N_tmp) - - deallocate(tmp1_jtime) - deallocate(tmp1_lon) - deallocate(tmp1_lat) - deallocate(tmp1_obs) - deallocate(tmp_data) - deallocate(mask_data) - - else - - N_tmp = 0 - - end if - - ! ---------------------------------------------------------------- - ! - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_tmp>0) then - - allocate(tmp_tile_num(N_tmp)) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num ) - - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - ASCAT_sm = 0. - ASCAT_lon = 0. - ASCAT_lat = 0. - ASCAT_time = 0.0D0 - - N_obs_in_tile = 0 - - do ii=1,N_tmp - - ind = tmp_tile_num(ii) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - ASCAT_sm( ind) = ASCAT_sm( ind) + tmp_obs( ii) - ASCAT_lon( ind) = ASCAT_lon( ind) + tmp_lon( ii) - ASCAT_lat( ind) = ASCAT_lat( ind) + tmp_lat( ii) - ASCAT_time(ind) = ASCAT_time(ind) + tmp_jtime(ii) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize and set obs error std-dev - - do ii=1,N_catd - - ! set observation error standard deviation - - ASCAT_sm_std(ii) = this_obs_param%errstd/100. ! change units from percent (0-100) to fraction (0-1) - - ! normalize - - if (N_obs_in_tile(ii)>1) then - - ASCAT_sm( ii) = ASCAT_sm( ii)/real(N_obs_in_tile(ii)) - ASCAT_lon( ii) = ASCAT_lon( ii)/real(N_obs_in_tile(ii)) - ASCAT_lat( ii) = ASCAT_lat( ii)/real(N_obs_in_tile(ii)) - ASCAT_time( ii) = ASCAT_time(ii)/real(N_obs_in_tile(ii),kind(0.0D0)) - - elseif (N_obs_in_tile(ii)==0) then - - ASCAT_sm( ii) = this_obs_param%nodata - ASCAT_lon( ii) = this_obs_param%nodata - ASCAT_lat( ii) = this_obs_param%nodata - ASCAT_time( ii) = real(this_obs_param%nodata,kind(0.0D0)) - ASCAT_sm_std(ii) = this_obs_param%nodata - - else - - ! nothing to do if N_obs_in_tile(ii)==1 (and assuming N_obs_in_tile is never negative) - - end if - - end do - - ! clean up - - if (associated(tmp_tile_num)) deallocate(tmp_tile_num) - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - ! clean up - - if (associated(tmp_obs)) deallocate(tmp_obs) - if (associated(tmp_lon)) deallocate(tmp_lon) - if (associated(tmp_lat)) deallocate(tmp_lat) - if (associated(tmp_jtime)) deallocate(tmp_jtime) - - end subroutine read_obs_sm_ASCAT_EUMET - - ! *************************************************************************** - - subroutine read_sm_ASCAT_bin( & - N_files, fnames, N_data, lon, lat, sm_ASCAT, ease_col, ease_row ) - - ! read soil moisture data from one or more ASCAT bin files - ! - ! return ONLY valid data points (ie. excluding no-data-values) - ! - ! no QC in addition to what was done in matlab-preprocessing - ! - ! DRAPER, May 2011 - ! based on read_ae_sm_LPRM_bin - ! - ! DRAPER, July 2012 - ! updated, for inclusion of SDS error in ASCAT file - ! (error info currently not saved) - - implicit none - - integer, intent(in) :: N_files - - character(*), dimension(N_files), intent(in) :: fnames - - integer, intent(out) :: N_data - - real, dimension(:), pointer :: lon, lat, sm_ASCAT ! output - - integer, dimension(:), pointer, optional :: ease_col, ease_row ! output - - ! local variables - - logical :: must_stop - - integer, dimension(N_files) :: N_data_tmp - - integer :: i, j, k_off - - integer, dimension(:), allocatable :: tmpintvec - real, dimension(:), allocatable :: tmprealvec - - character(len=*), parameter :: Iam = 'read_sm_ASCAT_bin' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - ! make sure pointers are not allocated or associated - - must_stop = .false. - - if ( associated(lon) .or. associated(lat) .or. associated(sm_ASCAT) ) then - must_stop = .true. - end if - - if ( present(ease_col) ) then - if (associated(ease_col)) must_stop = .true. - end if - - if ( present(ease_row) ) then - if (associated(ease_row)) must_stop = .true. - end if - - if (must_stop) then - err_msg = 'output pointers must not be ' // & - 'associated or allocated on input.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - - !write (logunit,*) 'read_ae_sm_LPRM_bin(): output pointers must not be ' // & - ! 'associated or allocated on input. STOPPING.' - !stop - ! - !end if - - ! determine number of data to be read from each file - - N_data = 0 - - do j=1,N_files - - ! open file - - open( 10, file=trim(fnames(j)), form='unformatted',convert='big_endian', action='read' ) - - read( 10) N_data_tmp(j) - - close(10, status='keep') - - end do - - ! allocate pointers (must be deallocated outside this subroutine!) - - N_data = sum(N_data_tmp) - - allocate(lon( N_data)) - allocate(lat( N_data)) - allocate(sm_ASCAT(N_data)) - - if (present(ease_col)) allocate(ease_col(N_data)) - if (present(ease_row)) allocate(ease_row(N_data)) - - ! read data into arrays, concatenate data from N_files files - - ! format of AMSR_sm_LPRM_EASE_bin files: - ! - ! record 1 -- N_data int*4 - ! record 2 -- lon( 1:N_data) real*4 - ! record 3 -- lat( 1:N_data) real*4 - ! record 4 -- sds( 1:N_data) real*4 - ! record 5 -- sds_noise (1:N_data) real*4 - ! record 6 -- ind_i(1:N_data) int*4 zero-based (!) EASE row index - ! record 7 -- ind_j(1:N_data) int*4 zero-based (!) EASE col index - - k_off = 0 - - do j=1,N_files - - allocate(tmprealvec(N_data_tmp(j))) - - if (present(ease_col)) allocate(tmpintvec(N_data_tmp(j))) - - open (10, file=trim(fnames(j)), form='unformatted', convert='big_endian', action='read' ) - - ! re-read N_data - - read (10) N_data_tmp(j) - - ! read data as needed - - read (10) tmprealvec; lon(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - read (10) tmprealvec; lat(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - read (10) tmprealvec; sm_ASCAT(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - ! skip record with error - - read (10) ! tmprealvec; er_ASCAT(k_off+1:k_off+N_data_tmp(j)) = tmprealvec - - if (present(ease_col) .and. present(ease_row)) then - - read (10) tmpintvec; ease_col(k_off+1:k_off+N_data_tmp(j)) = tmpintvec - read (10) tmpintvec; ease_row(k_off+1:k_off+N_data_tmp(j)) = tmpintvec - - end if - - ! clean up - - close(10, status='keep') - - deallocate(tmprealvec) - if (allocated(tmpintvec)) deallocate(tmpintvec) - - ! prepare next j - - k_off = k_off + N_data_tmp(j) - - end do - - ! ------------------------------------- - ! - ! eliminate no-data-values - - j = 0 - - do i=1,N_data - - if (sm_ASCAT(i)>0.) then ! any neg is nodata - - j=j+1 - - sm_ASCAT(j) = sm_ASCAT(i) - lon(j) = lon(i) - lat(j) = lat(i) - if (present(ease_col)) ease_col(j) = ease_col(i) - if (present(ease_row)) ease_row(j) = ease_row(i) - - end if - - end do - - N_data = j - - end subroutine read_sm_ASCAT_bin - - - ! ***************************************************************** - - subroutine read_obs_LaRC_Tskin( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, ts_LARC, std_ts_LARC ) - - !--------------------------------------------------------------------- - ! - ! Subroutine to read in Tskin from LaRC. - ! Draper, June 2012. - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: ts_LARC - real, intent(out), dimension(N_catd) :: std_ts_LARC - logical, intent(out) :: found_obs - - ! --------------- - - real, parameter :: min_Tskin = 200. - real, parameter :: max_Tskin = 370. - - real, parameter :: tol = 1.e-2 - - ! Offsets taken - - integer :: ts_time_offset ! in seconds - - character(6) :: DDHHMM - character(6) :: YYYYMM - - type(date_time_type) :: date_time_tmp - - integer :: i, ind, N_tmp, N_files - - ! 24 = max number of files in one cycle - ! (assumes daily assim cycle, and hourly files) - - character(300), dimension(24) :: fnames - - real, dimension(:), pointer :: tmp_obs, tmp_lat, tmp_lon - - integer, dimension(N_catd) :: N_obs_in_tile - - integer, dimension(:), pointer :: tmp_tile_num - - character(300) :: tmp_fname - - logical :: ex - - integer :: MM - - character(len=*), parameter :: Iam = 'read_obs_LaRC_Tskin' - - ! ------------------------------------------------------------------- - - nullify( tmp_obs, tmp_lat, tmp_lon , tmp_tile_num) - - ! --------------- - - ! initialize - - ! time stampes are at start of scan. MET-09 scans much faster than others - - select case (trim(this_obs_param%descr)) - - case ('LaRC_tskin-GOESE','LaRC_tskin-GOESW', 'LaRC_tskin-FY2E-') - - ts_time_offset=26*60/2 - - case ('LaRC_tskin-MTST2') - - ts_time_offset=28*60/2 - - case ('LaRC_tskin-MET09') - - ts_time_offset=12*60/2 - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown obs_param%descr') - - end select - - found_obs = .false. - - ! find files that are within half-open interval - ! [date_time-dtstep_assim/2,date_time+dtstep_assim/2) - - select case (trim(this_obs_param%descr)) - - case ('LaRC_tskin-GOESW') - MM=00 - case ('LaRC_tskin-GOESE') - MM=45 - case ('LaRC_tskin-MET09') - MM=00 - case ('LaRC_tskin-FY2E-') - MM=00 - case ('LaRC_tskin-MTST2') - MM=30 - case default - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown obs_param%descr') - end select - - date_time_tmp = date_time - - call augment_date_time( -(dtstep_assim/2 + ts_time_offset), date_time_tmp ) - - ! identify all files within current assimilation interval - ! inquire for the file once per hour - will always be at same minutes past hour - - N_files=0 - - do i=1,(dtstep_assim/3600) - - write (YYYYMM, '(i6.6)') date_time_tmp%year*100 + date_time_tmp%month - write (DDHHMM, '(i6.6)') date_time_tmp%day*10000 + date_time_tmp%hour*100 + MM - - tmp_fname=trim(this_obs_param%path) // '/' // YYYYMM(1:4) // & - '/' // YYYYMM(5:6) // '/' // DDHHMM(1:2) // '/' // & - trim(this_obs_param%name) & - // YYYYMM // DDHHMM(1:2) // '_' // DDHHMM(3:6) // 'z.nc4' - - inquire(file=trim(tmp_fname),exist=ex) - - if (ex) then - - N_files = N_files + 1 - - fnames(N_files) = tmp_fname - - end if - - call augment_date_time( 3600, date_time_tmp ) - - end do - - ! read observations: - ! - ! 1.) read N_tmp observations and their lat/lon info from file - ! 2.) get tile number for each obs from lat/lon - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - ! ---------------------------------------------------------------- - ! - ! 1.) read N_tmp observations and their lat/lon info from file - - if (N_files>0) then - - call read_LaRC_Tskin_nc4( & - this_obs_param, N_files, fnames(1:N_files), & - N_tmp, tmp_lon, tmp_lat, tmp_obs ) - - if (logit) then - - write (logunit,*) 'read_obs_LaRC_Tskin: read ', N_tmp, & - ' at date_time = ', date_time - do i=1,N_files - write (logunit,*) trim(fnames(i)) - end do - write (logunit,*) '----------' - - end if - - else - - N_tmp = 0 - - end if - - ! 2.) get tile number for each obs from lat/lon - - if (N_tmp>0) then - - allocate(tmp_tile_num(N_tmp)) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num ) - - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - ts_LARC = 0. - - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - ! make sure obs is within allowed range - - if ( (min_Tskin1) then - - ts_LARC(i) = ts_LARC(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - ts_LARC(i) = this_obs_param%nodata - - end if - - end do - - if (associated(tmp_tile_num)) deallocate(tmp_tile_num) - - do i=1,N_catd - - std_ts_LARC(i) = this_obs_param%errstd - - ! CSD - temporary - only works over Americas - ! if keep, base on SZA - - if ( (date_time_tmp%hour .GT. 2 ) .AND. (date_time_tmp%hour .LT. 14.5 )) then - - std_ts_LARC(i) = 1.3 ! 1.5 - - else - - std_ts_LARC(i) = 2.1 ! 2.2 - - end if - - ! CSD - end temporary. - ! -------------------------------- - - end do - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - ! clean up - - if (associated(tmp_obs)) deallocate(tmp_obs) - if (associated(tmp_lon)) deallocate(tmp_lon) - if (associated(tmp_lat)) deallocate(tmp_lat) - - end subroutine read_obs_LaRC_Tskin - - ! *************************************************************************** - - subroutine read_LaRC_Tskin_nc4( & - this_obs_param, N_files, fnames, N_data, lon, lat, ts_LaRC ) - - ! read Tskin from LaRC nc4 files - ! - ! Apply QC: - ! Screen longitude to retain obs only from closest GEOsat - ! Viewing zenith angle (VZA) - ! Cloud fraction - ! Sun zenith angle (SZA) - ! - ! returns number of data, and pointers to the lon, lat, and data - ! return ONLY valid data points (ie. excluding no-data-values) - ! - ! Currently tailored to read in LaRC files that have been reprocessed to replace - ! integer data with float data (to enable GFIO to be used) - ! - ! If LaRC fixes the files, will need to change: - ! if ( nvars .LT 5 ) - this is included as some LaRC files are missing HIRESTSKIN field - ! Replace lower case variable names with appropriate case - ! Replace nodata value (hardwired, as cannot read missing_value from file) - ! Replace time setting with actual minutes (currently rounded down to nearest hour, - ! due to bug/assumption in GFIO read var routines). - - ! DRAPER, June 2011 - - implicit none - - type(obs_param_type), intent(in) :: this_obs_param - - integer, intent(in) :: N_files - - character(*), dimension(N_files), intent(in) :: fnames - - integer, intent(out) :: N_data - - real, dimension(:), pointer :: lon, lat, ts_LaRC ! output - - ! local variables - - integer :: i, j, fid, rc - integer :: x, x_min, x_max, y, y_min, y_max - integer :: YYYYMMDD, HHMMSS - integer :: g_nlon, g_nlat, km, lm, nvars, ngatts - - real :: nodata_LARC - - real, parameter :: tol=0.01 - - ! QC - - real, parameter :: max_fcld = 20. ! max total cloud fraction (%) - real, parameter :: max_vza = 60. ! max viewing zenith angle - real, parameter :: min_excl_sza = 82. ! min of sza exclusion interval - real, parameter :: max_excl_sza = 90. ! max of sza exclusion interval - - logical :: tskin_ok, fcld_ok, sza_ok, vza_ok - - real, dimension(2) :: lon_range, lat_range - - real :: dlat, dlon - - logical :: first - - real, dimension(:,:), allocatable :: tmp_data, ave_data, sum_data - - integer, dimension(:,:), allocatable :: cnt_data - - real, dimension(:,:), allocatable :: tmp_vza, tmp_sza, tmp_fcld - - ! ---------------------- - ! - ! variables to fix viewing zenith angle bug in some of the 2012 GOES-East files - ! reprocessed by Ben Scarino - ! - ! the "tmp_goesEast_vza_*" parameters point to a dummy "vza.nc4" file that contains - ! the correct vza values (located within the path of the reprocessed GOES-East files) - - character( 40), parameter :: tmp_goesEast_vza_dirname = 'goesEast201205_201304_RM2' - character( 40), parameter :: tmp_goesEast_vza_fname = 'int2float/vza.nc4' - - integer, parameter :: tmp_goesEast_vza_YYYYMMDD = 20120629 - integer, parameter :: tmp_goesEast_vza_HHMMSS = 230000 - - character(300) :: tmp_fname - - integer :: ind, tmp_fid - - character(len=*), parameter :: Iam = 'read_LaRC_Tskin_nc4' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - ! make sure pointers are not allocated or associated - - if ( associated(lon) .or. associated(lat) .or. associated(ts_LaRC) ) then - err_msg = 'output pointers must not be ' // & - 'associated or allocated on input.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - !----------------------------------------- - ! read data into global arrays, perform QC - !----------------------------------------- - - first = .true. - - do j=1,N_files - - if (logit) write(logunit,'(400A)') 'reading LaRC Tskin obs from ', trim(fnames(j)) - - call Gfio_Open ( fnames(j), 1, fid, rc ) - - if (rc<0) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'Error opening gfio file') - end if - - ! temporary catch for files missing HIRESTSKIN (LaRC will fix this) - - call GFIO_DimInquire (fid,g_nlon,g_nlat,km,lm,nvars,ngatts,rc) - - dlon=360./real(g_nlon ) - dlat=180./real(g_nlat-1) - - if (rc<0) then - err_msg = 'DimInquire error, reading gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - !if (nvars .LT. 24) then (for original LaRC files) - - if (nvars .LT. 5) then ! reprocessed files have only 5 variables - - write (logunit,*) 'CSD_LaRC file missing a variable ', fnames(j) - - else - - if (first) then - - ! Attribute cannot be read from LaRC (or reprocessed) files - ! no idea why this is not working. ncdump shows attribute is in file - ! call GFIO_GetRealAtt ( fid, 'missing_value', 1, nodata_LARC, rc ) - !if (rc<0) call stop_it('Get attribute error, reading nodata from gfio file') - - nodata_LARC=-9.99e33 ! For reprocessed files only!!! LaRC use different value - - write(logunit,*) & - 'No-data-value manually set for reprocessed files: ', nodata_LARC - - ! get dimensions of grid and allocate temporary arrays - - allocate(tmp_data(g_nlon, g_nlat)) - allocate(ave_data(g_nlon, g_nlat)) - allocate(sum_data(g_nlon, g_nlat)) - allocate(cnt_data(g_nlon, g_nlat)) - allocate(tmp_vza( g_nlon, g_nlat)) - allocate(tmp_sza( g_nlon, g_nlat)) - allocate(tmp_fcld(g_nlon, g_nlat)) - - sum_data=0 - cnt_data=0 - - ! get dimensions of subgrid containing data for this disk - - lat_range=(/-52.0,52.0/) ! maximum range is +/-52.0 for VZA<60 - - ! specify boundary for min and max lon (select disk with lowest VZA) - - select case (trim(this_obs_param%descr)) - - case ('LaRC_tskin-GOESW') - lon_range=(/-175. ,-105. /) - case ('LaRC_tskin-GOESE') - lon_range=(/-105. , -36.875/) - case ('LaRC_tskin-MET09') - lon_range=(/ -36.875, 54. /) - case ('LaRC_tskin-FY2E-') - ! bounds will not change if not using FY2, as FY2 eastern hemisphere is missing - lon_range=(/ 54. , 90. /) - case ('LaRC_tskin-MTST2') - lon_range=(/ 90. , 180. /) ! avoid crossing the dateline - case default - err_msg = 'unknown obs_param%descr' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end select - - - ! find index of smallest lon > min_lon and of largest lon <= max_lon - - x_min=floor( (minval(lon_range)-(-180.))/dlon ) + 2 - x_max=floor( (maxval(lon_range)-(-180.))/dlon ) + 1 - - ! find index of smallest lat >= min_lat and of largest lat <= max_lat - - y_min=floor( (lat_range(1)-(-90.))/dlat ) + 1 - y_max=floor( (lat_range(2)-(-90.))/dlat ) + 1 - - first = .false. - - endif ! first - - ! cannot use actual time, as obs files are rounded to nearest hour - - ! ORIGINAL LaRC FILES - ! -define time as "minutes since YYYYMMDD, HHMM", and have time=0 - ! read(fnames(j)(len_trim(fnames(j))-8:len_trim(fnames(j))-5),'(i4)') HHMMSS - ! HHMMSS=HHMMSS*100 ! add seconds - - ! lat4d.sh REPROCESSED FILES - ! -define time as "hours since YYYYMMDD, HH", and have time=MM/60 - ! The GFIO routine getbegdatetime calculates the time increment in a file by - ! reading in first two values - ! If there is only one time value in the file, the second read (line 240) fails, - ! and incSecs=1 - ! This results in TimeIndex in GFIO_GetVar= (MM in seconds) (rather than 1) - ! (in summary, getbegdatetime assumes that if there are not multiple times in - ! a file, time must equal 0 - ! which it does not for reprocessed LaRC files) - ! Get around this by specifying MM=0 regardless of actual time - - read(fnames(j)(len_trim(fnames(j)) -8:len_trim(fnames(j))-7),'(i2)') HHMMSS - - HHMMSS=HHMMSS*10000 ! add seconds, assume minutes are zero - - read(fnames(j)(len_trim(fnames(j))-17:len_trim(fnames(j))-9),'(i8)') YYYYMMDD - - - ! read HIRESTSKIN - - call GFIO_GetVar( fid,'hirestskin', & - YYYYMMDD, HHMMSS, g_nlon, g_nlat, & - 0, 1, tmp_data(:,:), rc ) - if (rc<0) then - err_msg = 'GetVar error, reading hirestskin from gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! Viewing zenith angle (VZA) - - call GFIO_GetVar( fid,'vza', & - YYYYMMDD, HHMMSS, g_nlon, g_nlat, & - 0, 1, tmp_vza, rc ) - if (rc<0) then - err_msg = 'GetVar error, reading vza from gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! GOES-East VZA for end Sep, start Oct 2012 are incorrect in the files - ! reprocessed by Ben Scarino, replace VZA with that from a hard-coded file - - ind = index(fnames(j), trim(tmp_goesEast_vza_dirname)) - - if (ind/=0) then - - ! extract path to replacement vza file from "fnames(j)" - ! (=fnames(j) up to and including "tmp_goesEast_vza_dirname") - - tmp_fname = fnames(j)(1:ind+len_trim(tmp_goesEast_vza_dirname)-1) - - ! append "tmp_goesEast_vza_fname" - - tmp_fname = trim(tmp_fname) // '/' // trim(tmp_goesEast_vza_fname) - - call Gfio_Open (tmp_fname, 1, tmp_fid, rc ) - - if (rc<0) then - err_msg = 'Error opening gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! read replacement vza - - call GFIO_GetVar( tmp_fid,'vza', & - tmp_goesEast_vza_YYYYMMDD, tmp_goesEast_vza_HHMMSS, g_nlon, g_nlat, & - 0, 1, tmp_vza, rc ) - if (rc<0) then - err_msg = 'GetVar error, reading vza from gfio file (2)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - call GFIO_Close ( tmp_fid, rc ) - - end if - - - ! Sun zenith angle (SZA) - - call GFIO_GetVar( fid,'sza', & - YYYYMMDD, HHMMSS, g_nlon, g_nlat, & - 0, 1, tmp_sza, rc ) - if (rc<0) then - err_msg = 'GetVar error, reading sza from gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - - ! Cloud fraction (FCLD), level 1 is total cloud - - call GFIO_GetVar( fid,'fcld', & - YYYYMMDD, HHMMSS, g_nlon, g_nlat, & - 1, 1, tmp_fcld, rc ) - if (rc<0) then - err_msg = 'GetVar error, reading fcld from gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! calculate mean of all data that passes QC - - do x=x_min, x_max - - do y=y_min, y_max - - ! Tskin must not be no-data-value - - tskin_ok = (abs(tmp_data(x,y) - nodata_LARC) .GE. tol) - - ! fcld must not be no-data-value; fcld<=max_cld - - fcld_ok = & - (tmp_fcld(x,y) .LE. max_fcld) .AND. & - (abs(tmp_fcld(x,y)-nodata_LARC) .GT. tol) - - ! sza must not be no-data-value; sza<=min_excl_sza; sza>=max_excl_sza - - sza_ok = & - ( & - (tmp_sza(x,y) .LE. min_excl_sza) .OR. & - (tmp_sza(x,y) .GE. max_excl_sza) & - ) .AND. & - (abs(tmp_sza(x,y)-nodata_LARC) .GT. tol) - - ! vza must not be no-data-value; vza<=vza_max - - vza_ok = & - (tmp_vza( x,y) .LE. max_vza) .AND. & - (abs(tmp_vza( x,y)-nodata_LARC) .GT. tol) - - - if (tskin_ok .and. fcld_ok .and. sza_ok .and. vza_ok ) then - - sum_data(x,y) =sum_data(x,y) + tmp_data(x,y) - - cnt_data(x,y) = cnt_data(x,y)+1 - - end if - - end do - end do - - end if ! nvars - - call GFIO_Close ( fid, rc ) - - end do ! N_files - - - if ( .not. first) then - - ! only calc averages if found file with HIRESTSKIN - temporary for incomplete files - - ! calculate average over appropriate lat/lon range, and count locations with data - - N_data=0 - - do x=x_min, x_max - do y=y_min, y_max - if(cnt_data(x,y)>0) then - ave_data(x,y)=sum_data(x,y)/cnt_data(x,y) - N_data=N_data+1 - else - ave_data(x,y)=nodata_LARC - endif - enddo - enddo - - ! allocate pointers for return vectors (must be deallocated outside this subroutine!) - - allocate(lon( N_data)) - allocate(lat( N_data)) - allocate(ts_LaRC(N_data)) - - ! pass return data into vectors - - i=1 - do x=x_min, x_max - do y=y_min, y_max - if ( abs(ave_data(x,y)-nodata_LARC) .GT. tol ) then - ts_LaRC(i)=ave_data(x,y) - lon(i)=(x-1)*dlon -180. - lat(i)=(y-1)*dlat - 90. - i=i+1 - endif - enddo - enddo - - ! clean up - - deallocate(tmp_data) - deallocate(sum_data) - deallocate(cnt_data) - deallocate(ave_data) - deallocate(tmp_vza) - deallocate(tmp_sza) - deallocate(tmp_fcld) - - else - - N_data=0 - - ! OK not to allocate pointers for data? - - endif - - end subroutine read_LaRC_Tskin_nc4 - - ! ***************************************************************** - - subroutine read_obs_RedArkOSSE_sm( & - date_time, N_catd, tile_coord, this_obs_param, & - found_obs, RedArkOSSE_sm, std_RedArkOSSE_sm ) - - ! Read observations of surface soil moisture from Wade Crow's - ! synthetic RedArk OSSE 36km soil moisture files. - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! If there are N > 1 observations in a given tile, - ! a "super-observation" is computed by averaging the N observations. - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 25 May 2006 - ! reichle, 26 Sep 2006 - added iostat to open statement - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: RedArkOSSE_sm - real, intent(out), dimension(N_catd) :: std_RedArkOSSE_sm - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! RedArkOSSE synthetic soil moisture obs at 36km are available once a day. - ! - ! Mapping of the 36km retrievals to catchment/tile space is precomputed - ! and stored in p2t_nearest.dat and t2p_nearest.dat - - integer, parameter :: N_p2t = 1120 ! # of 36 km pixels - integer, parameter :: N_t2p = 69 ! # of tiles that need "duplicated" obs - - integer, parameter :: HH_obs = 21 ! obs hour of day (UTC) = 3pm CST - - ! initial QC parameters - - real, parameter :: obs_min = 0.0 ! min allowed obs - real, parameter :: obs_max = 0.45 ! max allowed obs - real, parameter :: opac_max = 0.3 ! max allowed vegetation opacity - - integer, parameter :: qc_failed_obs = -888. - - integer, dimension(N_p2t) :: p2t - integer, dimension(N_t2p,2) :: t2p - - character(3) :: DDD - character(4) :: YYYY - character(300) :: tmpfname - - integer :: i, j, ind, N_tmp, tmp_tile_id, istat - - real :: tmp_real, tmp_opac - - real, dimension(:), allocatable :: tmp_obs - integer, dimension(:), allocatable :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - character(len=*), parameter :: Iam = 'read_obs_RedArkOSSE_sm' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------- - - ! initialize - - found_obs = .false. - - ! obs are available only once per day - ! (hard-coded b/c time-of-day is not clear from filename) - - if (date_time%hour == HH_obs) then - - ! read observations: - ! - ! 1.) read observations, p2t, and t2p from files - ! 2.) for each observation determine tile_num ("p2t") - ! 3.) duplicate observations for tiles that are not covered yet ("t2p") - ! 4.) compute super-obs for each tile from all obs w/in that tile - ! - ! ---------------------------------------------------------------- - - ! 1.) a) read obs - - write (YYYY,'(i4.4)') date_time%year - write (DDD, '(i3.3)') date_time%dofyr - - tmpfname = trim(this_obs_param%path) // '/' // YYYY // & - '/' // trim(this_obs_param%name) // YYYY // '.' // DDD - - open(10, file=tmpfname, form='formatted', action='read', iostat=istat) - - if (istat==0) then - - N_tmp = N_p2t + N_t2p - - allocate(tmp_obs(N_tmp)) - allocate(tmp_tile_num(N_tmp)) - - do i=1,N_p2t - - read(10,*) tmp_real, tmp_opac - - tmp_obs(i) = tmp_real/100. ! unit conversion - - ! initial QC - - if ( (tmp_opac > opac_max) .or. & - (tmp_obs(i) > obs_max) .or. & - (tmp_obs(i) < obs_min) ) then - - tmp_obs(i) = qc_failed_obs - - end if - - end do - - close(10,status='keep') - - ! 1.) b) read p2t - - tmpfname = trim(this_obs_param%path) // '/p2t_nearest.dat' - - open(10, file=tmpfname, form='formatted', action='read') - - do i=1,N_p2t - - read(10,*) p2t(i), tmp_tile_id ! col 1: tile_num, col 2: tile_id - - ! check tile_id for consistency - - if (p2t(i)>0) then ! if statement added 1 May 2007, reichle - if (tmp_tile_id/=tile_coord(p2t(i))%tile_id) then - - !write (logunit,*) 'read_obs_RedArkOSSE(): something is wrong (p2t)' - !!!write (logunit,*) i, p2t(i), tmp_tile_id, tile_coord(p2t(i))%tile_id - !stop - - err_msg = 'something is wrong (p2t)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - end if - - end do - - close(10,status='keep') - - ! 1.) c) read t2p - - tmpfname = trim(this_obs_param%path) // '/t2p_nearest.dat' - - open(10, file=tmpfname, form='formatted', action='read') - - do i=1,N_t2p - - read(10,*) t2p(i,1:2), tmp_tile_id ! pixel_num, tile_num, tile_id - - if (tmp_tile_id/=tile_coord(t2p(i,2))%tile_id) then - err_msg = 'something is wrong (t2p)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - !write (logunit,*) 'read_obs_RedArkOSSE(): something is wrong (t2p)' - !stop - ! - !end if - - end do - - close(10,status='keep') - - ! ----------------------- - ! - ! 2.) for each observation determine tile_num ("p2t") - - do i=1,N_p2t - - tmp_tile_num(i) = p2t(i) - - end do - - ! ----------------------- - ! - ! 3.) duplicate observations for tiles not covered yet ("t2p") - - do i=1,N_t2p - - j = i + N_p2t - - tmp_obs( j) = tmp_obs(t2p(i,1)) - - tmp_tile_num(j) = t2p(i,2) - - end do - - - ! ------------------------ - ! - ! 4.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - RedArkOSSE_sm = 0. - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - if (tmp_obs(i)>0.) then ! this step eliminates no-data - - RedArkOSSE_sm(ind) = RedArkOSSE_sm(ind) + tmp_obs(i) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - RedArkOSSE_sm(i) = RedArkOSSE_sm(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - RedArkOSSE_sm(i) = this_obs_param%nodata - - end if - - end do - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_RedArkOSSE_sm(i) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if ! istat==0 - - ! clean up - - if (allocated(tmp_tile_num)) deallocate(tmp_tile_num) - if (allocated(tmp_obs)) deallocate(tmp_obs) - - end if - - end subroutine read_obs_RedArkOSSE_sm - - ! ******************************************************************* - - subroutine read_obs_RedArkOSSE_CLSMsynthSM( date_time, N_catd, & - this_obs_param, & - found_obs, RedArkOSSE_CLSMsynthSM, std_RedArkOSSE_CLSMsynthSM ) - - ! Read synthetic observations of surface soil moisture from CLSM - ! RedArkOSSE integration (generated in matlab from innov output with - ! get_RedArk_CLSM_synth_retrievals.m) - ! - ! synthetic RedArk OSSE 36km soil moisture files. - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 16 Feb 2006 - ! reichle, 5 Apr 2007 - use obs std from default nml input - ! (instead of reading from file) - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: RedArkOSSE_CLSMsynthSM - real, intent(out), dimension(N_catd) :: std_RedArkOSSE_CLSMsynthSM - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! RedArkOSSE CLSM synthetic soil moisture obs are available once a day. - - integer, parameter :: HH_obs = 21 ! obs hour of day (UTC) = 3pm CST - - real, parameter :: nodata = -9999. - - ! initial QC parameters - - real, parameter :: obs_min = 0.0 ! min allowed obs - real, parameter :: obs_max = 0.5 ! max allowed obs - - character(2) :: MM, DD - character(4) :: YYYY, HHMM - character(300) :: tmpfname - - integer :: i, N_tmp, istat, tmp_tilenum - - real :: tmp_obs, tmp_obs_std - - ! ------------------------------------------------------------------- - - ! initialize - - found_obs = .false. - - ! obs are available only once per day - ! (hard-coded b/c time-of-day is not very clear in RedArkOSSE - - if (date_time%hour == HH_obs) then - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HHMM,'(i4.4)') 100*HH_obs - - tmpfname = trim(this_obs_param%path) // '/Y' // YYYY // '/M' // MM // & - '/' // trim(this_obs_param%name) // YYYY // MM // DD // '_' // HHMM - - open(10, file=tmpfname, form='formatted', action='read', iostat=istat) - - if (istat==0) then - - read(10,*) N_tmp - read(10,*) ! tmp_obs_std - - ! do NOT use obs std from file - ! (s.t. "wrong" obs std can be specified conveniently in nml file) - ! reichle, 5 Apr 2007 - - tmp_obs_std = this_obs_param%errstd - - RedArkOSSE_CLSMsynthSM( 1:N_catd) = nodata - std_RedArkOSSE_CLSMsynthSM(1:N_catd) = tmp_obs_std - - do i=1,N_tmp - - read(10,*) tmp_tilenum, tmp_obs - - ! initial QC - - tmp_obs = min( obs_max, tmp_obs ) - tmp_obs = max( obs_min, tmp_obs ) - - RedArkOSSE_CLSMsynthSM( tmp_tilenum ) = tmp_obs - - end do - - close(10,status='keep') - - found_obs = .true. - - end if ! istat==0 - - end if - - end subroutine read_obs_RedArkOSSE_CLSMsynthSM - - ! ***************************************************************** - - subroutine read_obs_VivianaOK_CLSMsynthSM( date_time, N_catd, & - this_obs_param, & - found_obs, VivianaOK_CLSMsynthSM, std_VivianaOK_CLSMsynthSM ) - - ! Read synthetic observations of surface soil moisture from CLSM - ! integration over Viviana's OK domain - ! - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! vmaggion + reichle, 4 Aug 2008: - ! adapted from read_obs_RedArkOSSE_CLSMsynthSM - ! use obs std from default nml input (instead of reading from file) - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: VivianaOK_CLSMsynthSM - real, intent(out), dimension(N_catd) :: std_VivianaOK_CLSMsynthSM - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! VivianaOK CLSM synthetic soil moisture obs are available once a day. - - integer, parameter :: HH_obs = 12 ! obs hour of day (UTC) = 6am CST - - real, parameter :: nodata = -9999. - - ! initial QC parameters - - real, parameter :: obs_min = 0.0 ! min allowed obs - real, parameter :: obs_max = 0.5 ! max allowed obs - - character(2) :: MM, DD, HH - character(4) :: YYYY - character(300) :: tmpfname - - integer :: i, istat - - real :: tmp_obs, tmp_obs_std - - ! ------------------------------------------------------------------- - - ! initialize - - found_obs = .false. - - ! obs are available only once per day - ! (hard-coded b/c time-of-day is not very clear in VivianaOK - - if (date_time%hour == HH_obs) then - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HH, '(i2.2)') HH_obs - - tmpfname = trim(this_obs_param%path) // '/' // & - trim(this_obs_param%name) // YYYY // MM // DD // '_' // HH // 'z.txt' - - open(10, file=tmpfname, form='formatted', action='read', iostat=istat) - - if (istat==0) then - - ! do NOT use obs std from file - ! (s.t. "wrong" obs std can be specified conveniently in nml file) - - tmp_obs_std = this_obs_param%errstd - - VivianaOK_CLSMsynthSM( 1:N_catd) = nodata - std_VivianaOK_CLSMsynthSM(1:N_catd) = tmp_obs_std - - do i=1,N_catd - - read(10,*) tmp_obs - - ! initial QC - - tmp_obs = min( obs_max, tmp_obs ) - tmp_obs = max( obs_min, tmp_obs ) - - VivianaOK_CLSMsynthSM(i) = tmp_obs - - if (abs(tmp_obs-nodata)>1e-4) found_obs = .true. - - end do - - close(10,status='keep') - - end if ! istat==0 - - end if - - end subroutine read_obs_VivianaOK_CLSMsynthSM - - ! ***************************************************************** - - subroutine read_obs_RedArkOSSE_truth( & - date_time, N_catd, this_obs_param, & - found_obs, RedArkOSSE_truth, std_RedArkOSSE_truth ) - - ! Read "observations" of true surface soil moisture from Wade Crow's - ! truth soil moisture in CLSM catchment space. - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 18 Sep 2006 - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: RedArkOSSE_truth - real, intent(out), dimension(N_catd) :: std_RedArkOSSE_truth - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - ! RedArkOSSE soil moisture truth available once a day. - ! - ! Truth is stored directly in Catchment space - - integer, parameter :: HH_obs = 21 ! obs hour of day (UTC) = 3pm CST - - character(2), parameter :: HH = '15' ! might be CST??? - - character(3) :: DDD - character(4) :: YYYY - character(300) :: tmpfname - - integer :: i, istat - - real :: tmp_real - - ! ------------------------------------------------------------------- - - ! initialize - - found_obs = .false. - - ! obs are available only once per day - ! (hard-coded b/c time-of-day is not clear from filename) - - if (date_time%hour == HH_obs) then - - ! read observations from file - - write (YYYY,'(i4.4)') date_time%year - write (DDD, '(i3.3)') date_time%dofyr - - ! file name - - tmpfname = trim(this_obs_param%path) // '/' // YYYY // & - '/' // trim(this_obs_param%name) // YYYY // '.' // DDD // '.' // HH - - ! open file and read obs if available - - open(10, file=tmpfname, form='formatted', action='read', iostat=istat) - - if (istat==0) then - - do i=1,N_catd - - read(10,*) tmp_real - - RedArkOSSE_truth(i) = tmp_real/100. ! unit conversion - - end do - - close(10,status='keep') - - ! set observation error standard deviation - - do i=1,N_catd - std_RedArkOSSE_truth(i) = this_obs_param%errstd - end do - - found_obs = .true. - - end if - end if - - end subroutine read_obs_RedArkOSSE_truth - - ! ***************************************************************** - - subroutine read_obs_isccp_tskin_gswp2_v1( & - date_time, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, isccp_tskin_gswp2_v1, std_isccp_tskin_gswp2_v1 ) - - ! Read observations of land skin temperature from ISCCP data - ! produced by Sarith on GSWP-2 grid - ! Set flag "found_obs" to true if observations are available - ! for assimilation. - ! - ! If there are N > 1 observations in a given tile, - ! a "super-observation" is computed by averaging the N observations - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 26 Sep 2005 - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: isccp_tskin_gswp2_v1 - real, intent(out), dimension(N_catd) :: std_isccp_tskin_gswp2_v1 - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - integer, parameter :: N_gswp2_compressed = 15238 - - ! land_i_gswp2 and land_j_gswp2 as stored in - ! ISCCP_Tskin_GSWP2_grid_V1 files (by Sarith) follow the GSWP2 convention - ! for grid orientation, that is counting from north-to-south - ! and from west-to-east - - real, parameter :: minlon_gswp2 = -180.5 - real, parameter :: maxlat_gswp2 = 90.5 - - real, parameter :: dx_gswp2 = 1. - real, parameter :: dy_gswp2 = 1. - - ! parameters for initial quality control and no-data-value treatment - - real, parameter :: tskin_min = 200. - real, parameter :: tskin_max = 400. - - ! ISCCP_Tskin_GSWP2_grid_V1 files are available every 3h - - character(2) :: HH - character(4) :: YYYY, MMDD - character(300) :: fname - - integer :: i, j, ind, istat, N_tmp - - real :: tsclr - - integer :: land_i_gswp2, land_j_gswp2 - - integer, dimension(N_gswp2_compressed) :: tmp_tile_num - - real, dimension(N_gswp2_compressed) :: tmp_obs, tmp_lat, tmp_lon - - integer, dimension(N_catd) :: N_obs_in_tile - - ! ------------------------------------------------------------------- - - ! initialize - - found_obs = .false. - - ! assemble file name - - write (YYYY,'(i4.4)') date_time%year - write (MMDD,'(i4.4)') date_time%month*100 + date_time%day - write (HH, '(i2.2)') date_time%hour - - fname = trim(this_obs_param%path) // '/' // '/Y' // YYYY // & - '/M' // MMDD(1:2) // '/' // trim(this_obs_param%name) & - // YYYY // MMDD // '_' // HH // 'z.bin' - - open(10, file=fname, form='unformatted', convert='big_endian', & - action='read', status='old', iostat=istat) - - ! read observations: - ! - ! 1.) read N_tmp observations and their lat/lon info from file - ! 2.) for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! - ! ---------------------------------------------------------------- - ! - ! 1.) read N_tmp observations and their lat/lon info from file - - if (istat==0) then - - j = 0 - - do i=1,N_gswp2_compressed - - read (10) land_i_gswp2, land_j_gswp2, tsclr - - ! eliminate no-data-values (specify range of acceptable tskin) - - if ( (tsclr>tskin_min) .and. & - (tsclr0) then - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tmp, tmp_lat(1:N_tmp), tmp_lon(1:N_tmp), & - this_obs_param, & - tmp_tile_num(1:N_tmp) ) - - ! ---------------------------------------------------------------- - ! - ! 3.) compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - isccp_tskin_gswp2_v1 = 0. - N_obs_in_tile = 0 - - do i=1,N_tmp - - ind = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this step eliminates obs outside domain - - isccp_tskin_gswp2_v1(ind) = isccp_tskin_gswp2_v1(ind) + tmp_obs(i) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - isccp_tskin_gswp2_v1(i) = & - isccp_tskin_gswp2_v1(i)/real(N_obs_in_tile(i)) - - elseif (N_obs_in_tile(i)==0) then - - isccp_tskin_gswp2_v1(i) = this_obs_param%nodata - - end if - - end do - - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_isccp_tskin_gswp2_v1(i) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - end subroutine read_obs_isccp_tskin_gswp2_v1 - - ! ***************************************************************** - - subroutine read_obs_isccp_tskin_ceop3n4( & - date_time, N_catd, tile_coord, & - this_obs_param, & - found_obs, isccp_tskin_gswp2_v1, std_isccp_tskin_gswp2_v1 ) - - ! *** ONLY for "CEOP3n4_by_tile_FV_144x91" domain *** - ! - ! Read observations of land skin temperature from ISCCP data - ! produced by Sarith on GSWP-2 grid - ! Set flag "found_obs" to true if observations are available - ! for assimilation (even if only "nodata" values in file...). - ! - ! inputs to this subroutine: - ! date_time = current model date and time - ! N_catd = number of catchments in domain - ! - ! reichle, 27 Jan 2009 - ! - ! -------------------------------------------------------------------- - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! outputs: - - real, intent(out), dimension(N_catd) :: isccp_tskin_gswp2_v1 - real, intent(out), dimension(N_catd) :: std_isccp_tskin_gswp2_v1 - logical, intent(out) :: found_obs - - ! --------------- - - ! locals - - integer, parameter :: N_gswp2_compressed = 15238 - - ! parameters for initial quality control and no-data-value treatment - - real, parameter :: tskin_min = 200. - real, parameter :: tskin_max = 400. - - integer, parameter :: N_tiles = 41 - - ! the following mapping is from - ! /land/l_data/CEOP/EOP3n4/coord/map_CEOP3n4_to_ISCCP_GSWP2.txt - ! produced with - ! land01:/home/reichle/GMAO/station_data/CEOP/EOP3n4/matlab/map_GEOS5_to_ISCCP_GSWP2.m - - ! ISCCP_Tskin_GSWP2_grid_V1 files are available every 3h - - character(2) :: HH - character(4) :: YYYY, MMDD - character(300) :: fname - - integer :: i, istat - - real, dimension(N_gswp2_compressed) :: tsclr - - real :: tmp_obs - - integer :: land_i_gswp2, land_j_gswp2 - - character(len=*), parameter :: Iam = 'read_obs_isccp_tskin_ceop3n4' - character(len=400) :: err_msg - - integer, dimension(2,N_tiles) :: GEOS5_to_ISCCP - - ! ------------------------------------------ - - - GEOS5_to_ISCCP = reshape( & - (/ & - 64402, 96, & - 68663, 1687, & - 68677, 1686, & - 68771, 1792, & - 68773, 1630, & - 68774, 1792, & - 68775, 1842, & - 68811, 1791, & - 68813, 1790, & - 68814, 1840, & - 68816, 1686, & - 68819, 1685, & - 68836, 1740, & - 68837, 1629, & - 68841, 1739, & - 68842, 1739, & - 68844, 1684, & - 68845, 1738, & - 68849, 1628, & - 69075, 2146, & - 69256, 1839, & - 69301, 1738, & - 80530, 5920, & - 80668, 6477, & - 81200, 7547, & - 91079, 11144, & - 91761, 12506, & - 91762, 12505, & - 91822, 12569, & - 92290, 11258, & - 97082, 13894, & - 97435, 13833, & - 99867, 13526, & - 100925, 11630, & - 100952, 11522, & - 101511, 12243, & - 101689, 12024, & - 101896, 11578, & - 101899, 11524, & - 101901, 11523, & - 106846, 14836 & - /), & - shape(GEOS5_to_ISCCP) & - ) - - - ! ------------------------------------------------------------------- - - if (N_catd/=N_tiles) then - err_msg = 'error 1 -- use only for CEOP3n4_by_tile_144x91 domain' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - !write (logunit,*) 'error 1 -- use only for CEOP3n4_by_tile_144x91 domain' - !stop - !end if - - ! initialize - - found_obs = .false. - - isccp_tskin_gswp2_v1 = this_obs_param%nodata - std_isccp_tskin_gswp2_v1 = this_obs_param%nodata - - ! assemble file name - - write (YYYY,'(i4.4)') date_time%year - write (MMDD,'(i4.4)') date_time%month*100 + date_time%day - write (HH, '(i2.2)') date_time%hour - - fname = trim(this_obs_param%path) // '/' // '/Y' // YYYY // & - '/M' // MMDD(1:2) // '/' // trim(this_obs_param%name) & - // YYYY // MMDD // '_' // HH // 'z.bin' - - open(10, file=fname, form='unformatted', convert='big_endian', & - action='read', status='old', iostat=istat) - - if (istat==0) then - - ! set found_obs=true (even if only nodata values in file) - - found_obs = .true. - - ! read observations from ISCCP file - - do i=1,N_gswp2_compressed - - read (10) land_i_gswp2, land_j_gswp2, tsclr(i) - - end do - - ! extract obs for CEOP3n4_by_tile_FV_144x91 domain - - do i=1,N_tiles - - ! double-check tile ids - - if (GEOS5_to_ISCCP(1,i)/=tile_coord(i)%tile_id) then - - !write (logunit,*) 'error 2 -- only for CEOP3n4_by_tile_144x91 domain' - !stop - - err_msg = 'error 2 -- only for CEOP3n4_by_tile_144x91 domain' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - else - - tmp_obs = tsclr(GEOS5_to_ISCCP(2,i)) - - ! basic QC - - if ( (tmp_obs>tskin_min) .and. (tmp_obs0) then - - tmp_obs = tsclr(GEOS5_to_ISCCP(2,i)) - - else - - tmp_obs = this_obs_param%nodata - - end if - - ! basic QC - - if ( (tmp_obs>tskin_min) .and. (tmp_obsN_files_max) then - err_msg = 'too many files found' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - fnames(k) = tmpfname - - end if - - call augment_date_time( dtstep_file, date_time_low ) - - end do ! end do while time step loop - - N_files = k - - ! --------------------------------------------------------------- - ! - ! read data if files were found - - if (N_files>0) then - - allocate(unitnum( N_files )) - - allocate(start_time( N_files, 5)) - allocate(end_time( N_files, 5)) - - allocate(Asc_flag( N_files )) - allocate(N_obs_tmp( N_files )) - allocate(N_ang_tmp( N_files )) - - ! open files, read and interpret headers - - do k=1,N_files - - unitnum(k) = unitnum_off + k - - open(unitnum(k), file=trim(fnames(k)),form='unformatted', convert='big_endian',status='old', & - access='SEQUENTIAL', iostat=istat) - - if (istat/=0) then - - err_msg = 'could not open file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - else - - if (logit) write (logunit,'(400A)') 'reading file ' // trim(fnames(k)) - - end if - - read(unitnum(k)) Asc_flag( k ) ! could also read version no. - read(unitnum(k)) start_time(k,:) - read(unitnum(k)) end_time( k,:) - read(unitnum(k)) N_obs_tmp( k ), N_ang_tmp(k) - - if (logit) write (logunit,*) ' Asc_flag = ', Asc_flag( k ) - if (logit) write (logunit,*) ' start_time = ', start_time( k,:) - if (logit) write (logunit,*) ' end_time = ', end_time( k,:) - if (logit) write (logunit,*) ' N_obs_tmp = ', N_obs_tmp( k ) - if (logit) write (logunit,*) ' N_ang_tmp = ', N_ang_tmp( k ) - - end do - - ! make sure N_ang is same in all files - - N_ang = N_ang_tmp(1) - - do k=2,N_files - - if ( N_obs_tmp(k)>0 .and. (N_ang/=N_ang_tmp(k)) ) then - err_msg = 'angles differ between files' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end do - - ! allocate data variables - - N_obs = sum(N_obs_tmp(1:N_files)) - - if (N_obs>0) then - - allocate(tmp_ang(N_ang)) - - allocate(tmp_lon(N_obs)) - allocate(tmp_lat(N_obs)) - - allocate(tmp_obs(N_obs)) - - allocate(tmp_std(N_obs)) - allocate(tmp_cnt(N_obs)) - - allocate(tmp_file_ind(N_obs)) - - if (SM_files) allocate(tmp_DQX(N_obs)) - - ! loop through files and read data - - ind_end = 0 - - do k=1,N_files - - if (N_obs_tmp(k)>0) then - - ind_start = ind_end + 1 - - ind_end = ind_start + N_obs_tmp(k) - 1 - - ! record to which file each obs belongs - - tmp_file_ind(ind_start:ind_end) = k - - ! continue with reading file (scalars in header were read above) - - read(unitnum(k)) tmp_ang ! assume same angles in all files - read(unitnum(k)) tmp_lon(ind_start:ind_end) - read(unitnum(k)) tmp_lat(ind_start:ind_end) - - - if (SM_files) then - - ! read SMOS SM file - - read(unitnum(k)) tmp_obs(ind_start:ind_end) ! 1 SM - read(unitnum(k)) ! 2 ST - read(unitnum(k)) ! 3 tau - read(unitnum(k)) ! 4 Tbh - read(unitnum(k)) ! 5 Tbv - read(unitnum(k)) tmp_DQX(ind_start:ind_end) ! 6 SM RSTD - read(unitnum(k)) ! 7 ST RSTD - read(unitnum(k)) ! 8 tau RSTD - read(unitnum(k)) tmp_std(ind_start:ind_end) ! 9 std-dev SM - read(unitnum(k)) tmp_cnt(ind_start:ind_end) ! 10 count SM - - else - - ! read SMOS Tb file - - ! first time obs are read: figure out angle and polarization of interest - - if (ind_start==1) then - - ! find the index for the angle of interest - ! NOTE: after processing of namelist inputs, each species - ! has a unique angle (see subroutine read_ens_upd_inputs()) - - ind_angle = -9999 - - do i=1,N_ang - - if (abs(tmp_ang(i)-this_obs_param%ang(1))<0.01) ind_angle = i - - end do - - if (ind_angle<0) then - err_msg = 'Problem with incidence angle' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! need h-pol or v-pol? - - if (this_obs_param%pol==1) then - - hpol = .true. - - elseif (this_obs_param%pol==2) then - - hpol = .false. - - else - - err_msg = 'Problem with polarization' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end if - - ! for each field, loop over all angles, keep data at angle of interest - - do i=1,N_ang ! (1) Tbh - - if ( (i==ind_angle) .and. ( hpol) ) then - read(unitnum(k)) tmp_obs(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - do i=1,N_ang ! (2) Tbv - - if ( (i==ind_angle) .and. (.not. hpol) ) then - read(unitnum(k)) tmp_obs(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - do i=1,N_ang ! (3) std-dev Tbh - - if ( (i==ind_angle) .and. ( hpol) ) then - read(unitnum(k)) tmp_std(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - do i=1,N_ang ! (4) std-dev Tbv - - if ( (i==ind_angle) .and. (.not. hpol) ) then - read(unitnum(k)) tmp_std(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - do i=1,N_ang ! (5) count Tbh - - if ( (i==ind_angle) .and. ( hpol) ) then - read(unitnum(k)) tmp_cnt(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - do i=1,N_ang ! (6) count Tbv - - if ( (i==ind_angle) .and. (.not. hpol) ) then - read(unitnum(k)) tmp_cnt(ind_start:ind_end) - else - read(unitnum(k)) - end if - - end do - - ! additional fields in file that are not currently read: - ! - ! (7-8) RA Tbh-Tbv - ! (9-16) repeat the above for T3 and T4 - - end if ! if SM_files - - end if ! if N_obs_tmp(k)>0 - - end do ! loop through files - - ! ------------------------------------------------- - ! - ! eliminate no-data-values and data that fail initial QC - ! and keep track how many obs survived from each file - - N_obs_tmp = 0 ! re-use N_obs_tmp - - j=0 - - do n=1,N_obs - - if (SM_files) then - - keep_data = & - (tmp_obs( n) > SM_min) .and. & ! incl: any neg is nodata - (tmp_obs( n) < SM_max) .and. & - (tmp_DQX( n) > SM_DQX_min) .and. & - (tmp_DQX( n) < SM_DQX_max) .and. & - (tmp_std( n) < SM_std_max) .and. & - (tmp_cnt( n) >= SM_cnt_min) - - else - - keep_data = & - (tmp_obs( n) > Tb_min) .and. & ! incl: any neg is nodata - (tmp_obs( n) < Tb_max) .and. & - (tmp_std( n) < Tb_std_max) .and. & - (tmp_cnt( n) >= Tb_cnt_min) - - end if - - if (keep_data) then - - j=j+1 - - tmp_obs(j) = tmp_obs(n) - tmp_lon(j) = tmp_lon(n) - tmp_lat(j) = tmp_lat(n) - - N_obs_tmp(tmp_file_ind(n)) = N_obs_tmp(tmp_file_ind(n)) + 1 - - end if - - end do - - N_obs = j ! Note: This is NOT the final number of valid obs in "SMOS_data"! - - if (SM_files) deallocate(tmp_DQX) - - deallocate(tmp_std) - deallocate(tmp_cnt) - - deallocate(tmp_file_ind) - - ! ------------------------------------------------- - ! - ! map obs to tiles - ! - ! for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_obs>0) then - - allocate(tmp_tile_num(N_obs)) - - ! temporarily shift lat/lon of obs for computation of nearest tile to - ! avoid ambiguous assignment of M09 model tile within M36 obs grid cell - ! (center of M36 grid cell is equidistant from at least two M09 model - ! tiles) -- reichle, 23 Aug 2013 - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_obs, tmp_lat, tmp_lon, & - this_obs_param, & - tmp_tile_num, & - tmp_shift_lat, tmp_shift_lon ) - - ! make sure center-of-mass of tile that administers obs - ! is within EASEv2 M36 obs grid cell, discard obs otherwise - ! (by setting tmp_tile_num to negative value) - ! - reichle, 31 Jan 2014 - ! - ! It is not 100 percent clear why this piece code had been added - ! at the time. - ! Chances are that it had to do with land-water mask issues and the - ! distortion of EASE grid cells at high latitudes, and/or Gabrielle's - ! use of an M36 innovations integration to derive Tb scaling files - ! for the M09 (SMAP) system. - ! The problem with the piece of code is that it throws out far too many - ! obs (at all latitudes) if the tile space is coarse, e.g., that of the - ! 1/2 deg Lat/Lon grids of MERRA or MERRA-2. - ! The piece of code may no longer be needed because of improvements in - ! the obs readers and in get_obs_pred(), but the impact of removing the - ! code on the SMAP L4_SM system is not clear. At this time, just prior - ! to finalizing the L4_SM "validated release", keep the code for the - ! EASEv2 M09 and M36 tile spaces that are relevant for the L4_SM - ! system, but drop it for all other tile spaces. - ! - reichle, 3 Feb 2016 - - if ( & - (index(tile_grid_d%gridtype, 'EASEv2_M09') /=0) .or. & - (index(tile_grid_d%gridtype, 'EASEv2_M36') /=0) ) then - - do ii=1,N_obs - - if (tmp_tile_num(ii)>0) then - - call ease_convert('EASEv2_M36', & - tile_coord(tmp_tile_num(ii))%com_lat, & - tile_coord(tmp_tile_num(ii))%com_lon, & - M36_col_ind_tile, M36_row_ind_tile ) - - call ease_convert('EASEv2_M36', & - tmp_lat(ii), & - tmp_lon(ii), & - M36_col_ind_obs, M36_row_ind_obs ) - - if ( (nint(M36_col_ind_tile)/=nint(M36_col_ind_obs)) .or. & - (nint(M36_row_ind_tile)/=nint(M36_row_ind_obs)) ) & - tmp_tile_num(ii) = -9999 - - end if - - end do - - end if - - ! compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - SMOS_data = 0. - SMOS_lon = 0. - SMOS_lat = 0. - - N_obs_in_tile = 0 - - do i=1,N_obs - - ind_tile = tmp_tile_num(i) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind_tile>0) then ! this step eliminates obs outside domain - - SMOS_data(ind_tile) = SMOS_data(ind_tile) + tmp_obs(i) - SMOS_lon( ind_tile) = SMOS_lon( ind_tile) + tmp_lon(i) - SMOS_lat( ind_tile) = SMOS_lat( ind_tile) + tmp_lat(i) - - N_obs_in_tile(ind_tile) = N_obs_in_tile(ind_tile) + 1 - - end if - - end do - - ! normalize - - do i=1,N_catd - - if (N_obs_in_tile(i)>1) then - - tmpreal = real(N_obs_in_tile(i)) - - SMOS_data(i) = SMOS_data(i)/tmpreal - SMOS_lon( i) = SMOS_lon( i)/tmpreal - SMOS_lat( i) = SMOS_lat( i)/tmpreal - - elseif (N_obs_in_tile(i)==0) then - - SMOS_data(i) = this_obs_param%nodata - SMOS_lon( i) = this_obs_param%nodata - SMOS_lat( i) = this_obs_param%nodata - - end if - - end do - - ! clean up - - deallocate(tmp_tile_num) - - ! -------------------------------- - - ! set observation error standard deviation - - do i=1,N_catd - std_SMOS_data(i) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if - - deallocate(tmp_ang) - - deallocate(tmp_lon) - deallocate(tmp_lat) - - deallocate(tmp_obs) - - end if - - do k=1,N_files - - close(unitnum(k),status='keep') - - end do - - deallocate(unitnum) - - deallocate(start_time) - deallocate(end_time) - deallocate(Asc_flag) - deallocate(N_ang_tmp) - - end if ! if N_files>0 - - ! ------------------------------------------------- - ! - ! write "obslog" file - - if (write_obslog) then - - YYYYMMDD_HHMMSSz = date_time2string(date_time) - - tmpstr80 = 'read_obs_SMOS()' ! name of this subroutine - - do k=1,N_files - - write (tmpstr12,'(i12)') N_obs_tmp(k) ! convert integer to string - - call add_to_obslog( YYYYMMDD_HHMMSSz, this_obs_param%descr, tmpstr80, & - tmpstr12, fnames(k) ) - - end do - - end if - - ! clean up - - if (N_files>0) deallocate(N_obs_tmp) - - deallocate(fnames) - - if (logit) write (logunit,*) 'read_obs_SMOS(): done.' - - end subroutine read_obs_SMOS - - - ! ***************************************************************** - - subroutine read_obs_MODIS_SCF( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, MODIS_obs, std_MODIS_obs, MODIS_lon, MODIS_lat ) - - ! read MODIS snow cover fraction observations on MODIS 0.05-degree climate - ! modeling grid (CMG) - ! - ! Terra: MOD10C1 - ! Aqua: MYD10C1 - ! - ! For now, assume that MODIS resolution is finer than Catchment tile space - ! and super-ob data to tile space, with lat/lon coords of obs matching - ! lat/lon coords of tiles - ! - ! reichle, 18 Oct 2023 - ! - ! ------------------------------------------------------------------------------ - - implicit none - - ! inputs - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim ! [seconds] - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! output - - logical, intent(out) :: found_obs - - real, dimension(N_catd), intent(out) :: MODIS_obs, std_MODIS_obs, MODIS_lon, MODIS_lat - - ! ------------------------------------------------------------------------ - - ! locals - - integer, parameter :: dtstep_assim_max = 21600 ! [seconds] avoid assim window spanning >=180 deg lon - - real, parameter :: CMG_dlon = 0.05 ! [degrees] longitude spacing of MODIS CMG grid - real, parameter :: CMG_dlat = 0.05 ! [degrees] latitude spacing of MODIS CMG grid - - real, parameter :: CMG_ll_lon = -180. ! [degrees] lower-left longitude of MODIS CMG grid - real, parameter :: CMG_ur_lat = 90. ! [degrees] upper-right latitude of MODIS CMG grid - - character(7) :: MODIS_product_ID - - character(4) :: YYYY - character(3) :: DDD ! day of year - - character(400) :: fname - - real :: overpass_hour, tmp_delta, tmp_real, max_delta_lon - - integer :: N_files, N_lon, N_lat, N_tmp, nn, kk, ind - integer :: N_CMG_obs, N_good_data, tmp_ind_start, tmp_ind_last - - type(date_time_type) :: date_time_beg, date_time_end - type(date_time_type) :: date_time_beg_MODIS, date_time_end_MODIS - - real :: lon_beg, lon_end - real :: lon_beg_MODIS, lon_end_MODIS - - integer :: delta_day_beg, delta_day_end - integer :: delta_day_beg_MODIS, delta_day_end_MODIS - - real :: lat_min, lat_max - - real, dimension(2) :: lon_min_vec, lon_max_vec - - integer, dimension(2) :: N_lon_vec, year_vec, dofyr_vec, start_ind, last_ind - - real, dimension(:), allocatable :: CMG_obs, CMG_lon, CMG_lat - - integer, dimension(:), allocatable :: tmp_tile_num - - integer, dimension(N_catd) :: N_obs_in_tile - - character(len=*), parameter :: Iam = 'read_obs_MODIS_SCF' - character(len=400) :: err_msg - - ! ---------------------------------------------------------------------------------- - ! - ! restrict assimilation time step to max allowed - - if (dtstep_assim > dtstep_assim_max) then - - err_msg = 'dtstep_assim exceeds max allowed' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - ! initialize - - found_obs = .false. - - - ! identify MODIS product and overpass hour - - MODIS_product_ID = this_obs_param%name(1:7) - - select case (MODIS_product_ID) - - case('MOD10C1'); overpass_hour = 10.5 ! [hours] Terra: 10:30am local time - - case('MYD10C1'); overpass_hour = 13.5 ! [hours] Aqua: 1:30pm local time - - end select - - - ! determine beginning and end of assimilation window - - date_time_beg = date_time - date_time_end = date_time - - call augment_date_time( -dtstep_assim/2, date_time_beg ) - call augment_date_time( dtstep_assim/2, date_time_end ) - - - ! determine longitude band associated with assimilation window and local overpass hour - ! - ! observations will be returned only for tiles with lon_end < tile_coord%com_lon <= lon_beg - - call localtime2longitude( date_time_beg, overpass_hour, lon_beg, delta_day_beg ) - call localtime2longitude( date_time_end, overpass_hour, lon_end, delta_day_end ) - - - ! determine (rough) longitude band for which MODIS obs need to be read - ! - ! --> because tiles have a non-zero extent, need to read MODIS obs in CMG grid cells located - ! in a wider band (lon_min-delta:lon_max+delta), - ! where delta should be somewhat larger than max( tile_coord%max_lon - tile_coord%min_lon ) - - tmp_delta = 3.*maxval( tile_coord(1:N_catd)%max_lon - tile_coord(1:N_catd)%min_lon ) ! [degrees] - - tmp_delta = tmp_delta/360.*86400. ! [seconds] - - date_time_beg_MODIS = date_time_beg - date_time_end_MODIS = date_time_end - - call augment_date_time( -nint(tmp_delta), date_time_beg_MODIS ) - call augment_date_time( nint(tmp_delta), date_time_end_MODIS ) - - call localtime2longitude( date_time_beg_MODIS, overpass_hour, lon_beg_MODIS, delta_day_beg_MODIS ) - call localtime2longitude( date_time_end_MODIS, overpass_hour, lon_end_MODIS, delta_day_end_MODIS ) - - ! adjust date_time_*_MODIS to reflect calendar date at lon_*_MODIS - - call augment_date_time( delta_day_beg_MODIS*86400, date_time_beg_MODIS ) - call augment_date_time( delta_day_end_MODIS*86400, date_time_end_MODIS ) - - ! put together arguments for call(s) to read_MODIS_SCF_hdf() - - lon_min_vec = MAPL_UNDEF - lon_max_vec = MAPL_UNDEF - - year_vec = -9999 - dofyr_vec = -9999 - - N_lon_vec = 0 - - if (lon_end_MODIS < lon_beg_MODIS) then - - if ( date_time_end_MODIS%dofyr == date_time_beg_MODIS%dofyr ) then - - ! need only one daily MODIS file and longitude band - - N_files = 1 - - lon_min_vec(1) = lon_end_MODIS - lon_max_vec(1) = lon_beg_MODIS - - year_vec( 1) = date_time_beg_MODIS%year - dofyr_vec( 1) = date_time_beg_MODIS%dofyr - - else - - ! this should never happen for dtstep_assim_max=21600 and overpass_hour=10:30am or 1:30pm - - write (logunit,*) 'overpass_hour = ', overpass_hour - write (logunit,*) 'date_time = ', date_time - write (logunit,*) 'date_time_beg = ', date_time_beg - write (logunit,*) 'date_time_end = ', date_time_end - write (logunit,*) 'date_time_beg_MODIS = ', date_time_beg_MODIS - write (logunit,*) 'date_time_end_MODIS = ', date_time_end_MODIS - write (logunit,*) 'lon_beg = ', lon_beg - write (logunit,*) 'lon_end = ', lon_end - write (logunit,*) 'lon_beg_MODIS = ', lon_beg_MODIS - write (logunit,*) 'lon_end_MODIS = ', lon_end_MODIS - - err_msg = 'encountered unexpected condition for longitude band!!!' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - else - - ! longitude band wraps around dateline, two daily MODIS files are needed - ! (this could also occur if lon_*_MODIS=180., which would result in an - ! empty first longitude band, but because of tmp_delta>0, this should - ! never happen) - - N_files = 2 - - lon_min_vec(1) = lon_end_MODIS - lon_max_vec(1) = 179.999 ! use 179.999 such that zero-based last_ind<=N_lon-1 (see below) - - year_vec( 1) = date_time_end_MODIS%year - dofyr_vec( 1) = date_time_end_MODIS%dofyr - - lon_min_vec(2) = -180. - lon_max_vec(2) = lon_beg_MODIS - - year_vec( 2) = date_time_beg_MODIS%year - dofyr_vec( 2) = date_time_beg_MODIS%dofyr - - end if - - ! verify that longitude bands do not exceed max expected expected width - ! (add 0.1 degree of wiggle room) - - max_delta_lon = real(dtstep_assim_max + 2*nint(tmp_delta))/86400.*360. + 0.1 ! [degree] - - do nn=1,N_files - - if ( lon_max_vec(nn) - lon_min_vec(nn) > max_delta_lon ) then - - err_msg = 'longitude band too wide' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end do - - - ! determine latitude band covered by domain (no need to read obs outside domain) - - lat_min = minval( tile_coord(1:N_catd)%min_lat ) - lat_max = maxval( tile_coord(1:N_catd)%max_lat ) - - - ! determine N_lat and N_lon[_vec] (# CMG grid cells in lat/lon bands ) - - start_ind(1) = (CMG_ur_lat - lat_max )/CMG_dlat - last_ind(1) = (CMG_ur_lat - lat_min )/CMG_dlat - - N_lat = last_ind(1) - start_ind(1) + 1 - - start_ind = (lon_min_vec - CMG_ll_lon)/CMG_dlon - last_ind = (lon_max_vec - CMG_ll_lon)/CMG_dlon - - N_lon_vec = last_ind - start_ind + 1 - - N_lon = sum( N_lon_vec(1:N_files) ) - - - - ! ! dbg ! ! write (*,*) '###############################################################################' - ! ! dbg ! ! write (*,*) Iam // '():' - ! ! dbg ! ! write (*,*) 'lon_min_vec = ', lon_min_vec - ! ! dbg ! ! write (*,*) 'lon_max_vec = ', lon_max_vec - ! ! dbg ! ! write (*,*) 'start_ind = ', start_ind - ! ! dbg ! ! write (*,*) 'last_ind = ', last_ind - ! ! dbg ! ! write (*,*) 'lat_min = ', lat_min - ! ! dbg ! ! write (*,*) 'lat_max = ', lat_max - ! ! dbg ! ! write (*,*) 'year_vec = ', year_vec - ! ! dbg ! ! write (*,*) 'dofyr_vec = ', dofyr_vec - ! ! dbg ! ! write (*,*) 'N_lon_vec = ', N_lon_vec - ! ! dbg ! ! write (*,*) 'N_lat = ', N_lat - ! ! dbg ! ! write (*,*) '###############################################################################' - - - - ! allocate arrays for MODIS CMG data (max size that could possibly be needed for obs from both files) - - N_tmp = N_lon*N_lat - - allocate( CMG_obs(N_tmp) ) - allocate( CMG_lon(N_tmp) ) - allocate( CMG_lat(N_tmp) ) - - - ! read MODIS SCF obs - ! - ! - (renamed) files currently located at /discover/nobackup/projects/S2SHMA/MODIS/MOD10C1_V61/ (2010-2022) - ! - ! - in ensupd nml file, specify the file "name" according to the following template: - ! - ! %name = 'MOD10C1.Ayyyyddd.061.hdf' - ! - ! 1 2 - ! 123456789012345678901234 - ! - ! MOD10C1 = MODIS product name - ! .A = "acquisition time" indicator - ! yyyyddd = placeholder for year/day-of-year - ! .061 = version (Collection) indicator - ! .hdf = file name extension - ! - ! Assuming the MODIS file naming convention remains unchanged, the version can then - ! be specified in the nml file. - - N_CMG_obs = 0 ! initialize counter for "good" obs returned by calls to read_MODIS_SCF_hdf() - - do nn=1,N_files ! loop through longitude bands - - ! determine MODIS file name(s) - - write (YYYY,'(i4.4)') year_vec( nn) - write (DDD, '(i3.3)') dofyr_vec(nn) - - fname = & - trim(this_obs_param%path) // '/' // YYYY // '/' // & - this_obs_param%name(1:9) // YYYY // DDD // this_obs_param%name(17:24) - - ! determine sub-array of CMG_* - - tmp_ind_start = N_CMG_obs + 1 - tmp_ind_last = N_CMG_obs + N_lon_vec(nn)*N_lat - - call read_MODIS_SCF_hdf( fname, & - lon_min_vec(nn), lon_max_vec(nn), lat_min, lat_max, & - N_good_data, & - CMG_lon(tmp_ind_start:tmp_ind_last), & - CMG_lat(tmp_ind_start:tmp_ind_last), & - CMG_obs(tmp_ind_start:tmp_ind_last) ) - - N_CMG_obs = N_CMG_obs + N_good_data - - end do - - - ! return if no MODIS obs were found (found_obs=.false. per initialization above) - - if (N_CMG_obs==0) return - - - ! map to tile space - - allocate(tmp_tile_num(N_CMG_obs)) - - call get_tile_num_for_obs( N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, & - tile_num_in_cell_ij, & - N_CMG_obs, CMG_lat(1:N_CMG_obs), CMG_lon(1:N_CMG_obs), & - this_obs_param, & - tmp_tile_num ) - - - std_MODIS_obs = this_obs_param%errstd - - MODIS_obs = 0. - MODIS_lon = 0. - MODIS_lat = 0. - - N_obs_in_tile = 0 - - do kk=1,N_CMG_obs - - ind = tmp_tile_num(kk) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind>0) then ! this condition eliminates obs outside domain - - MODIS_obs( ind) = MODIS_obs( ind) + CMG_obs(kk) - MODIS_lon( ind) = MODIS_lon( ind) + CMG_lon(kk) - MODIS_lat( ind) = MODIS_lat( ind) + CMG_lat(kk) - - N_obs_in_tile(ind) = N_obs_in_tile(ind) + 1 - - end if - - end do - - ! normalize - - do kk=1,N_catd - if (N_obs_in_tile(kk)>0) then - - tmp_real = real(N_obs_in_tile(kk)) - - MODIS_obs(kk) = MODIS_obs(kk)/tmp_real - MODIS_lon(kk) = MODIS_lon(kk)/tmp_real - MODIS_lat(kk) = MODIS_lat(kk)/tmp_real - - else if (N_obs_in_tile(kk)==0) then - - MODIS_obs(kk) = this_obs_param%nodata - MODIS_lon(kk) = this_obs_param%nodata - MODIS_lat(kk) = this_obs_param%nodata - - end if - end do - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - deallocate(tmp_tile_num) - - deallocate(CMG_obs) - deallocate(CMG_lon) - deallocate(CMG_lat) - - ! to avoid double-counting of MODIS CMG obs, remove obs for tiles with center-of-mass longitude - ! falling outside the longitude band associated with assimilation window - - if (lon_end < lon_beg) then - - ! need only one longitude band (keep obs when lon_end<=com_lon<=lon_beg) - - do kk=1,N_catd - - if ( (tile_coord(kk)%com_lonlon_beg) ) & - MODIS_obs(kk) = this_obs_param%nodata - - end do - - else - - ! longitude band wraps around dateline (keep obs when -180<=com_lon<=lon_beg or lon_end<=com_lon<=180) - - do kk=1,N_catd - - if ( (tile_coord(kk)%com_lon>lon_beg) .and. (tile_coord(kk)%com_lon= 24.) ) then - - err_msg = 'input local_hour falls outside allowed range of 0:24' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! initialize - - delta_day = 0 - - ! determine fractional UTC hour and time difference with local_hour - - UTC_hour = ( date_time%hour*3600 + date_time%min*60 + date_time%sec )/3600. ! 0 <= UTC_hour < 24 - - time_diff = local_hour - UTC_hour - - ! enforce -12. < time_diff <= 12. and determine associated date difference, if any - - if (time_diff <= -12.) then - - delta_day = 1 - - time_diff = time_diff + 24. - - elseif (time_diff > 12.) then - - delta_day = -1 - - time_diff = time_diff - 24. - - end if - - ! determine longitude - - longitude = time_diff/24.*360. - - end subroutine localtime2longitude - - ! ***************************************************************** - - subroutine read_MODIS_SCF_hdf( fname, lon_min, lon_max, lat_min, lat_max, & - N_good_data, CMG_lon, CMG_lat, CMG_SCF ) - - ! read snow cover area fraction (SCF) obs from daily MODIS Terra or Aqua M?D10C1, version 6.1 - ! - Terra: https://nsidc.org/data/mod10c1/versions/61 - ! - Aqua: https://nsidc.org/data/myd10c1/versions/61 - ! - daily data with spatial resolution of 0.05 deg on MODIS climate modeling grid (CMG) - ! - Terra: missing days 2016 d. 50-58 - ! - data are read for the requested lat/lon range - ! - apply QC - ! - ! reichle, 20 Oct 2023 - ! - ! ------------------------------------------------------------------------------------------------- - - implicit none - - character(*), intent(in) :: fname ! MODIS file name with full path - - real, intent(in) :: lon_min, lon_max ! -180 <= lon_* <= 180 - real, intent(in) :: lat_min, lat_max ! -90 <= lat_* <= 90 - - integer, intent(out) :: N_good_data - - real, dimension(:), intent(out) :: CMG_lon, CMG_lat, CMG_SCF ! NOTE: 1-dim array on CMG grid - - ! ------------------------------------------------- - - ! local parameters - - ! ll/ur_lon/lat simply indicate the extent of the MODIS CMG grid - ! - ! index increases from (-180,90) to (180,-90) (southward and eastward) - - integer, parameter :: CMG_N_lon = 7200 - integer, parameter :: CMG_N_lat = 3600 - - real, parameter :: CMG_ll_lon = -180. - real, parameter :: CMG_ll_lat = -90. - - real, parameter :: CMG_ur_lon = 180. - real, parameter :: CMG_ur_lat = 90. - - real, parameter :: CMG_dlon = 0.05 - real, parameter :: CMG_dlat = 0.05 - - integer, parameter :: N_fields = 3 - - character(22), dimension(N_fields), parameter :: field_names = (/ & - 'Day_CMG_Snow_Cover ', & ! 1 - 'Day_CMG_Clear_Index ', & ! 2 - 'Snow_Spatial_QA '/) ! 3 - - ! 1234567890123456789012 - ! 1 2 - - integer, parameter :: SCF_nodata = -9999. - - integer(KIND=2), parameter :: qc_snow_cover_max = 100 ! exclude lake ice, night, inland water, ocean, etc - integer(KIND=2), parameter :: qc_clear_index_min = 20 ! ensure sufficiently clear conditions - integer(KIND=2), parameter :: qc_snow_spatial_max = 2 ! data quality (0=best, 1=good, 2=OK, 3=poor, 4=other) - - integer, parameter :: DFACC_READ = 1 ! from hdf.inc - - integer, parameter :: uint8_min = 0 - integer, parameter :: uint8_max = 255 - - - ! local variables - - integer :: N_lon, N_lat, N_tmp, ii, jj, kk, nn - - real, dimension(:), allocatable :: lon_c - real, dimension(:), allocatable :: lat_c - - real, dimension(:), allocatable :: lon_ind - real, dimension(:), allocatable :: lat_ind - - integer, dimension(2) :: start, edge, stride, last, dimsizes - - logical :: file_exists, keep_data - - integer :: status, sd_id, sds_id, sds_index - - integer :: sfstart, sfn2index, sfselect, sfginfo - integer :: sfrdata, sfendacc, sfend - - character(64) :: sds_name - - integer :: rank, data_type, num_attrs - - integer(KIND=2), dimension(:,:), allocatable :: Snow_Cover - integer(KIND=2), dimension(:,:), allocatable :: Clear_Index - integer(KIND=2), dimension(:,:), allocatable :: Snow_Spatial_QA - - character(1), dimension(:,:), allocatable :: tmp_char1 - - character(len=*), parameter :: Iam = 'read_MODIS_SCF_hdf' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------------- - ! - ! make sure file exists - - inquire( file=trim(fname), exist=file_exists ) - - if (.not. file_exists ) then - - if (logit) then - write (logunit,'(400A)') trim(Iam), ': cannot find file ', trim(fname) - write (logunit,* ) 'not reading MODIS SCF obs' - end if - - N_good_data = 0 - - return - - end if - - ! ensure lon_* and lat_* inputs are within range - - if ( (lon_min < CMG_ll_lon) .or. & - (lon_max > CMG_ur_lon) .or. & - (lat_min < CMG_ll_lat) .or. & - (lat_max > CMG_ur_lat) ) then - - err_msg = 'lat/lon min/max inputs out of range' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! determine MODIS CMG array indices for requested lat/lon_min/max range - - ! MODIS CMG hdf files: - ! - lon-by-lat (NOTE: The metadata "s.Vgroup(1).Vgroup(1).SDS(1).Dims.Size" returned - ! by Matlab's hdfinfo() confusingly suggests that CMG files are - ! lat-by-lon, which is not the case!) - ! - index values increase eastward and southward - - start(1) = (lon_min - CMG_ll_lon)/CMG_dlon ! 0-based [as required for hdf read] - start(2) = (CMG_ur_lat - lat_max )/CMG_dlat ! 0-based [as required for hdf read] - - last(1) = (lon_max - CMG_ll_lon)/CMG_dlon ! 0-based [as required for hdf read] - last(2) = (CMG_ur_lat - lat_min )/CMG_dlat ! 0-based [as required for hdf read] - - N_lon = last(1) - start(1) + 1 - N_lat = last(2) - start(2) + 1 - - edge(1) = N_lon - edge(2) = N_lat - - stride(1) = 1 - stride(2) = 1 - - - - ! ! dbg ! ! write (*,*) '###############################################################################' - ! ! dbg ! ! write (*,*) Iam // '():' - ! ! dbg ! ! write (*,*) 'size(CMG_SCF), N_lon, N_lat = ', size(CMG_SCF), N_lon, N_lat - ! ! dbg ! ! write (*,*) 'lon_min, lon_max = ', lon_min, lon_max - ! ! dbg ! ! write (*,*) 'lat_min, lat_max = ', lat_min, lat_max - ! ! dbg ! ! write (*,*) 'start [lon, lat] = ', start - ! ! dbg ! ! write (*,*) 'last [lon, lat] = ', last - ! ! dbg ! ! write (*,*) 'edge [lon, lat] = ', edge - ! ! dbg ! ! write (*,*) '###############################################################################' - - - - ! checks array dimensions - - N_tmp = N_lon*N_lat - - if ( (N_tmp /= size(CMG_lon)) .or. & - (N_tmp /= size(CMG_lat)) .or. & - (N_tmp /= size(CMG_SCF)) ) then - - err_msg = 'inconsistent array dimensions' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! check array bounds - - if ( ( start(1) < 0 ) .or. ( start(1) > CMG_N_lon - 1 ) .or. & - ( start(2) < 0 ) .or. ( start(2) > CMG_N_lat - 1 ) .or. & - ( last( 1) < 0 ) .or. ( last( 1) > CMG_N_lon - 1 ) .or. & - ( last( 2) < 0 ) .or. ( last( 2) > CMG_N_lat - 1 ) .or. & - ( start(1) > last(1) ) .or. ( start(2) > last(2) ) & - ) then - - err_msg = 'start/edge indices out of bounds' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - if (logit) then - write (logunit,'(400A)') trim(Iam), '(): reading MODIS SCF obs from ', trim(fname) - write (logunit,* ) ' N_lon, N_lat, lon_min, lon_max, lat_min, lat_max = ' - write (logunit,* ) N_lon, N_lat, lon_min, lon_max, lat_min, lat_max - end if - - - ! allocate arrays - - allocate(lon_c( N_lon)) - allocate(lat_c( N_lat)) - - allocate(lon_ind(N_lon)) - allocate(lat_ind(N_lat)) - - allocate(Snow_Cover (N_lon,N_lat)) - allocate(Clear_Index (N_lon,N_lat)) - allocate(Snow_Spatial_QA(N_lon,N_lat)) - - allocate(tmp_char1( N_lon,N_lat)) - - ! -------------------------- - - ! determine center lat/lon of CMG cells - - lon_ind = (/(ii, ii=0, N_lon-1, 1)/) ! =0:(N_lon-1) - lat_ind = (/(jj, jj=0, N_lat-1, 1)/) ! =0:(N_lat-1) - - ! lat_c, lon_c are lat/lon at center of CMG grid cell - - lon_c = CMG_ll_lon + 0.5*CMG_dlon + (start(1)+lon_ind)*CMG_dlon - lat_c = CMG_ur_lat - 0.5*CMG_dlat - (start(2)+lat_ind)*CMG_dlat - - ! -------------------------- - - ! open hdf file (read-only) and initialize SD interface - - sd_id = sfstart(trim(fname), DFACC_READ) - - if (sd_id<0) then - - err_msg = 'cannot sfstart (open) file: ' // trim(fname) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! read data - - do nn=1,N_fields - - sds_index = sfn2index( sd_id, trim(field_names(nn)) ) - sds_id = sfselect( sd_id, sds_index ) - - - status = sfginfo( sds_id, sds_name, rank, dimsizes, data_type, num_attrs ) - - if ( (dimsizes(1)/=CMG_N_lon) .or. (dimsizes(2)/=CMG_N_lat) ) then - - err_msg = 'dimensions in hdf file doe not match CMG_N_lon and/or CMG_N_lat' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - ! ######################################################### - ! ! dbg ! ! write (*,*) 'sds_name = ', trim(sds_name) - ! ! dbg ! ! write (*,*) 'rank, data_type, num_attrs = ', rank, data_type, num_attrs - ! ! dbg ! ! write (*,*) 'dimsizes = ', dimsizes - ! ######################################################### - - - select case (nn) - - case (1); status = sfrdata( sds_id, start, stride, edge, tmp_char1 ); Snow_Cover = ichar(tmp_char1,2) - case (2); status = sfrdata( sds_id, start, stride, edge, tmp_char1 ); Clear_Index = ichar(tmp_char1,2) - case (3); status = sfrdata( sds_id, start, stride, edge, tmp_char1 ); Snow_Spatial_QA = ichar(tmp_char1,2) - - case default; call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown field') - - end select - - if (status/=0) then - - err_msg = 'error reading data from hdf file: ' // trim(fname) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - status = sfendacc(sds_id) ! terminate access to SDS (field) - - end do - - status = sfend(sd_id) ! close hdf file and SD interface - - - ! ################################################################################# - ! ! dbg ! ! write (*,*) 'Snow_Cover(1:10,1:5)=' - ! ! dbg ! ! write (*,*) Snow_Cover(1:10,1:5) - ! ! dbg ! ! write (*,*) 'Clear_Index(1:10,1:5)=' - ! ! dbg ! ! write (*,*) Clear_Index(1:10,1:5) - ! ! dbg ! ! write (*,*) 'Snow_Spatial_QA(1:10,1:5)=' - ! ! dbg ! ! write (*,*) Snow_Spatial_QA(1:10,1:5) - - ! ! dbg ! ! !if ( (lon_min>-138) .and. (lon_min<-134) ) then - ! ! dbg ! ! if (.false.) then - ! ! dbg ! ! do jj=1,N_lat - ! ! dbg ! ! write(997) Snow_Cover( jj,:) - ! ! dbg ! ! write(998) Clear_Index( jj,:) - ! ! dbg ! ! write(999) Snow_Spatial_QA(jj,:) - ! ! dbg ! ! end do - ! ! dbg ! ! write (*,*) 'stopping after file dump ' - ! ! dbg ! ! stop - ! ! dbg ! ! end if - ! ################################################################################# - - - - ! check range (make sure uint8 from hdf file is correctly translated into Fortran integer) - - if ( any(Snow_Cover < uint8_min) .or. & - any(Snow_Cover > uint8_max) .or. & - any(Clear_Index < uint8_min) .or. & - any(Clear_Index > uint8_max) .or. & - any(Snow_Spatial_QA < uint8_min) .or. & - any(Snow_Spatial_QA > uint8_max) ) then - - err_msg = 'unexpected range in data from hdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! ------------------------------------- - ! - ! apply QC and put SCF obs into output array - - CMG_lon = SCF_nodata ! initialize - CMG_lat = SCF_nodata ! initialize - CMG_SCF = SCF_nodata ! initialize - - kk = 0 ! initialize counter for "good" data - - do ii=1,N_lon - do jj=1,N_lat - - ! note: Snow_Cover >= 0 per range check above, no need to check for minimum - - keep_data = & - (Snow_Cover( ii,jj) <= qc_snow_cover_max ) .and. & ! 0<=SCF<=100 (1) - (Clear_Index( ii,jj) > qc_clear_index_min ) .and. & ! sufficiently clear sky (2) - (Snow_Spatial_QA(ii,jj) <= qc_snow_spatial_max) ! keep "best", "good", or "OK" quality (3) - - ! (1) excludes "lake ice", "night", "inland water", "ocean", "cloud obscured water", "data not mapped", "fill" - ! (2) clear_index>100 already removed via qc_snow_cover_max - ! (3) excludes Antarctica - - if (keep_data) then - - kk = kk + 1 - - ! raw SCF value is for clear portion of grid cell only, need to normalize with Clear_Index - - CMG_SCF(kk) = real(Snow_Cover(ii,jj))/real(Clear_Index(ii,jj)) - - CMG_lon(kk) = lon_c(ii) - CMG_lat(kk) = lat_c(jj) - - end if - - end do - end do - - N_good_data = kk - - if (logit) write (logunit,*) 'N_good_data = ', N_good_data - - deallocate(lat_c) - deallocate(lon_c) - - deallocate(lat_ind) - deallocate(lon_ind) - - deallocate(Snow_Cover ) - deallocate(Clear_Index ) - deallocate(Snow_Spatial_QA) - - end subroutine read_MODIS_SCF_hdf - - ! ***************************************************************** - - subroutine read_obs_SMAP_FT( date_time, N_catd, this_obs_param, & - dtstep_assim, tile_coord, tile_grid_d, & - N_tile_in_cell_ij, tile_num_in_cell_ij, write_obslog, & - found_obs, SMAP_data, std_SMAP_data, SMAP_lon, SMAP_lat, SMAP_time ) - - ! read freeze/thaw (FT) data within the assimilation window from one or more - ! SMAP L2_SM_AP half-orbit h5 files (or L3_FT_A files -- TO BE IMPLEMENTED) - ! - ! this subroutine reads each species independently of the others; - ! TO DO: what if more than one flavor of FT data is read from SMAP? - ! - ! reichle, 14 Nov 2014 - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd, dtstep_assim - - type(obs_param_type), intent(in) :: this_obs_param - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - logical, intent(in) :: write_obslog - - ! outputs: - - logical, intent(out) :: found_obs - - real, intent(out), dimension(N_catd) :: SMAP_data, std_SMAP_data - real, intent(out), dimension(N_catd) :: SMAP_lon, SMAP_lat - real*8, intent(out), dimension(N_catd) :: SMAP_time ! J2000 seconds - - ! -------------------------------------- - - ! local variables - - character(len=*), parameter :: Iam = 'read_obs_SMAP_FT' - - character(4), parameter :: J2000_epoch_id = 'TT12' ! see date_time_util.F90 - - ! SMAP data are stored in Yyyyy/Mmm/Ddd directories - ! - ! Within each directory, there must be an ASCII text file that lists the h5 file - ! names of all files in the directory that are suitable for assimilation. - ! These ASCII files must be named as follows: - - character(80), parameter :: fname_of_fname_list_L2_SM_AP_A = 'SMAP_L2_SM_AP_A_list.txt' - character(80), parameter :: fname_of_fname_list_L2_SM_AP_D = 'SMAP_L2_SM_AP_D_list.txt' - character(80), parameter :: fname_of_fname_list_L3_FT_A = 'SMAP_L3_FT_A_list.txt' - - logical, parameter :: tmp_debug = .false. - - real, parameter :: FT_min = 0. ! min allowed FT - real, parameter :: FT_max = 1. ! max allowed FT - - integer, parameter :: dt_halforbit = 50*60 ! seconds - - integer, parameter :: N_halforbits_max = 15 ! max number of half-orbits per day - - integer, parameter :: dtstep_assim_max = 10800 ! max allowed dtstep_assim [seconds] - - ! get max number of files to be read (use 2*dt_halforbit just to be safe) - - integer, parameter :: N_fnames_max = & - ceiling(real(N_halforbits_max)/86400.*real(dtstep_assim_max+2*dt_halforbit)) - - ! -------------------------------------------- - - type(hdf5read) :: h5r - - logical :: L2AP_files, keep_data, file_exists - - type(date_time_type) :: date_time_low, date_time_upp - type(date_time_type) :: date_time_low_fname, date_time_tmp - - integer :: ii, jj, kk, nn - integer :: N_fnames, N_fnames_tmp, N_obs_tmp - integer :: dset_rank - integer :: ind_tile, ind_start, ind_end - - real :: M09_col_ind_tile, M09_row_ind_tile - real :: M09_col_ind_obs, M09_row_ind_obs - real :: tmpreal - - real*8 :: J2000_seconds_low, J2000_seconds_upp - - character( 12) :: tmpstr12 - character( 15) :: SMAP_date_time - character( 16) :: YYYYMMDD_HHMMSSz - character( 80) :: fname_of_fname_list, tmpstr80 - character(300) :: fname_tmp, tmp_err_msg - - character(100) :: dset_name_lon, dset_name_lat - character(100) :: dset_name_time, dset_name_ft, dset_name_ft_qual_flag - - character(100), dimension(2*N_halforbits_max) :: fname_list ! max 2 days of files - - integer, dimension(7) :: dset_size - integer, dimension(N_fnames_max) :: N_obs_kept - integer, dimension(N_catd) :: N_obs_in_tile - - real, dimension(:), allocatable :: tmp_lon, tmp_lat - - real, dimension(:), allocatable :: tmp_ft - - real*8, dimension(:), allocatable :: tmp_time - - integer, dimension(:), allocatable :: tmp_ft_qual_flag - - integer, dimension(:), allocatable :: tmp_tile_num - - character(len=400) :: err_msg - - ! ------------------------------------------------------------------- - - ! check inputs - - ! the subroutine makes sense only if dtstep_assim <= 3 hours - ! - ! (this avoids that more than 2 different Yyyyy/Mmm/Ddd directories are needed - ! and that the time mismatch between the observed Tb and the model forecast Tb - ! becomes excessive; in future, add time interpolation of forecast Tb) - - if (dtstep_assim > dtstep_assim_max) then - err_msg = 'dtstep_assim must not exceed 3 hours' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! initialize - - found_obs = .false. - - ! read L2_SM_AP or L3_FT_A files? - - if (index(this_obs_param%descr,'L2AP') /= 0) then - - L2AP_files = .true. ! read SMAP L2_SM_AP files - - elseif (index(this_obs_param%descr,'L3FT') /= 0) then - - L2AP_files = .false. ! read SMAP L3_FT_A files - - else - - err_msg = 'cannot interpret %descr' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - ! determine the name of the file that contain the relevant list of file names - - if (L2AP_files .and. this_obs_param%orbit==1) then - - fname_of_fname_list = trim(fname_of_fname_list_L2_SM_AP_A) - - elseif (L2AP_files .and. this_obs_param%orbit==2) then - - fname_of_fname_list = trim(fname_of_fname_list_L2_SM_AP_D) - - else - - fname_of_fname_list = trim(fname_of_fname_list_L3_FT_A) - - end if - - ! --------------------------- - ! - ! define h5 data set names - - if (L2AP_files) then - - ! L2_SM_AP - - dset_name_lon = '/Soil_Moisture_Retrieval_Data/longitude' - dset_name_lat = '/Soil_Moisture_Retrieval_Data/latitude' - - dset_name_time = '/Soil_Moisture_Retrieval_Data/spacecraft_overpass_time_seconds' - - dset_name_ft = '/Soil_Moisture_Retrieval_Data/freeze_thaw_fraction' - - dset_name_ft_qual_flag = '/Soil_Moisture_Retrieval_Data/NOT_YET_IMPLEMENTED' - - else - - ! L3FT - - err_msg = 'L3FT NOT YET IMPLEMENTED' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! --------------------------- - ! - ! Define search interval for obs - ! - ! [ date_time - dtstep_assim/2 + one_second, date_time + dtstep_assim/2 ] - - ! lower boundary - - date_time_low = date_time - - call augment_date_time( -dtstep_assim/2+1, date_time_low ) - - J2000_seconds_low = datetime_to_J2000seconds( date_time_low, J2000_epoch_id ) - - ! upper boundary - - date_time_upp = date_time - - call augment_date_time( dtstep_assim/2, date_time_upp ) - - J2000_seconds_upp = datetime_to_J2000seconds( date_time_upp, J2000_epoch_id ) - - ! ----------------------------------------------------------------- - ! - ! identify names of files that could contain data within the - ! assimilation window [date_time_low,date_time_upp] - - date_time_low_fname = date_time_low - - call augment_date_time( -dt_halforbit, date_time_low_fname ) - - ! read file with list of SMAP file names for first day - - call read_obs_fnames( date_time_low_fname, this_obs_param, & - fname_of_fname_list, N_halforbits_max, & - N_fnames, fname_list(1:N_halforbits_max) ) - - ! if needed, read file with list of SMAP file names for second day and add - ! file names into "fname_list" - - if (date_time_low_fname%day /= date_time_upp%day) then - - call read_obs_fnames( date_time_upp, this_obs_param, & - fname_of_fname_list, N_halforbits_max, & - N_fnames_tmp, fname_list((N_fnames+1):(N_fnames+N_halforbits_max)) ) - - N_fnames = N_fnames + N_fnames_tmp - - end if - - ! ------------------------------------------------------------------ - - ! extract names of files that could contain data within the assimilation - ! window - ! - ! sample file names: - ! - ! Yyyyy/Mmm/Ddd/SMAP_L2_SM_AP_03073_D_20010730T193828_D04003_000.h5 - ! ||||||||||||||| - ! counter: 1 2 3 4 5 6 - ! 1234567890123456789012345678901234567890123456789012345678901234567890 - - if (L2AP_files) then - - ind_start = 37 - ind_end = 51 - - else - - ind_start = -9999999 ! TO DO: IMPLEMENT F3FT - ind_end = -9999999 - - end if - - kk = 0 - - do ii=1,N_fnames - - SMAP_date_time = fname_list(ii)(ind_start:ind_end) - - date_time_tmp = SMAPdatetime_to_DateTimeType( SMAP_date_time ) - - ! check whether: date_time_low_fname < date_time_tmp <= date_time_upp - - if ( datetime_lt_refdatetime( date_time_low_fname, date_time_tmp ) .and. & - datetime_le_refdatetime( date_time_tmp, date_time_upp ) ) then - - kk = kk+1 - - ! there can be no more than N_fnames_max files that have data falling into the - ! assimilation window (see also dtstep_assim_max) - - if (kk>N_fnames_max) then - err_msg = 'too many files match assimilation window' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - fname_list(kk) = fname_list(ii) - - end if - - end do ! ii=1,N_fnames - - N_fnames = kk - - ! the "N_fnames" files of interest are now the first "N_fnames" entries - ! in "fname_list" - - ! --------------------------------------------------------- - ! - ! read and process data if files were found - - if (N_fnames==0) then - - ! no data files found - - SMAP_data = this_obs_param%nodata - SMAP_lon = this_obs_param%nodata - SMAP_lat = this_obs_param%nodata - SMAP_time = real(this_obs_param%nodata,kind(0.0D0)) - std_SMAP_data = this_obs_param%nodata - - else - - ! initialize outputs - - SMAP_data = 0. - SMAP_lon = 0. - SMAP_lat = 0. - SMAP_time = 0.0D0 - - N_obs_in_tile = 0 ! for normalization after mapping to tile and super-obs - - ! loop through files - - do kk=1,N_fnames - - ! open file - - fname_tmp = trim(this_obs_param%path) // '/' // fname_list(kk) - - if (logit) write(logunit,'(400A)') 'reading file: ' // trim(fname_tmp) - - inquire(file=fname_tmp, exist=file_exists) - - if (.not. file_exists) then - - err_msg = 'file does NOT exist' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - call h5r%openFile(fname_tmp) - - ! ------------------------------ - - ! read h5 datasets - - tmp_err_msg = trim(Iam) // ': inconsistent dataset lengths' - - ! LONGITUDE: query dataset, record size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_lon) - - call h5r%queryDataset(dset_name_lon, dset_rank, dset_size) - - N_obs_tmp = dset_size(1) - - allocate(tmp_lon(N_obs_tmp)) - - call h5r%readDataset(tmp_lon) - - ! LATITUDE: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_lat) - - call h5r%queryDataset(dset_name_lat, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_lat(N_obs_tmp)) - - call h5r%readDataset(tmp_lat) - - ! TIME: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_time) - - call h5r%queryDataset(dset_name_time, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_time(N_obs_tmp)) - - call h5r%readDataset(tmp_time) - - ! FT: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_ft) - - call h5r%queryDataset(dset_name_ft, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_ft(N_obs_tmp)) - - call h5r%readDataset(tmp_ft) - - !! FT_QUAL_FLAG: query dataset, check size, allocate space, read data - ! - !if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_ft_qual_flag) - ! - !call h5r%queryDataset(dset_name_ft_qual_flag, dset_rank, dset_size) - ! - !if (N_obs_tmp/=dset_size(1)) then - ! call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - !end if - ! - !allocate(tmp_ft_qual_flag(N_obs_tmp)) - ! - !call h5r%readDataset(tmp_ft_qual_flag) - - - ! close file - - call h5r%closeFile - - if (logit) write(logunit,*) 'done reading file' - - ! -------------------------------------------------------- - ! - ! eliminate obs outside desired time window, no-data-values and data - ! that fail initial QC - ! keep track of how many obs survived from current file - - ! ##################################### - ! TO DO: - ! - use quality flag once available - ! ##################################### - - jj = 0 - - if (L2AP_files) then - - do nn=1,N_obs_tmp - - !(mod(tmp_tb_qual_flag_1(nn),2)==0) .and. & ! lowest bit must be 0 - - keep_data = & - (tmp_time(nn) > J2000_seconds_low) .and. & - (tmp_time(nn) <= J2000_seconds_upp) .and. & - (tmp_ft(nn) > FT_min) .and. & ! elim neg nodata - (tmp_ft(nn) < FT_max) ! elim unphysically large value - - if (keep_data) then - - jj=jj+1 - - tmp_lon( jj) = tmp_lon( nn) - tmp_lat( jj) = tmp_lat( nn) - tmp_ft( jj) = tmp_ft( nn) - tmp_time(jj) = tmp_time(nn) - - end if - - end do - - else - - ! L3FT - - err_msg = 'L3FT NOT YET IMPLEMENTED' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if ! (L2AP_files) - - N_obs_kept(kk) = jj - - ! ------------------------------------------------- - ! - ! map obs to tiles - ! - ! for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_obs_kept(kk)>0) then - - allocate(tmp_tile_num(N_obs_kept(kk))) - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_obs_kept(kk), & - tmp_lat(1:N_obs_kept(kk)), & - tmp_lon(1:N_obs_kept(kk)), & - this_obs_param, & - tmp_tile_num ) - - ! make sure center-of-mass of tile that administers obs - ! is within EASEv2 M09 obs grid cell, discard obs otherwise - ! (by setting tmp_tile_num to negative value) - ! - ! this step eliminates SMAP obs that fall outside of the GEOS-5 - ! land mask at M09 resolution - ! - ! not sure what this does if model is run on tile space other than - ! EASEv2_M09 - reichle, 11 Nov 2014 - ! - ! It is not 100 percent clear why this piece code had been added - ! at the time. - ! Chances are that it had to do with land-water mask issues and the - ! distortion of EASE grid cells at high latitudes, and/or Gabrielle's - ! use of an M36 innovations integration to derive Tb scaling files - ! for the M09 (SMAP) system. - ! The problem with the piece of code is that it throws out far too many - ! obs (at all latitudes) if the tile space is coarse, e.g., that of the - ! 1/2 deg Lat/Lon grids of MERRA or MERRA-2. - ! The piece of code may no longer be needed because of improvements in - ! the obs readers and in get_obs_pred(), but the impact of removing the - ! code on the SMAP L4_SM system is not clear. At this time, just prior - ! to finalizing the L4_SM "validated release", keep the code for the - ! EASEv2 M09 and M36 tile spaces that are relevant for the L4_SM - ! system, but drop it for all other tile spaces. - ! - reichle, 3 Feb 2016 - - if ( & - (index(tile_grid_d%gridtype, 'EASEv2_M09') /=0) .or. & - (index(tile_grid_d%gridtype, 'EASEv2_M36') /=0) ) then - - do ii=1,N_obs_kept(kk) - - if (tmp_tile_num(ii)>0) then - - call ease_convert('EASEv2_M09', & - tile_coord(tmp_tile_num(ii))%com_lat, & - tile_coord(tmp_tile_num(ii))%com_lon, & - M09_col_ind_tile, M09_row_ind_tile ) - - call ease_convert('EASEv2_M09', & - tmp_lat(ii), & - tmp_lon(ii), & - M09_col_ind_obs, M09_row_ind_obs ) - - if ( (nint(M09_col_ind_tile)/=nint(M09_col_ind_obs)) .or. & - (nint(M09_row_ind_tile)/=nint(M09_row_ind_obs)) ) & - tmp_tile_num(ii) = -9999 - - end if - - end do - - end if - - ! compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - do ii=1,N_obs_kept(kk) - - ind_tile = tmp_tile_num(ii) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind_tile>0) then ! this step eliminates obs outside domain - - SMAP_data(ind_tile) = SMAP_data(ind_tile) + tmp_ft( ii) - SMAP_lon( ind_tile) = SMAP_lon( ind_tile) + tmp_lon( ii) - SMAP_lat( ind_tile) = SMAP_lat( ind_tile) + tmp_lat( ii) - SMAP_time(ind_tile) = SMAP_time(ind_tile) + tmp_time(ii) - - N_obs_in_tile(ind_tile) = N_obs_in_tile(ind_tile) + 1 - - end if - - end do - - deallocate(tmp_tile_num) - - end if - - ! clean up - - if (allocated(tmp_lon )) deallocate(tmp_lon ) - if (allocated(tmp_lat )) deallocate(tmp_lat ) - if (allocated(tmp_time )) deallocate(tmp_time ) - if (allocated(tmp_ft )) deallocate(tmp_ft ) - if (allocated(tmp_ft_qual_flag)) deallocate(tmp_ft_qual_flag) - - end do ! kk=1,N_fnames - - ! normalize - - do ii=1,N_catd - - if (N_obs_in_tile(ii)>1) then - - tmpreal = real(N_obs_in_tile(ii)) - - SMAP_data(ii) = SMAP_data(ii)/ tmpreal - SMAP_lon( ii) = SMAP_lon( ii)/ tmpreal - SMAP_lat( ii) = SMAP_lat( ii)/ tmpreal - SMAP_time(ii) = SMAP_time(ii)/real(tmpreal,kind(0.0D0)) - - elseif (N_obs_in_tile(ii)==0) then - - SMAP_data(ii) = this_obs_param%nodata - SMAP_lon( ii) = this_obs_param%nodata - SMAP_lat( ii) = this_obs_param%nodata - SMAP_time(ii) = real(this_obs_param%nodata,kind(0.0D0)) - - end if - - end do - - ! -------------------------------- - - ! set observation error standard deviation - - do ii=1,N_catd - std_SMAP_data(ii) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if ! N_fnames==0 - - ! ------------------------------------------------- - ! - ! write "obslog" file - - if (write_obslog) then - - YYYYMMDD_HHMMSSz = date_time2string(date_time) - - tmpstr80 = 'read_obs_SMAP_FT()' ! name of this subroutine - - do kk=1,N_fnames - - fname_tmp = trim(this_obs_param%path) // fname_list(kk) - - write (tmpstr12,'(i12)') N_obs_kept(kk) ! convert integer to string - - call add_to_obslog( YYYYMMDD_HHMMSSz, this_obs_param%descr, tmpstr80, & - tmpstr12, fname_tmp ) - - end do - - end if - - ! clean up - - if (logit) write (logunit,*) 'read_obs_SMAP_FT(): done.' - - end subroutine read_obs_SMAP_FT - - ! ***************************************************************** - - ! ***************************************************************** - - subroutine read_obs_SMAP_halforbit_Tb( date_time, N_catd, this_obs_param, & - dtstep_assim, tile_coord, tile_grid_d, & - N_tile_in_cell_ij, tile_num_in_cell_ij, write_obslog, & - found_obs, SMAP_data, std_SMAP_data, SMAP_lon, SMAP_lat, SMAP_time ) - - ! read brightness temperature data within the assimilation window from one or more - ! SMAP half-orbit h5 files (L1C, L1CE (Enhanced), or L2AP) - ! - ! this subroutine reads each species independently of the others; - ! see subroutine turn_off_assim_SMAP_L1CTb() for avoiding the assimilation - ! of redundant L1C_Tb observations when corresponding L2AP_Tb obs are assimilated - ! - ! this subroutine is *not* meant to work for SMAP L3 files, but it could - ! perhaps be extended to read soil moisture data from half-orbit h5 files - ! - ! reichle, 17 Jan 2014 - ! reichle, 31 Jan 2014: added output of "SMAP_time" - ! reichle, 31 May 2016: added stats check for L1C fore-minus-aft Tb differences - ! reichle, 26 Dec 2017: added functionality for L1CE (Enhanced) files, incl. thinning - ! reichle, 23 Jan 2018: removed stats check for L1C fore-minus-aft Tb differences; - ! use avg fore/aft timestamp so that fore and aft Tbs for same - ! location are never used in different assimilation windows - ! reichle, 22 Apr 2020: resurrected check for L1C fore-minus-aft Tb differences - ! after antenna-scan-angle (ASA) issues continued and the - ! SMAP Project declined to address these issues in L1 ops - - implicit none - - ! inputs: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catd, dtstep_assim - - type(obs_param_type), intent(in) :: this_obs_param - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - logical, intent(in) :: write_obslog - - ! outputs: - - logical, intent(out) :: found_obs - - real, intent(out), dimension(N_catd) :: SMAP_data, std_SMAP_data - real, intent(out), dimension(N_catd) :: SMAP_lon, SMAP_lat - real*8, intent(out), dimension(N_catd) :: SMAP_time ! J2000 seconds - - ! -------------------------------------- - - ! local variables - - character(4), parameter :: J2000_epoch_id = 'TT12' ! see date_time_util.F90 - - ! SMAP data are stored in Yyyyy/Mmm/Ddd directories - ! - ! Within each directory, there must be an ASCII text file that lists the h5 file - ! names of all files in the directory that are suitable for assimilation. - ! These ASCII files must be named as follows: - - character(80), parameter :: fname_of_fname_list_L1C_TB_A = 'SMAP_L1C_TB_A_list.txt' - character(80), parameter :: fname_of_fname_list_L1C_TB_D = 'SMAP_L1C_TB_D_list.txt' - - character(80), parameter :: fname_of_fname_list_L1C_TB_E_A = 'SMAP_L1C_TB_E_A_list.txt' - character(80), parameter :: fname_of_fname_list_L1C_TB_E_D = 'SMAP_L1C_TB_E_D_list.txt' - - character(80), parameter :: fname_of_fname_list_L2_SM_AP_A = 'SMAP_L2_SM_AP_A_list.txt' - character(80), parameter :: fname_of_fname_list_L2_SM_AP_D = 'SMAP_L2_SM_AP_D_list.txt' - - logical, parameter :: tmp_debug = .false. - - real, parameter :: Tb_min = 100.0 ! min allowed Tb - real, parameter :: Tb_max = 320.0 ! max allowed Tb - - real, parameter :: max_std_tb_fore_minus_aft = 20. ! max std-dev L1C[E] fore-minus-aft Tb diffs - - integer, parameter :: L1CE_spacing = 3 ! thinning of L1C_TB_E in units of 9-km indices ("3" => 27 km) - - ! temporarily shift lat/lon of obs for computation of nearest tile to - ! avoid ambiguous assignment of M09 model tile within M36 obs grid cell - ! (center of M36 grid cell is equidistant from at least two M09 model - ! tiles) -- reichle, 23 Aug 2013 - - real, parameter :: tmp_shift_lon = 0.01 - real, parameter :: tmp_shift_lat = 0.005 - - integer, parameter :: dt_halforbit = 50*60 ! seconds - - integer, parameter :: N_halforbits_max = 15 ! max number of half-orbits per day - - integer, parameter :: dtstep_assim_max = 10800 ! max allowed dtstep_assim [seconds] - - ! get max number of files to be read (use 2*dt_halforbit just to be safe) - - integer, parameter :: N_fnames_max = & - ceiling(real(N_halforbits_max)/86400.*real(dtstep_assim_max+2*dt_halforbit)) - - ! -------------------------------------------- - - type(hdf5read) :: h5r - - logical :: L1C_files, L1CE_files, hpol - logical :: L1CE_thinning, keep_data_1, keep_data_2, tmp_keep, file_exists - - type(date_time_type) :: date_time_low, date_time_upp - type(date_time_type) :: date_time_low_fname, date_time_tmp - - integer :: ii, jj, kk, nn, mm - integer :: N_fnames, N_fnames_tmp, N_obs_tmp - integer :: dset_rank - integer :: ind_tile, ind_start, ind_end - - real :: M36_col_ind_tile, M36_row_ind_tile - real :: M36_col_ind_obs, M36_row_ind_obs - real :: tmpreal - real :: tmp_tb_diff, tmp_tb_diff_Sum, tmp_tb_diff_SumOfSq, tmp_var - - real*8 :: J2000_seconds_low, J2000_seconds_upp - - character( 2) :: orbit_tag - character( 12) :: tmpstr12 - character( 15) :: SMAP_date_time - character( 16) :: YYYYMMDD_HHMMSSz - character( 80) :: fname_of_fname_list, tmpstr80 - character(300) :: fname_tmp, tmp_err_msg - - character(100) :: dset_name_lon, dset_name_lat - character(100) :: dset_name_col, dset_name_row - character(100) :: dset_name_time_1, dset_name_tb_1, dset_name_tb_qual_flag_1 - character(100) :: dset_name_time_2, dset_name_tb_2, dset_name_tb_qual_flag_2 - - character(100), dimension(2*N_halforbits_max) :: fname_list ! max 2 days of files - - integer, dimension(7) :: dset_size - integer, dimension(N_fnames_max) :: N_obs_kept - integer, dimension(N_catd) :: N_obs_in_tile - - real, dimension(:), allocatable :: tmp_lon, tmp_lat - - integer, dimension(:), allocatable :: tmp_col, tmp_row - - real, dimension(:), allocatable :: tmp_tb_1 - real, dimension(:), allocatable :: tmp_tb_2 - - real*8, dimension(:), allocatable :: tmp_time_1 - real*8, dimension(:), allocatable :: tmp_time_2 - - integer, dimension(:), allocatable :: tmp_tb_qual_flag_1 - integer, dimension(:), allocatable :: tmp_tb_qual_flag_2 - - integer, dimension(:), allocatable :: tmp_tile_num - - character(len=*), parameter :: Iam = 'read_obs_SMAP_halforbit_Tb' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------- - - ! check inputs - - ! the subroutine makes sense only if dtstep_assim <= 3 hours - ! - ! (this avoids that more than 2 different Yyyyy/Mmm/Ddd directories are needed - ! and that the time mismatch between the observed Tb and the model forecast Tb - ! becomes excessive; in future, add time interpolation of forecast Tb) - - if (dtstep_assim > dtstep_assim_max) then - err_msg = 'dtstep_assim must not exceed 3 hours' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! initialize - - found_obs = .false. - - ! read Tbs from L1C_TB, L1C_TB_E, or L2_SM_AP files? - - L1CE_thinning = .false. ! initialize - - if (index(this_obs_param%descr,'L1C') /= 0) then - - if (index(this_obs_param%descr,'_E') /= 0) then - - L1CE_files = .true. ! read SMAP L1C_TB_E (Enhanced) files - L1C_files = .false. - - if (index(this_obs_param%descr,'_E27') /= 0) L1CE_thinning = .true. - - else - - L1C_files = .true. ! read SMAP L1C_TB (standard) files - L1CE_files = .false. - - end if - - elseif (index(this_obs_param%descr,'L2AP') /= 0) then - - L1C_files = .false. ! read SMAP L2_SM_AP files - L1CE_files = .false. - - else - - err_msg = 'cannot interpret %descr' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - ! read ascending or descending files? - - tmp_err_msg = 'inconsistent %descr and %orbit' - - if (index(this_obs_param%descr,'_A') /=0 ) then - - orbit_tag = '_A' - - if (this_obs_param%orbit/=1) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - elseif (index(this_obs_param%descr,'_D') /=0 ) then - - orbit_tag = '_D' - - if (this_obs_param%orbit/=2) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - else - - err_msg = 'unknown %descr or %orbit' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! determine the name of the file that contains the relevant list of file names - - if (this_obs_param%orbit==1) then ! ascending - - if (L1C_files) then - - fname_of_fname_list = trim(fname_of_fname_list_L1C_TB_A) - - elseif (L1CE_files) then - - fname_of_fname_list = trim(fname_of_fname_list_L1C_TB_E_A) - - else - - fname_of_fname_list = trim(fname_of_fname_list_L2_SM_AP_A) - - end if - - elseif (this_obs_param%orbit==2) then ! descending - - if (L1C_files) then - - fname_of_fname_list = trim(fname_of_fname_list_L1C_TB_D) - - elseif (L1CE_files) then - - fname_of_fname_list = trim(fname_of_fname_list_L1C_TB_E_D) - - else - - fname_of_fname_list = trim(fname_of_fname_list_L2_SM_AP_D) - - end if - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown obs type') - - end if - - ! need h-pol or v-pol? - - if (this_obs_param%pol==1) then - - hpol = .true. - - elseif (this_obs_param%pol==2) then - - hpol = .false. - - else - - err_msg = 'Problem with polarization' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - ! --------------------------- - ! - ! define h5 data set names - - if (L1C_files .or. L1CE_files) then - - ! L1C_TB or L1_C_TB_E - - dset_name_lon = '/Global_Projection/cell_lon' - dset_name_lat = '/Global_Projection/cell_lat' - - dset_name_col = '/Global_Projection/cell_column' - dset_name_row = '/Global_Projection/cell_row' - - dset_name_time_1 = '/Global_Projection/cell_tb_time_seconds_fore' - dset_name_time_2 = '/Global_Projection/cell_tb_time_seconds_aft' - - if (hpol) then - - dset_name_tb_1 = '/Global_Projection/cell_tb_h_fore' - dset_name_tb_2 = '/Global_Projection/cell_tb_h_aft' - - dset_name_tb_qual_flag_1 = '/Global_Projection/cell_tb_qual_flag_h_fore' - dset_name_tb_qual_flag_2 = '/Global_Projection/cell_tb_qual_flag_h_aft' - - else - - dset_name_tb_1 = '/Global_Projection/cell_tb_v_fore' - dset_name_tb_2 = '/Global_Projection/cell_tb_v_aft' - - dset_name_tb_qual_flag_1 = '/Global_Projection/cell_tb_qual_flag_v_fore' - dset_name_tb_qual_flag_2 = '/Global_Projection/cell_tb_qual_flag_v_aft' - - end if - - else - - ! L2_SM_AP - - dset_name_lon = '/Soil_Moisture_Retrieval_Data/longitude' - dset_name_lat = '/Soil_Moisture_Retrieval_Data/latitude' - - dset_name_time_1 = '/Soil_Moisture_Retrieval_Data/spacecraft_overpass_time_seconds' - dset_name_time_2 = '' ! *not* used - - if (hpol) then - - dset_name_tb_1 = '/Soil_Moisture_Retrieval_Data/tb_h_disaggregated' - dset_name_tb_2 = '' ! *not* used - - dset_name_tb_qual_flag_1 = '/Soil_Moisture_Retrieval_Data/tb_h_disaggregated_qual_flag' - dset_name_tb_qual_flag_2 = '' ! *not* used - - else - - dset_name_tb_1 = '/Soil_Moisture_Retrieval_Data/tb_v_disaggregated' - dset_name_tb_2 = '' ! *not* used - - dset_name_tb_qual_flag_1 = '/Soil_Moisture_Retrieval_Data/tb_v_disaggregated_qual_flag' - dset_name_tb_qual_flag_2 = '' ! *not* used - - end if - - end if - - ! --------------------------- - ! - ! Define search interval for obs - ! - ! [ date_time - dtstep_assim/2 + one_second, date_time + dtstep_assim/2 ] - - ! lower boundary - - date_time_low = date_time - - call augment_date_time( -dtstep_assim/2+1, date_time_low ) - - J2000_seconds_low = datetime_to_J2000seconds( date_time_low, J2000_epoch_id ) - - ! upper boundary - - date_time_upp = date_time - - call augment_date_time( dtstep_assim/2, date_time_upp ) - - J2000_seconds_upp = datetime_to_J2000seconds( date_time_upp, J2000_epoch_id ) - - ! ----------------------------------------------------------------- - ! - ! identify names of files that could contain data within the - ! assimilation window [date_time_low,date_time_upp] - - date_time_low_fname = date_time_low - - call augment_date_time( -dt_halforbit, date_time_low_fname ) - - ! read file with list of SMAP file names for first day - - call read_obs_fnames( date_time_low_fname, this_obs_param, & - fname_of_fname_list, N_halforbits_max, & - N_fnames, fname_list(1:N_halforbits_max) ) - - ! if needed, read file with list of SMAP file names for second day and add - ! file names into "fname_list" - - if (date_time_low_fname%day /= date_time_upp%day) then - - call read_obs_fnames( date_time_upp, this_obs_param, & - fname_of_fname_list, N_halforbits_max, & - N_fnames_tmp, fname_list((N_fnames+1):(N_fnames+N_halforbits_max)) ) - - N_fnames = N_fnames + N_fnames_tmp - - end if - - ! ------------------------------------------------------------------ - - ! extract names of files that could contain data within the assimilation - ! window - ! - ! sample file names: - ! ||||||||||||||| - ! Yyyyy/Mmm/Ddd/SMAP_L1C_TB_03027_D_20010727T160914_D04003_000.h5 - ! - ! ||||||||||||||| - ! Yyyyy/Mmm/Ddd/SMAP_L1C_TB_E_03027_D_20010727T160914_D04003_000.h5 - ! Yyyyy/Mmm/Ddd/SMAP_L2_SM_AP_03073_D_20010730T193828_D04003_000.h5 - ! ||||||||||||||| - ! counter: 1 2 3 4 5 6 - ! 1234567890123456789012345678901234567890123456789012345678901234567890 - - if (L1C_files) then - - ind_start = 35 - ind_end = 49 - - else ! L1CE or L2AP files - - ind_start = 37 - ind_end = 51 - - end if - - kk = 0 - - do ii=1,N_fnames - - SMAP_date_time = fname_list(ii)(ind_start:ind_end) - - date_time_tmp = SMAPdatetime_to_DateTimeType( SMAP_date_time ) - - ! check whether: date_time_low_fname < date_time_tmp <= date_time_upp - - if ( datetime_lt_refdatetime( date_time_low_fname, date_time_tmp ) .and. & - datetime_le_refdatetime( date_time_tmp, date_time_upp ) ) then - - kk = kk+1 - - ! there can be no more than N_fnames_max files that have data falling into the - ! assimilation window (see also dtstep_assim_max) - - if (kk>N_fnames_max) then - err_msg = 'too many files match assimilation window' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - fname_list(kk) = fname_list(ii) - - end if - - end do ! ii=1,N_fnames - - N_fnames = kk - - ! the "N_fnames" files of interest are now the first "N_fnames" entries - ! in "fname_list" - - ! --------------------------------------------------------- - ! - ! read and process data if files were found - - if (N_fnames==0) then - - ! no data files found - - SMAP_data = this_obs_param%nodata - SMAP_lon = this_obs_param%nodata - SMAP_lat = this_obs_param%nodata - SMAP_time = real(this_obs_param%nodata,kind(0.0D0)) - std_SMAP_data = this_obs_param%nodata - - else - - ! initialize outputs - - SMAP_data = 0. - SMAP_lon = 0. - SMAP_lat = 0. - SMAP_time = 0.0D0 - - N_obs_in_tile = 0 ! for normalization after mapping to tile and super-obs - - ! loop through files - - do kk=1,N_fnames - - ! open file - - fname_tmp = trim(this_obs_param%path) // '/' // fname_list(kk) - - if (logit) write(logunit,'(400A)') 'reading file: ' // trim(fname_tmp) - - inquire(file=fname_tmp, exist=file_exists) - - if (.not. file_exists) then - - err_msg = 'file does NOT exist' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - call h5r%openFile(fname_tmp) - - ! ------------------------------ - - ! read h5 datasets - - tmp_err_msg = 'read_obs_SMAP_halforbit_Tb(): inconsistent dataset lengths' - - ! LONGITUDE: query dataset, record size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_lon) - - call h5r%queryDataset(dset_name_lon, dset_rank, dset_size) - - N_obs_tmp = dset_size(1) - - allocate(tmp_lon(N_obs_tmp)) - - call h5r%readDataset(tmp_lon) - - ! LATITUDE: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_lat) - - call h5r%queryDataset(dset_name_lat, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_lat(N_obs_tmp)) - - call h5r%readDataset(tmp_lat) - - if (L1CE_thinning) then ! need to read column and row indices - - ! COLUMN: query dataset, record size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_col) - - call h5r%queryDataset(dset_name_col, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_col(N_obs_tmp)) - - call h5r%readDataset(tmp_col) - - ! ROW: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_row) - - call h5r%queryDataset(dset_name_row, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_row(N_obs_tmp)) - - call h5r%readDataset(tmp_row) - - end if - - ! TIME_1: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_time_1) - - call h5r%queryDataset(dset_name_time_1, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_time_1(N_obs_tmp)) - - call h5r%readDataset(tmp_time_1) - - ! TB_1: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_tb_1) - - call h5r%queryDataset(dset_name_tb_1, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_tb_1(N_obs_tmp)) - - call h5r%readDataset(tmp_tb_1) - - ! TB_QUAL_FLAG_1: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_tb_qual_flag_1) - - call h5r%queryDataset(dset_name_tb_qual_flag_1, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_tb_qual_flag_1(N_obs_tmp)) - - call h5r%readDataset(tmp_tb_qual_flag_1) - - ! for L1C_TB or L1C_TB_E files also read "aft" - - if (L1C_files .or. L1CE_files) then - - ! *_1 = "fore" - ! *_2 = "aft" - - ! TIME_2: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_time_2) - - call h5r%queryDataset(dset_name_time_2, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_time_2(N_obs_tmp)) - - call h5r%readDataset(tmp_time_2) - - ! TB_2: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_tb_2) - - call h5r%queryDataset(dset_name_tb_2, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_tb_2(N_obs_tmp)) - - call h5r%readDataset(tmp_tb_2) - - ! TB_QUAL_FLAG_2: query dataset, check size, allocate space, read data - - if (tmp_debug .and. logit) write(logunit,*) trim(dset_name_tb_qual_flag_2) - - call h5r%queryDataset(dset_name_tb_qual_flag_2, dset_rank, dset_size) - - if (N_obs_tmp/=dset_size(1)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, tmp_err_msg) - end if - - allocate(tmp_tb_qual_flag_2(N_obs_tmp)) - - call h5r%readDataset(tmp_tb_qual_flag_2) - - end if - - ! close file - - call h5r%closeFile - - if (logit) write(logunit,*) 'done reading file' - - ! -------------------------------------------------------- - ! - ! eliminate obs outside desired time window, no-data-values and data - ! that fail initial QC - ! keep track of how many obs survived from current file - - ! ##################################### - ! TO DO: - ! - refine use of quality flag? - ! - how to QC for proximity to water body? - ! - anything else missing that is done for SMOS - ! (either in preproc or in obs reader)?? - ! ##################################### - - jj = 0 - - if (L1C_files .or. L1CE_files) then - - ! initialize stats check for fore-minus-aft Tb diffs - - mm = 0 - - tmp_tb_diff_Sum = 0. - tmp_tb_diff_SumOfSq = 0. - - do nn=1,N_obs_tmp - - ! QC - - keep_data_1 = & - (mod(tmp_tb_qual_flag_1(nn),2)==0) .and. & ! lowest bit must be 0 - (tmp_tb_1(nn) > Tb_min) .and. & ! elim neg nodata - (tmp_tb_1(nn) < Tb_max) ! elim huge pos nodata - - keep_data_2 = & - (mod(tmp_tb_qual_flag_2(nn),2)==0) .and. & ! lowest bit must be 0 - (tmp_tb_2(nn) > Tb_min) .and. & ! elim neg nodata - (tmp_tb_2(nn) < Tb_max) ! elim huge pos nodata - - ! thinning of L1C_TB_E obs - - if (L1CE_thinning) then - - tmp_keep = & - ( mod(tmp_col(nn),L1CE_spacing) == 1 ) .and. & - ( mod(tmp_row(nn),L1CE_spacing) == 1 ) - - keep_data_1 = keep_data_1 .and. tmp_keep - keep_data_2 = keep_data_2 .and. tmp_keep - - end if - - ! compute fore and aft average, put into "tb_1", "tmp_time_1" - - if (keep_data_1 .and. keep_data_2) then - - ! Compute stats for fore-minus-aft Tb differences. - ! Excessive diffs are found in bad L1C_TB files, which occur - ! occasionally due to bad ANT_AZ files in L1B processing. - ! Includes ALL SURFACES!!! - ! - reichle, 22 Apr 2020 (resurrected) - ! - reichle, 16 Oct 2020 (bug fix: do stats first, then avg) - - mm=mm+1 - - tmp_tb_diff = tmp_tb_1(nn) - tmp_tb_2(nn) - - tmp_tb_diff_Sum = tmp_tb_diff_Sum + tmp_tb_diff - tmp_tb_diff_SumOfSq = tmp_tb_diff_SumOfSq + tmp_tb_diff**2 - - ! put average of "fore" and "aft" into "tb_1", "tmp_time_1" - - tmp_tb_1( nn) = 0.5 *( tmp_tb_1( nn) + tmp_tb_2( nn) ) - tmp_time_1(nn) = 0.5D0*( tmp_time_1(nn) + tmp_time_2(nn) ) - - elseif (keep_data_2) then - - ! put "aft" data into "tb_1", "tmp_time_1" - - tmp_tb_1( nn) = tmp_tb_2( nn) - tmp_time_1(nn) = tmp_time_2(nn) - - else - - ! nothing to do here - ! - if only keep_data_1 is true (tmp_tb_1 and tmp_time_1 are already as needed) - ! - if both keep_data_1 and keep_data_2 are false (next if block ignores data) - - end if - - ! apply QC and thinning, ensure that time stamp is within assimilation window - - if ( (keep_data_1 .or. keep_data_2) .and. & - (tmp_time_1(nn) > J2000_seconds_low) .and. & - (tmp_time_1(nn) <= J2000_seconds_upp) & - ) then - - jj=jj+1 - - tmp_lon( jj) = tmp_lon(nn) - tmp_lat( jj) = tmp_lat(nn) - tmp_tb_1( jj) = tmp_tb_1( nn) - tmp_time_1(jj) = tmp_time_1(nn) - - end if - - end do - - ! finalize stats check for fore-minus-aft differences (ALL SURFACES!!!) - ! - reichle, 22 Apr 2020 (resurrected) - - if (mm>1) then - - tmp_var = ( tmp_tb_diff_SumOfSq - (tmp_tb_diff_Sum**2)/real(mm) )/(real(mm-1)) - - if ( tmp_var > max_std_tb_fore_minus_aft**2 ) then - - write(err_msg, '(e12.5)') sqrt(tmp_var) - - err_msg = & - 'Ignoring ALL obs in halforbit file b/c of excessive std-dev in fore-minus-aft Tbs. ' // & - 'std-dev( tb_fore - tb_aft ) = ' // trim(err_msg) - - call ldas_warn(LDAS_GENERIC_WARNING, Iam, err_msg) - - jj = 0 ! results in N_obs_kept=0 below - - end if - - end if - - else ! L2_SM_AP - - do nn=1,N_obs_tmp - - keep_data_1 = & - (mod(tmp_tb_qual_flag_1(nn),2)==0) .and. & ! lowest bit must be 0 - (tmp_time_1(nn) > J2000_seconds_low) .and. & - (tmp_time_1(nn) <= J2000_seconds_upp) .and. & - (tmp_tb_1(nn) > Tb_min) .and. & ! elim neg nodata - (tmp_tb_1(nn) < Tb_max) ! elim huge pos nodata - - if (keep_data_1) then - - jj=jj+1 - - tmp_lon( jj) = tmp_lon( nn) - tmp_lat( jj) = tmp_lat( nn) - tmp_tb_1( jj) = tmp_tb_1( nn) - tmp_time_1(jj) = tmp_time_1(nn) - - end if - - end do - - end if ! (L1C_files .or. L1CE_files) - - N_obs_kept(kk) = jj - - ! ------------------------------------------------- - ! - ! map obs to tiles - ! - ! for each observation - ! a) determine grid cell that contains lat/lon - ! b) determine tile within grid cell that contains lat/lon - - if (N_obs_kept(kk)>0) then - - allocate(tmp_tile_num(N_obs_kept(kk))) - - ! shift M36 obs lat/lon for proper assignment of M09 tile? - - if ( L1C_files .and. (index(tile_grid_d%gridtype, 'EASEv2_M09') /=0 .or. index(tile_grid_d%gridtype, 'EASEv2-M09') /=0 )) then - - ! temporarily shift lat/lon of obs for computation of nearest tile to - ! avoid ambiguous assignment of M09 model tile within M36 obs grid cell - ! (center of M36 grid cell is equidistant from at least two M09 model - ! tiles) -- reichle, 23 Aug 2013 - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_obs_kept(kk), & - tmp_lat(1:N_obs_kept(kk)), & - tmp_lon(1:N_obs_kept(kk)), & - this_obs_param, & - tmp_tile_num, & - tmp_shift_lat, tmp_shift_lon ) - - else - - call get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_obs_kept(kk), & - tmp_lat(1:N_obs_kept(kk)), & - tmp_lon(1:N_obs_kept(kk)), & - this_obs_param, & - tmp_tile_num) - - end if - - ! make sure center-of-mass of tile that administers obs - ! is within EASEv2 M36 obs grid cell, discard obs otherwise - ! (by setting tmp_tile_num to negative value) - ! - ! this step eliminates SMAP obs that fall outside of the GEOS-5 - ! land mask at M09 resolution - ! - ! not sure what this does if model is run on tile space other than - ! EASEv2_M09 - reichle, 11 Nov 2014 - ! - ! Bug fix - index used within loop should be "ii" (not "kk"). - ! For global runs the bug should have had only minimal impact. - ! - reichle, 23 Apr 2015 - ! - ! It is not 100 percent clear why this piece code had been added - ! at the time. - ! Chances are that it had to do with land-water mask issues and the - ! distortion of EASE grid cells at high latitudes, and/or Gabrielle's - ! use of an M36 innovations integration to derive Tb scaling files - ! for the M09 (SMAP) system. - ! The problem with the piece of code is that it throws out far too many - ! obs (at all latitudes) if the tile space is coarse, e.g., that of the - ! 1/2 deg Lat/Lon grids of MERRA or MERRA-2. - ! The piece of code may no longer be needed because of improvements in - ! the obs readers and in get_obs_pred(), but the impact of removing the - ! code on the SMAP L4_SM system is not clear. At this time, just prior - ! to finalizing the L4_SM "validated release", keep the code for the - ! EASEv2 M09 and M36 tile spaces that are relevant for the L4_SM - ! system, but drop it for all other tile spaces. - ! - reichle, 3 Feb 2016 - - if ( & - (index(tile_grid_d%gridtype, 'EASEv2_M09') /=0) .or. & - (index(tile_grid_d%gridtype, 'EASEv2_M36') /=0) ) then - - do ii=1,N_obs_kept(kk) - - if (tmp_tile_num(ii)>0) then - - call ease_convert('EASEv2_M36', & - tile_coord(tmp_tile_num(ii))%com_lat, & - tile_coord(tmp_tile_num(ii))%com_lon, & - M36_col_ind_tile, M36_row_ind_tile ) - - call ease_convert('EASEv2_M36', & - tmp_lat(ii), & - tmp_lon(ii), & - M36_col_ind_obs, M36_row_ind_obs ) - - if ( (nint(M36_col_ind_tile)/=nint(M36_col_ind_obs)) .or. & - (nint(M36_row_ind_tile)/=nint(M36_row_ind_obs)) ) & - tmp_tile_num(ii) = -9999 - - end if - - end do - - end if - - ! compute super-obs for each tile from all obs w/in that tile - ! (also eliminate observations that are not in domain) - - do ii=1,N_obs_kept(kk) - - ind_tile = tmp_tile_num(ii) ! 1<=tmp_tile_num<=N_catd (unless nodata) - - if (ind_tile>0) then ! this step eliminates obs outside domain - - SMAP_data(ind_tile) = SMAP_data(ind_tile) + tmp_tb_1( ii) - SMAP_lon( ind_tile) = SMAP_lon( ind_tile) + tmp_lon( ii) - SMAP_lat( ind_tile) = SMAP_lat( ind_tile) + tmp_lat( ii) - SMAP_time(ind_tile) = SMAP_time(ind_tile) + tmp_time_1(ii) - - N_obs_in_tile(ind_tile) = N_obs_in_tile(ind_tile) + 1 - - end if - - end do - - deallocate(tmp_tile_num) - - end if - - ! clean up - - if (allocated(tmp_lon )) deallocate(tmp_lon ) - if (allocated(tmp_lat )) deallocate(tmp_lat ) - if (allocated(tmp_col )) deallocate(tmp_col ) - if (allocated(tmp_row )) deallocate(tmp_row ) - if (allocated(tmp_time_1 )) deallocate(tmp_time_1 ) - if (allocated(tmp_time_2 )) deallocate(tmp_time_2 ) - if (allocated(tmp_tb_1 )) deallocate(tmp_tb_1 ) - if (allocated(tmp_tb_2 )) deallocate(tmp_tb_2 ) - if (allocated(tmp_tb_qual_flag_1)) deallocate(tmp_tb_qual_flag_1) - if (allocated(tmp_tb_qual_flag_2)) deallocate(tmp_tb_qual_flag_2) - - end do ! kk=1,N_fnames - - ! normalize - - do ii=1,N_catd - - if (N_obs_in_tile(ii)>1) then - - tmpreal = real(N_obs_in_tile(ii)) - - SMAP_data(ii) = SMAP_data(ii)/ tmpreal - SMAP_lon( ii) = SMAP_lon( ii)/ tmpreal - SMAP_lat( ii) = SMAP_lat( ii)/ tmpreal - SMAP_time(ii) = SMAP_time(ii)/real(tmpreal,kind(0.0D0)) - - elseif (N_obs_in_tile(ii)==0) then - - SMAP_data(ii) = this_obs_param%nodata - SMAP_lon( ii) = this_obs_param%nodata - SMAP_lat( ii) = this_obs_param%nodata - SMAP_time(ii) = real(this_obs_param%nodata,kind(0.0D0)) - - end if - - end do - - ! -------------------------------- - - ! set observation error standard deviation - - do ii=1,N_catd - std_SMAP_data(ii) = this_obs_param%errstd - end do - - ! -------------------------------- - - if (any(N_obs_in_tile>0)) then - - found_obs = .true. - - else - - found_obs = .false. - - end if - - end if ! N_fnames==0 - - ! ------------------------------------------------- - ! - ! write "obslog" file - - if (write_obslog) then - - YYYYMMDD_HHMMSSz = date_time2string(date_time) - - tmpstr80 = 'read_obs_SMAP_halforbit_Tb()' ! name of this subroutine - - do kk=1,N_fnames - - fname_tmp = trim(this_obs_param%path) // fname_list(kk) - - write (tmpstr12,'(i12)') N_obs_kept(kk) ! convert integer to string - - call add_to_obslog( YYYYMMDD_HHMMSSz, this_obs_param%descr, tmpstr80, & - tmpstr12, fname_tmp ) - - end do - - end if - - ! clean up - - if (logit) write (logunit,*) 'read_obs_SMAP_halforbit_Tb(): done.' - - end subroutine read_obs_SMAP_halforbit_Tb - - ! ***************************************************************** - - subroutine turn_off_assim_SMAP_L1CTb(N_obs_param, obs_param, N_obsl, Observations_l) - - ! this subroutine turns off the assimilation of *individual* L1C_Tb obs - ! if corresponding L2AP_Tb obs are assimilated - - ! rationale: SMAP L1C_Tb obs are used to derive the disaggregated L2AP_Tb obs - ! and should not be assimilated along with L2AP_Tb - - ! L1C_Tb obs are on the EASEv2 36 km grid ("M36") - ! L2AP_Tb obs are on the EASEv2 9 km grid ("M09") - - ! reichle, 17 Jan 2014 - ! reichle, 5 May 2015 - added *ascending* L2AP - - implicit none - - integer, intent(in) :: N_obs_param, N_obsl - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(obs_type), dimension(N_obsl), intent(inout) :: Observations_l - - ! local variables - - logical :: turnoff_L1C_Tbh_A, turnoff_L1C_Tbv_A - logical :: turnoff_L1C_Tbh_D, turnoff_L1C_Tbv_D - - integer :: n, ii, j, N_obsf, N_cols, N_rows - - integer :: species_L1C_Tbh_A, species_L2AP_Tbh_A - integer :: species_L1C_Tbh_D, species_L2AP_Tbh_D - integer :: species_L1C_Tbv_A, species_L2AP_Tbv_A - integer :: species_L1C_Tbv_D, species_L2AP_Tbv_D - - integer :: ind_L1C_Tbh_A, ind_L2AP_Tbh_A - integer :: ind_L1C_Tbh_D, ind_L2AP_Tbh_D - integer :: ind_L1C_Tbv_A, ind_L2AP_Tbv_A - integer :: ind_L1C_Tbv_D, ind_L2AP_Tbv_D - - real :: col, row - - integer, dimension(numprocs) :: N_obsl_vec, tmp_low_ind - - type(obs_type), dimension(:), allocatable :: Observations_f - - logical, dimension(:,:), allocatable :: mask_h_A, mask_v_A - logical, dimension(:,:), allocatable :: mask_h_D, mask_v_D - - character(len=*), parameter :: Iam = 'turn_off_assim_SMAP_L1CTb' - - ! ------------------------------------------------------------------------------ - - ! determine species and index numbers of conflicting obs species - - species_L1C_Tbh_A = -9999 - species_L1C_Tbh_D = -9999 - species_L1C_Tbv_A = -9999 - species_L1C_Tbv_D = -9999 - species_L2AP_Tbh_A = -9999 - species_L2AP_Tbh_D = -9999 - species_L2AP_Tbv_A = -9999 - species_L2AP_Tbv_D = -9999 - - ind_L1C_Tbh_A = -9999 - ind_L1C_Tbh_D = -9999 - ind_L1C_Tbv_A = -9999 - ind_L1C_Tbv_D = -9999 - ind_L2AP_Tbh_A = -9999 - ind_L2AP_Tbh_D = -9999 - ind_L2AP_Tbv_A = -9999 - ind_L2AP_Tbv_D = -9999 - - do j=1,N_obs_param - - ! reichle, 1 Feb 2018: Only worry about assimilated species. - ! NOTE: At most one of L1C_Tb, L1C_Tb E09, or L1C_Tb E27 can be - ! assimilated at a time, checked in read_ens_upd_inputs(). - - if (obs_param(j)%assim) then - - select case (trim(obs_param(j)%descr)) - - case('SMAP_L1C_Tbh_A','SMAP_L1C_Tbh_E09_A','SMAP_L1C_Tbh_E27_A'); species_L1C_Tbh_A =obs_param(j)%species; ind_L1C_Tbh_A =j - case('SMAP_L1C_Tbh_D','SMAP_L1C_Tbh_E09_D','SMAP_L1C_Tbh_E27_D'); species_L1C_Tbh_D =obs_param(j)%species; ind_L1C_Tbh_D =j - case('SMAP_L1C_Tbv_A','SMAP_L1C_Tbv_E09_A','SMAP_L1C_Tbv_E27_A'); species_L1C_Tbv_A =obs_param(j)%species; ind_L1C_Tbv_A =j - case('SMAP_L1C_Tbv_D','SMAP_L1C_Tbv_E09_D','SMAP_L1C_Tbv_E27_D'); species_L1C_Tbv_D =obs_param(j)%species; ind_L1C_Tbv_D =j - case('SMAP_L2AP_Tbh_A'); species_L2AP_Tbh_A=obs_param(j)%species; ind_L2AP_Tbh_A=j - case('SMAP_L2AP_Tbh_D'); species_L2AP_Tbh_D=obs_param(j)%species; ind_L2AP_Tbh_D=j - case('SMAP_L2AP_Tbv_A'); species_L2AP_Tbv_A=obs_param(j)%species; ind_L2AP_Tbv_A=j - case('SMAP_L2AP_Tbv_D'); species_L2AP_Tbv_D=obs_param(j)%species; ind_L2AP_Tbv_D=j - - end select - - end if - - end do - - ! determine whether there is possibly a redundancy - - turnoff_L1C_Tbh_A = .false. - turnoff_L1C_Tbh_D = .false. - turnoff_L1C_Tbv_A = .false. - turnoff_L1C_Tbv_D = .false. - - if (ind_L1C_Tbh_A>0 .and. ind_L2AP_Tbh_A>0) turnoff_L1C_Tbh_A = .true. - if (ind_L1C_Tbh_D>0 .and. ind_L2AP_Tbh_D>0) turnoff_L1C_Tbh_D = .true. - if (ind_L1C_Tbv_A>0 .and. ind_L2AP_Tbv_A>0) turnoff_L1C_Tbv_A = .true. - if (ind_L1C_Tbv_D>0 .and. ind_L2AP_Tbv_D>0) turnoff_L1C_Tbv_D = .true. - - ! ----------------------------------------------------------------------- - - ! proceed only if there is work to be done - - if ( turnoff_L1C_Tbh_A .or. turnoff_L1C_Tbv_A .or. & - turnoff_L1C_Tbh_D .or. turnoff_L1C_Tbv_D ) then - - ! gather local obs - -#ifdef LDAS_MPI - - call MPI_Gather( & - N_obsl, 1, MPI_integer, & - N_obsl_vec, 1, MPI_integer, & - 0, mpicomm, mpierr ) - -#else - - N_obsl_vec(1) = N_obsl - -#endif - - if (root_proc) then - - N_obsf = sum(N_obsl_vec) - - allocate(Observations_f(N_obsf)) - - tmp_low_ind(1) = 1 - - do n=1,numprocs-1 - - tmp_low_ind(n+1) = tmp_low_ind(n) + N_obsl_vec(n) - - end do - - end if - -#ifdef LDAS_MPI - - call MPI_GATHERV( & - Observations_l, N_obsl, MPI_obs_type, & - Observations_f, N_obsl_vec, tmp_low_ind-1, MPI_obs_type, & - 0, mpicomm, mpierr ) - -#else - - Observations_f = Observations_l - -#endif - - ! --------------------------------------------------------- - ! - ! assemble 36 km EASEv2 mask of L2AP_Tb obs - - call ease_extent( 'EASEv2_M36', N_cols, N_rows ) - - allocate( mask_h_A(N_cols,N_rows) ) - allocate( mask_h_D(N_cols,N_rows) ) - allocate( mask_v_A(N_cols,N_rows) ) - allocate( mask_v_D(N_cols,N_rows) ) - - mask_h_A = .false. ! initialize - mask_h_D = .false. ! initialize - mask_v_A = .false. ! initialize - mask_v_D = .false. ! initialize - - if (root_proc) then - - ! mask for H-pol ascending - - if (turnoff_L1C_Tbh_A) then - - do ii=1,N_obsf - - if (Observations_f(ii)%species==species_L2AP_Tbh_A) then - - call ease_convert('EASEv2_M36', Observations_f(ii)%lat, Observations_f(ii)%lon, & - col, row) - - ! set mask=.true. for the M36 grid cell that contains the L2AP_Tb obs; - ! note conversion to one-based indices - - mask_h_A(nint(col)+1,nint(row)+1) = .true. - - end if - - end do - - end if - - ! mask for H-pol descending - - if (turnoff_L1C_Tbh_D) then - - do ii=1,N_obsf - - if (Observations_f(ii)%species==species_L2AP_Tbh_D) then - - call ease_convert('EASEv2_M36', Observations_f(ii)%lat, Observations_f(ii)%lon, & - col, row) - - ! set mask=.true. for the M36 grid cell that contains the L2AP_Tb obs; - ! note conversion to one-based indices - - mask_h_D(nint(col)+1,nint(row)+1) = .true. - - end if - - end do - - end if - - ! mask for V-pol ascending - - if (turnoff_L1C_Tbv_A) then - - do ii=1,N_obsf - - if (Observations_f(ii)%species==species_L2AP_Tbv_A) then - - call ease_convert('EASEv2_M36', Observations_f(ii)%lat, Observations_f(ii)%lon, & - col, row) - - ! set mask=.true. for the M36 grid cell that contains the L2AP_Tb obs; - ! note conversion to one-based indices - - mask_v_A(nint(col)+1,nint(row)+1) = .true. - - end if - - end do - - end if - - ! mask for V-pol descending - - if (turnoff_L1C_Tbv_D) then - - do ii=1,N_obsf - - if (Observations_f(ii)%species==species_L2AP_Tbv_D) then - - call ease_convert('EASEv2_M36', Observations_f(ii)%lat, Observations_f(ii)%lon, & - col, row) - - ! set mask=.true. for the M36 grid cell that contains the L2AP_Tb obs; - ! note conversion to one-based indices - - mask_v_D(nint(col)+1,nint(row)+1) = .true. - - end if - - end do - - end if - - deallocate(Observations_f) - - end if ! (root_proc) - - ! MPI broadcast masks - - call MPI_Bcast(mask_h_A, N_cols*N_rows, MPI_LOGICAL, 0, mpicomm, mpierr) - call MPI_Bcast(mask_h_D, N_cols*N_rows, MPI_LOGICAL, 0, mpicomm, mpierr) - call MPI_Bcast(mask_v_A, N_cols*N_rows, MPI_LOGICAL, 0, mpicomm, mpierr) - call MPI_Bcast(mask_v_D, N_cols*N_rows, MPI_LOGICAL, 0, mpicomm, mpierr) - - ! --------------------------------------------------------- - ! - ! apply H-pol masks - - if (turnoff_L1C_Tbh_A) then - - do ii=1,N_obsl - - if (Observations_l(ii)%species==species_L1C_Tbh_A) then - - call ease_convert('EASEv2_M36', & - Observations_l(ii)%lat, Observations_l(ii)%lon, col, row) - - ! note conversion to one-based indices - - if (mask_h_A(nint(col)+1,nint(row)+1)) Observations_l(ii)%assim = .false. - - end if - - end do - - end if - - if (turnoff_L1C_Tbh_D) then - - do ii=1,N_obsl - - if (Observations_l(ii)%species==species_L1C_Tbh_D) then - - call ease_convert('EASEv2_M36', & - Observations_l(ii)%lat, Observations_l(ii)%lon, col, row) - - ! note conversion to one-based indices - - if (mask_h_D(nint(col)+1,nint(row)+1)) Observations_l(ii)%assim = .false. - - end if - - end do - - end if - - ! apply V-pol masks - - if (turnoff_L1C_Tbv_A) then - - do ii=1,N_obsl - - if (Observations_l(ii)%species==species_L1C_Tbv_A) then - - call ease_convert('EASEv2_M36', & - Observations_l(ii)%lat, Observations_l(ii)%lon, col, row) - - ! note conversion to one-based indices - - if (mask_v_A(nint(col)+1,nint(row)+1)) Observations_l(ii)%assim = .false. - - end if - - end do - - end if - - if (turnoff_L1C_Tbv_D) then - - do ii=1,N_obsl - - if (Observations_l(ii)%species==species_L1C_Tbv_D) then - - call ease_convert('EASEv2_M36', & - Observations_l(ii)%lat, Observations_l(ii)%lon, col, row) - - ! note conversion to one-based indices - - if (mask_v_D(nint(col)+1,nint(row)+1)) Observations_l(ii)%assim = .false. - - end if - - end do - - end if - - ! clean up - - deallocate( mask_h_A ) - deallocate( mask_h_D ) - deallocate( mask_v_A ) - deallocate( mask_v_D ) - - end if ! (turnoff_L1C_Tbh_A .or. turnoff_L1C_Tbv_A .or. turnoff_L1C_Tbh_D .or. turnoff_L1C_Tbv_D) - - end subroutine turn_off_assim_SMAP_L1CTb - - ! ***************************************************************** - - subroutine read_obs_fnames( date_time, this_obs_param, & - fname_of_fname_list, N_max, N_fnames, fname_list, & - obs_dir_hier ) - - ! read the file within an obs Yyyyy/Mmm/Ddd directory that lists - ! the obs file names, preface file names with "Yyyyy/Mmm/Ddd", - ! and return in "fname_list" - ! - ! optional input argument: - ! obs_dir_hier==1 : preface file names with "Yyyyy/Mmm" instead - ! - ! this subroutine is needed when obs file names cannot be predicted - ! and must be provided in a short text file that lists the file names - ! (e.g., SMAP Tb or soil moisture h5 files, ASCAT soil moisture BUFR files) - ! - ! reichle, 3 Jan 2014 - ! reichle, 8 Jun 2017: Use "%flistpath" and "%flistname" from "obs_param_type". - ! A M Fox, reichle, 22 Sep 2023: added optional argument obs_dir_hier - ! - ! --------------------------------------------------------------------------------- - - implicit none - - type(date_time_type), intent(in) :: date_time - - type(obs_param_type), intent(in) :: this_obs_param - - character( *), intent(in) :: fname_of_fname_list - - integer, intent(in) :: N_max - - integer, intent(out) :: N_fnames - - character(100), dimension(N_max), intent(out) :: fname_list - - integer, optional, intent(in) :: obs_dir_hier - - ! local variables - - character(300) :: fname - character(200) :: fpath_tmp - character( 80) :: fname_tmp - character( 80) :: tmpstr80 - - character( 14) :: YYYYMMDDdir - character( 10) :: YYYYMMdir - character( 4) :: YYYY - character( 2) :: MM, DD - - integer :: ii, istat - - character(len=*), parameter :: Iam = 'read_obs_fnames' - character(len=400) :: err_msg - - ! --------------------------------------------------------------------- - - write (YYYY,'(i4.4)') date_time%year - write (MM ,'(i2.2)') date_time%month - write (DD ,'(i2.2)') date_time%day - - YYYYMMDDdir = 'Y' // YYYY // '/M' // MM // '/D' // DD // '/' - YYYYMMdir = 'Y' // YYYY // '/M' // MM // '/' - - ! initialize default values - - fpath_tmp = this_obs_param%path - fname_tmp = fname_of_fname_list - - ! use inputs from ensupd nml file if not empty - - if (len_trim(this_obs_param%flistpath)>0) fpath_tmp = this_obs_param%flistpath - if (len_trim(this_obs_param%flistname)>0) fname_tmp = this_obs_param%flistname - - fname = trim(fpath_tmp) // '/' // YYYYMMDDdir // trim(fname_tmp) - - open( 10, file=fname, form='formatted', action='read', iostat=istat) - - if (istat/=0) then - err_msg = 'cannot open file ' // trim(fname) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (logit) write(logunit,'(400A)') 'reading file ' // trim(fname) - - ! read list of file names - - istat = 0 - ii = 0 - - do while (istat==0) - - read(10,*,iostat=istat) tmpstr80 - - if (istat==0) then - - ii = ii+1 - - if (ii>N_max) then - err_msg = 'too many files in list' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! preface file names with "Yyyyy/Mmm/Ddd" (default) - - fname_list(ii) = YYYYMMDDdir // trim(tmpstr80) - - if (present(obs_dir_hier)) then - - if (obs_dir_hier == 1) then - - ! preface file names with "Yyyyy/Mmm" - - fname_list(ii) = YYYYMMdir // trim(tmpstr80) - - else - - err_msg = 'Unrecognized value of optional argument obs_dir_hier' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - end if - - else - - exit - - end if - - end do - - close(10, status='keep') - - N_fnames = ii - - end subroutine read_obs_fnames - - ! ***************************************************************** - - type(date_time_type) function SMAPdatetime_to_DateTimeType( SMAP_date_time ) - - ! convert SMAP date/time strings to LDASsa date_time_type - - ! reichle, 6 Jan 2014 - - implicit none - - ! input arguments - - character(len=*) :: SMAP_date_time - - ! local variables - - type(date_time_type) :: date_time - - character(4) :: YYYY - character(2) :: MM, DD, HH, MI, SS - - integer :: YYYY_is, YYYY_ie - integer :: MM_is, MM_ie - integer :: DD_is, DD_ie - integer :: HH_is, HH_ie - integer :: MI_is, MI_ie - integer :: SS_is, SS_ie - - character(len=*), parameter :: Iam = 'SMAPdatetime_to_DateTimeType' - character(len=400) :: err_msg - - ! --------------------------------------------------- - - if ( (len_trim(SMAP_date_time)==15) .and. & - (SMAP_date_time( 9: 9)=='T') ) then - - ! format: "20010727T160914" (yyyymmddThhmmss) - - YYYY_is = 1; YYYY_ie = 4; - MM_is = 5; MM_ie = 6; - DD_is = 7; DD_ie = 8; - HH_is = 10; HH_ie = 11; - MI_is = 12; MI_ie = 13; - SS_is = 14; SS_ie = 15; - - else if ( & - (len_trim(SMAP_date_time)==24) .and. & - (SMAP_date_time( 5: 5)=='-') .and. & - (SMAP_date_time( 8: 8)=='-') .and. & - (SMAP_date_time(11:11)=='T') .and. & - (SMAP_date_time(14:14)==':') .and. & - (SMAP_date_time(17:17)==':') .and. & - (SMAP_date_time(20:20)=='.') .and. & - (SMAP_date_time(24:24)=='Z') ) then - - ! format: "2001-07-27T16:09:14.567Z" - - YYYY_is = 1; YYYY_ie = 4; - MM_is = 6; MM_ie = 7; - DD_is = 9; DD_ie = 10; - HH_is = 12; HH_ie = 13; - MI_is = 15; MI_ie = 16; - SS_is = 18; SS_ie = 19; - - else - - err_msg = 'invalid SMAPdatetime string' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - YYYY = SMAP_date_time(YYYY_is:YYYY_ie) - MM = SMAP_date_time(MM_is :MM_ie ) - DD = SMAP_date_time(DD_is :DD_ie ) - HH = SMAP_date_time(HH_is :HH_ie ) - MI = SMAP_date_time(MI_is :MI_ie ) - SS = SMAP_date_time(SS_is :SS_ie ) - - read (YYYY,*) date_time%year - read (MM ,*) date_time%month - read (DD ,*) date_time%day - read (HH ,*) date_time%hour - read (MI ,*) date_time%min - read (SS ,*) date_time%sec - - call get_dofyr_pentad( date_time ) - - SMAPdatetime_to_DateTimeType = date_time - - end function SMAPdatetime_to_DateTimeType - - ! ***************************************************************** - - subroutine read_obs( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, write_obslog, & - found_obs, scaled_obs, & - tmp_obs, tmp_std_obs, tmp_lon, tmp_lat, tmp_time, tmp_assim ) - - ! read observations and optionally scale observations to model clim - ! - ! intended to be called by root_proc - - ! 10 Jun 2011 - removed model-based QC for MPI re-structuring (now done - ! in connection with get_obs_pred()) - ! 22 Nov 2011 - minor clean-up, renamed scale_obs_*() subroutines - ! 23 Aug 2013 - added possibility of using lat/lon of obs from reader - ! (rather than using lat/lon from model tile_coord) - ! 31 Jan 2014 - added output of time stamp ("tmp_time") - ! 14 Jul 2014 - added summary diagnostic "scaled_obs" - ! (indicates whether any of the founds obs were scaled) - ! 6 Jun 2016 - added functionality to keep obs that cannot be scaled - ! (but will not be assimilated; SMAP/SMOS Tb only for now) - - implicit none - - ! inputs: - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim, N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid_d - - integer, dimension(tile_grid_d%N_lon,tile_grid_d%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - type(obs_param_type), intent(in) :: this_obs_param - - logical, intent(in) :: write_obslog - - ! outputs: - - real, intent(out), dimension(N_catd) :: tmp_obs - real, intent(out), dimension(N_catd) :: tmp_std_obs - real, intent(out), dimension(N_catd) :: tmp_lon - real, intent(out), dimension(N_catd) :: tmp_lat - real*8, intent(out), dimension(N_catd) :: tmp_time - logical, intent(out), dimension(N_catd) :: tmp_assim - - logical, intent(out) :: found_obs, scaled_obs - - ! obs time stamp in LDASsa *must* be in J2000 seconds with 'TT12' epoch - ! (see enkf_types.F90) - - character(4), parameter :: J2000_epoch_id = 'TT12' ! see date_time_util.F90 - - character(len=*), parameter :: Iam = 'read_obs' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - scaled_obs = .false. ! initialize - - tmp_assim = .true. ! initialize - - ! initialize lat/lon/time info (may later be overwritten by individual reader) - - tmp_lon = tile_coord%com_lon - tmp_lat = tile_coord%com_lat - - ! obs time stamp in LDASsa *must* be in J2000 seconds with 'TT12' epoch - ! (see enkf_types.F90) - ! if needed, must be converted by obs reader (e.g., ASCAT/EUMETSAT) - - tmp_time = datetime_to_J2000seconds(date_time, J2000_epoch_id ) - - ! ----------------------------- - - ! choose appropriate reader - - select case (trim(this_obs_param%descr)) - - case ('ae_l2_sm_a', 'ae_l2_sm_d') - - call read_obs_ae_l2_sm( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - - case ('ae_sm_LPRM_a_C', 'ae_sm_LPRM_d_C', 'ae_sm_LPRM_a_X', 'ae_sm_LPRM_d_X' ) - - call read_obs_ae_sm_LPRM( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - - case ('ASCAT_SM_A', 'ASCAT_SM_D' ) - - call read_obs_sm_ASCAT( & - work_path, exp_id, & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - case ('ASCAT_META_SM','ASCAT_METB_SM','ASCAT_METC_SM' ) - - call read_obs_sm_ASCAT_EUMET( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs, tmp_lon, tmp_lat, & - tmp_time) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_zscore( N_catd, tile_coord, & - date_time, this_obs_param, tmp_lon, tmp_lat, tmp_time, & - tmp_obs, tmp_std_obs ) - - end if - - case ('isccp_tskin_gswp2_v1') - - call read_obs_isccp_tskin_gswp2_v1( & - date_time, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_tskin_zscore( N_catd, tile_coord, & - date_time, this_obs_param, tmp_obs, tmp_std_obs ) - - end if - - case ('isccp_tskin_ceop3n4') - - call read_obs_isccp_tskin_ceop3n4( & - date_time, N_catd, tile_coord, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_tskin_zscore( N_catd, tile_coord, & - date_time, this_obs_param, tmp_obs, tmp_std_obs ) - - end if - - case ('isccp_tskin_ceop3n4_hdASC') - - call read_obs_isccp_ts_ceop3n4_hdASC( & - date_time, N_catd, tile_coord, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_tskin_zscore( N_catd, tile_coord, & - date_time, this_obs_param, tmp_obs, tmp_std_obs ) - - end if - - case ('RedArkOSSE_sm') - - call read_obs_RedArkOSSE_sm( & - date_time, N_catd, tile_coord, this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology (use AMSR-E subroutine) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - case ('RedArkOSSE_CLSMsynthSM') - - call read_obs_RedArkOSSE_CLSMsynthSM( & - date_time, N_catd, this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology (use AMSR-E subroutine) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - case ('RedArkOSSE_truth_50mm','RedArkOSSE_truth_400mm') - - call read_obs_RedArkOSSE_truth( & - date_time, N_catd, this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology (use AMSR-E subroutine) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - ! assimilation NOT implemented for RedArkOSSE_truth obs - - if (this_obs_param%assim) then - err_msg = 'assimilation NOT implemented for RedArkOSSE_truth obs' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - - case ('VivianaOK_CLSMsynthSM') - - call read_obs_VivianaOK_CLSMsynthSM( & - date_time, N_catd, this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! scale observations to model climatology (use AMSR-E subroutine) - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - case('SMOS_SM_A','SMOS_SM_D') - - call read_obs_SMOS( & - date_time, N_catd, this_obs_param, & - dtstep_assim, tile_coord, tile_grid_d, & - N_tile_in_cell_ij, tile_num_in_cell_ij, write_obslog, & - found_obs, tmp_obs, tmp_std_obs, tmp_lon, tmp_lat ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - end if - - case('SMOS_reg_Tbh_A','SMOS_reg_Tbh_D','SMOS_reg_Tbv_A','SMOS_reg_Tbv_D', & - 'SMOS_fit_Tbh_A','SMOS_fit_Tbh_D','SMOS_fit_Tbv_A','SMOS_fit_Tbv_D') - - call read_obs_SMOS( & - date_time, N_catd, this_obs_param, & - dtstep_assim, tile_coord, tile_grid_d, & - N_tile_in_cell_ij, tile_num_in_cell_ij, write_obslog, & - found_obs, tmp_obs, tmp_std_obs, tmp_lon, tmp_lat ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_Tb_zscore( N_catd, tile_coord, date_time, & - this_obs_param, tmp_obs, tmp_std_obs, tmp_assim ) - - end if - - case ('MOD10C1','MYD10C1') - - call read_obs_MODIS_SCF( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs, tmp_lon, tmp_lat ) - - case('SMAP_L1C_Tbh_A', 'SMAP_L1C_Tbv_A', & - 'SMAP_L1C_Tbh_D', 'SMAP_L1C_Tbv_D', & - 'SMAP_L1C_Tbh_E09_A', 'SMAP_L1C_Tbv_E09_A', & - 'SMAP_L1C_Tbh_E09_D', 'SMAP_L1C_Tbv_E09_D', & - 'SMAP_L1C_Tbh_E27_A', 'SMAP_L1C_Tbv_E27_A', & - 'SMAP_L1C_Tbh_E27_D', 'SMAP_L1C_Tbv_E27_D', & - 'SMAP_L2AP_Tbh_A', 'SMAP_L2AP_Tbv_A', & - 'SMAP_L2AP_Tbh_D', 'SMAP_L2AP_Tbv_D' ) - - call read_obs_SMAP_halforbit_Tb( & - date_time, N_catd, this_obs_param, & - dtstep_assim, tile_coord, tile_grid_d, & - N_tile_in_cell_ij, tile_num_in_cell_ij, write_obslog, & - found_obs, tmp_obs, tmp_std_obs, tmp_lon, tmp_lat, tmp_time ) - - ! scale observations to model climatology - - if (this_obs_param%scale .and. found_obs) then - - scaled_obs = .true. - - call scale_obs_Tb_zscore( N_catd, tile_coord, date_time, & - this_obs_param, tmp_obs, tmp_std_obs, tmp_assim ) - - end if - - case('LaRC_tskin-GOESW', 'LaRC_tskin-GOESE', 'LaRC_tskin-MET09', & - 'LaRC_tskin-FY2E-', 'LaRC_tskin-MTST2') - - call read_obs_LaRC_Tskin( & - date_time, dtstep_assim, N_catd, tile_coord, & - tile_grid_d, N_tile_in_cell_ij, tile_num_in_cell_ij, & - this_obs_param, & - found_obs, tmp_obs, tmp_std_obs ) - - ! NOT IMPLEMENTED: scale observations to model climatology - - case default - - err_msg = 'unknown obs_param%descr' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - - end subroutine read_obs - - - ! ***************************************************************** - - subroutine scale_obs_sfmc_cdf( N_catd, tile_coord, this_obs_param, & - tmp_obs, tmp_std_obs ) - - ! scale sfmc obs to model climatology via cdf matching - ! - ! use matlab functions "get_cdf_match_AMSR.m" and "get_model_and_obs_stats.m" - ! to create input scaling files - ! - ! IMPORTANT: Make sure that model and obs data are in the SAME UNITS prior - ! to generating the input scaling files with the matlab routines. - ! Otherwise, the (linear) rescaling outside of the observed - ! range (between obs_min and obs_max) will fail! For example, - ! ASCAT soil moisture retrievals must first be converted into - ! volumetric units that range roughly from 0 to 0.5 m3/m3 - ! (for some porosity) before they can be rescaled to the - ! Catchment model's sfmc (which is in m3/m3). - - ! THIS SUBROUTINE COULD USE WORK... - ! - map from scaling parameter domain to model domain - ! reichle, 14 Oct 2005 - ! reichle, 26 Sep 2006 - ! - ! bug fix: scaling via linear interpolation outside of [obs_min,obs_max] - ! reichle, 27 Jan 2006 - ! - ! reichle, 22 Nov 2011 - renamed subroutine, minor clean-up, added comments - ! reichle, 9 Nov 2012 - edited to enable use of stats file that do not - ! perfectly match current domain (as in tile_coord) - - implicit none - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(obs_param_type), intent(in) :: this_obs_param - - ! inout - - real, intent(inout), dimension(N_catd) :: tmp_obs - real, intent(inout), dimension(N_catd) :: tmp_std_obs - - ! local variables - - real, parameter :: no_data_stats = -9999. - - real, parameter :: tol = 1e-2 - - character(300) :: fname - - integer :: i, j, N_sclprm, N_poly, ind - - real :: edge_min, edge_max, edge_dx - - real :: tmpreal, x, x0, x1, y0, y1 - - integer, dimension(:), allocatable :: tmp_tile_id - - real, dimension(:), allocatable :: std_obs, std_mod, min_obs, max_obs - - real, dimension(:,:), allocatable :: fit_coeff - - character(len=*), parameter :: Iam = 'scale_obs_sfmc_cdf' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - - ! read scaling parameters from file - - fname = trim(this_obs_param%scalepath) // '/' // & - trim(this_obs_param%scalename) - - if (logit) write (logunit,*) 'scaling obs species ', this_obs_param%species, ':' - if (logit) write (logunit,'(400A)') ' reading ', trim(fname) - - open(10, file=fname, form='formatted', action='read') - - read(10,*) N_sclprm, N_poly, edge_min, edge_max, edge_dx - - ! minimal consistency check - - if (N_catd>N_sclprm) then - err_msg = 'N_sclprm too small' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - allocate( tmp_tile_id( N_sclprm )) - allocate( std_obs( N_sclprm )) - allocate( std_mod( N_sclprm )) - allocate( min_obs( N_sclprm )) - allocate( max_obs( N_sclprm )) - allocate( fit_coeff( N_sclprm, N_poly+1 )) - - do i=1,N_sclprm - - read (10,*) tmp_tile_id(i), std_obs(i), std_mod(i), & - min_obs(i), max_obs(i), fit_coeff(i,:) - - end do - - close(10,status='keep') - - ! -------------------------------------------------------------- - - ! scale observations - - do i=1,N_catd - - ! check for no-data-values in observation - ! (any negative number could be no-data-value for observations) - - if (tmp_obs(i)>=0.) then - - ! find ind for current tile id in scaling parameters - - if (tmp_tile_id(i)==tile_coord(i)%tile_id) then - - ind = i ! educated guess for global domain - - else - - do ind=1,N_sclprm - - if (tmp_tile_id(ind)==tile_coord(i)%tile_id) exit - - end do - - if (ind>N_sclprm) then - err_msg = 'tile_id not found in scaling parameter file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - - ! make sure obs falls within range valid for scaling and - ! check for no-data-value in fit parameters - - if ( (tmp_obs(i)>=edge_min) .and. & - (tmp_obs(i)<=edge_max) .and. & - (abs(fit_coeff(ind,1)-no_data_stats) > tol) .and. & - (abs(fit_coeff(ind,2)-no_data_stats) > tol) ) then - - ! evaluate polynomial fit - ! - ! fit_coeff(ind,1) is coeff for highest order - ! fit_coeff(ind,N_poly+1) is constant term - - ! evaluate polynomial at tmp_obs if min_obs<=tmp_obs<=max_obs, - ! otherwise at min_obs or max_obs (accordingly) - - x = min( max( tmp_obs(i), min_obs(ind) ), max_obs(ind) ) - - tmpreal = fit_coeff(ind,1) - - do j=1,N_poly - - tmpreal = tmpreal*x + fit_coeff(ind,j+1) - - end do - - if (tmp_obs(i)max_obs(ind)) then - - ! linear interpolation between max_obs and max(edges) - ! (NOTE: model and obs data must be in SAME units, - ! reichle, 22 Nov 2011) - - y1 = edge_max - y0 = tmpreal - x1 = edge_max - x0 = max_obs(ind) - - tmp_obs(i) = (y1-y0)/(x1-x0)*( tmp_obs(i) - x0 ) + y0 - - else - - ! accept polynomial fit as is - - tmp_obs(i) = tmpreal - - end if - - ! scale observation error std - - tmp_std_obs(i) = std_mod(ind)/std_obs(ind)*tmp_std_obs(i) - - else - - tmp_obs(i) = this_obs_param%nodata - - end if - - end if - - ! qc check after scaling - - if ((tmp_obs(i)>edge_max) .or. (tmp_obs(i)N_sclprm) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'something is wrong') - end if - - ! -------------------------------------------------------------- - - ! scale observations (at this point all obs are of type - ! isccp_tskin_gswp2_v1 because of the way the subroutine is called - ! from subroutine read_obs()) - - do i=1,N_catd - - ! check for no-data-values in observation (any neg Tskin is no_data) - - if (tmp_obs(i)>=0.) then - - ! find ind for current tile id in scaling parameters - - do ind=1,N_sclprm - - if (sclprm_tile_id(ind)==tile_coord(i)%tile_id) exit - - end do - - ! sanity check (against accidental use of wrong tile space) - - if ( abs(tile_coord(i)%com_lat-sclprm_lat(ind))>tol .or. & - abs(tile_coord(i)%com_lon-sclprm_lon(ind))>tol ) then - err_msg = 'something wrong' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! check for no-data-values in observation and fit parameters - ! (any negative number could be no-data-value for observations) - - if ( sclprm_mean_obs(ind)>0. .and. & - sclprm_mean_mod(ind)>0. .and. & - sclprm_std_obs(ind)>=0. .and. & - sclprm_std_mod(ind)>=0. ) then - - ! scale via standard normal deviates - - tmpreal = sclprm_std_mod(ind)/sclprm_std_obs(ind) - - tmp_obs(i) = sclprm_mean_mod(ind) & - + tmpreal*(tmp_obs(i)-sclprm_mean_obs(ind)) - - ! scale observation error std - - tmp_std_obs(i) = tmpreal*tmp_std_obs(i) - - else - - tmp_obs(i) = this_obs_param%nodata - - end if - - end if - - end do - - deallocate(sclprm_tile_id) - deallocate(sclprm_lon) - deallocate(sclprm_lat) - deallocate(sclprm_mean_obs) - deallocate(sclprm_std_obs) - deallocate(sclprm_mean_mod) - deallocate(sclprm_std_mod) - - end subroutine scale_obs_tskin_zscore - - - ! ***************************************************************** - - subroutine scale_obs_sfmc_zscore( N_catd, tile_coord, & - date_time, this_obs_param, tmp_lon, tmp_lat, tmp_time, & - tmp_obs, tmp_std_obs ) - - ! scale sfmc or sfds obs to model climatology via standard-normal-deviate (zscore) - ! scaling using seasonally varying (pentad) stats - ! Grid information is read from a NetCDF file - ! - ! Scaling parameters are read from a NetCDF file that contains the following: - ! variables: - ! int version ; - ! double ll_lon ; - ! ll_lon:standard_name = "longitude of lower left corner" ; - ! double ll_lat ; - ! ll_lat:standard_name = "latitude of lower left corner" ; - ! double d_lon ; - ! d_lon:standard_name = "longitude grid spacing" ; - ! double d_lat ; - ! d_lat:standard_name = "latitude grid spacing" ; - ! int pentad(pentad) ; - ! pentad:standard_name = "pentad" ; - ! double start_time(pentad) ; - ! start_time:standard_name = "start time" ; - ! double end_time(pentad) ; - ! end_time:standard_name = "end time" ; - ! double o_mean(pentad, lon, lat) ; - ! o_mean:standard_name = "observation mean" ; - ! double o_std(pentad, lon, lat) ; - ! o_std:standard_name = "observation standard deviation" ; - ! double m_mean(pentad, lon, lat) ; - ! m_mean:standard_name = "model mean" ; - ! double m_std(pentad, lon, lat) ; - ! m_std:standard_name = "model standard deviation" ; - ! double m_min(lon, lat) ; - ! m_min:standard_name = "model minimum" ; - ! double m_max(lon, lat) ; - ! m_max:standard_name = "model maximum" ; - ! double n_data(pentad, lon, lat) ; - ! n_data:standard_name = "number of data points" ; - ! - ! A M Fox, reichle, April 2023 - - use netcdf - implicit none - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(date_time_type), intent(in) :: date_time - - type(obs_param_type), intent(in) :: this_obs_param - - real, intent(in), dimension(N_catd) :: tmp_lon, tmp_lat - real*8, intent(in), dimension(N_catd) :: tmp_time ! J2000 seconds - - ! inout - - real, intent(inout), dimension(N_catd) :: tmp_obs - real, intent(inout), dimension(N_catd) :: tmp_std_obs - - ! ------------------- - - character(300) :: fname - - integer :: i, ind, pp, j_ind, i_ind - integer :: ncid, varid, ierr, ierr2 - integer :: pentad_dimid, lon_dimid, lat_dimid - integer :: N_pentad, N_lon, N_lat - integer :: pentad_varid - integer :: o_mean_varid, o_std_varid, m_mean_varid, m_std_varid, m_min_varid, m_max_varid - integer :: ll_lon_varid, ll_lat_varid, dlon_varid, dlat_varid - integer, dimension(3) :: start, icount - - logical :: file_exists - - real :: tmpreal, this_lon, this_lat, ll_lon, ll_lat, dlon, dlat - - integer, dimension(:), allocatable :: sclprm_tile_id - integer, dimension(:), allocatable :: pentads - - real, dimension(:,:), allocatable :: sclprm_mean_obs, sclprm_std_obs - real, dimension(:,:), allocatable :: sclprm_mean_mod, sclprm_std_mod - real, dimension(:,:), allocatable :: sclprm_min_mod, sclprm_max_mod - - character(len=*), parameter :: Iam = ' scale_obs_sfmc_zscore' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - - ! Read scaling parameters from file - - fname = trim(this_obs_param%scalepath) // '/' // & - trim(this_obs_param%scalename) // '.nc4' - - if (logit) write (logunit,*) 'scaling obs species ', this_obs_param%species, ':' - if (logit) write (logunit,'(400A)') ' reading ', trim(fname) - - ! Check if file exists - - inquire(file=fname, exist=file_exists) - - if (.not. file_exists) then - - err_msg = 'Scaling parameter file not found' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! Determine pentad to use - - pp = date_time%pentad - - ! Open the NetCDF file - - ierr = nf90_open(fname, nf90_nowrite, ncid) - - ! Get the dimension and variable IDs - - ierr = nf90_inq_varid(ncid, 'll_lon', ll_lon_varid) - ierr = nf90_inq_varid(ncid, 'll_lat', ll_lat_varid) - ierr = nf90_inq_varid(ncid, 'd_lon', dlon_varid) - ierr = nf90_inq_varid(ncid, 'd_lat', dlat_varid) - - ! Get the dimension sizes - - ierr = nf90_inq_dimid(ncid, 'pentad', pentad_dimid) - ierr = nf90_inq_dimid(ncid, 'lon', lon_dimid) - ierr = nf90_inq_dimid(ncid, 'lat', lat_dimid) - - ierr = nf90_inquire_dimension(ncid, pentad_dimid, len = N_pentad) - ierr = nf90_inquire_dimension(ncid, lon_dimid, len = N_lon) - ierr = nf90_inquire_dimension(ncid, lat_dimid, len = N_lat) - - ! Get the variable IDs - - ierr = nf90_inq_varid(ncid, 'o_mean', o_mean_varid) - ierr = nf90_inq_varid(ncid, 'o_std', o_std_varid) - ierr = nf90_inq_varid(ncid, 'm_mean', m_mean_varid) - ierr = nf90_inq_varid(ncid, 'm_std', m_std_varid) - ierr = nf90_inq_varid(ncid, 'm_min', m_min_varid) - ierr = nf90_inq_varid(ncid, 'm_max', m_max_varid) - - ! Read grid variables - - ierr = nf90_get_var(ncid, ll_lon_varid, ll_lon) - ierr = nf90_get_var(ncid, ll_lat_varid, ll_lat) - ierr = nf90_get_var(ncid, dlon_varid, dlon) - ierr = nf90_get_var(ncid, dlat_varid, dlat) - - start = [1, 1, pp] - icount = [N_lat, N_lon, 1 ] - - ! Read mean and std variables - - allocate(sclprm_mean_obs(N_lat, N_lon), sclprm_std_obs(N_lat, N_lon)) - allocate(sclprm_mean_mod(N_lat, N_lon), sclprm_std_mod(N_lat, N_lon)) - allocate(sclprm_min_mod( N_lat, N_lon), sclprm_max_mod(N_lat, N_lon)) - - ierr = nf90_get_var(ncid, o_mean_varid, sclprm_mean_obs, start, icount) - ierr = nf90_get_var(ncid, o_std_varid, sclprm_std_obs, start, icount) - ierr = nf90_get_var(ncid, m_mean_varid, sclprm_mean_mod, start, icount) - ierr = nf90_get_var(ncid, m_std_varid, sclprm_std_mod, start, icount) - ierr = nf90_get_var(ncid, m_min_varid, sclprm_min_mod) - ierr = nf90_get_var(ncid, m_max_varid, sclprm_max_mod) - - ! Close the netcdf file - - ierr = nf90_close(ncid) - - ! -------------------------------------------------------------- - - ! Scale observations (at this point all obs are of same type because - ! of the way the subroutine is called from subroutine read_obs() - - do i=1,N_catd - - ! Check for no-data-values in observation (any neg value is no_data) - - if (tmp_obs(i)>=0.) then - - ! ll_lon and ll_lat refer to lower left corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - - this_lon = tmp_lon(i) - this_lat = tmp_lat(i) - - ! Find indices for current tile lat and lon on scaling parameter grid - - i_ind = ceiling((this_lon - ll_lon)/dlon) - j_ind = ceiling((this_lat - ll_lat)/dlat) - - ! Check for no-data-values in observation and fit parameters - ! (any negative number could be no-data-value for observations) - - if ( sclprm_mean_obs(j_ind, i_ind)>0. .and. & - sclprm_mean_mod(j_ind, i_ind)>0. .and. & - sclprm_std_obs(j_ind, i_ind)>=0. .and. & - sclprm_std_mod(j_ind, i_ind)>=0. ) then - - ! Scale via standard normal deviates - - tmpreal = sclprm_std_mod(j_ind, i_ind)/sclprm_std_obs(j_ind, i_ind) - - tmp_obs(i) = sclprm_mean_mod(j_ind, i_ind) & - + tmpreal*(tmp_obs(i)-sclprm_mean_obs(j_ind, i_ind)) - - ! Check of tmp_obs is within range of model climatology - - if (tmp_obs(i)sclprm_max_mod(j_ind, i_ind)) then - - tmp_obs(i) = sclprm_max_mod(j_ind, i_ind) - - end if - - ! Scale observation error std - - tmp_std_obs(i) = tmpreal*tmp_std_obs(i) - - else - - tmp_obs(i) = this_obs_param%nodata - - end if - - end if - - end do - - deallocate(sclprm_mean_obs) - deallocate(sclprm_std_obs) - deallocate(sclprm_mean_mod) - deallocate(sclprm_std_mod) - deallocate(sclprm_min_mod) - deallocate(sclprm_max_mod) - - end subroutine scale_obs_sfmc_zscore - - ! ******************************************************************************** - - subroutine scale_obs_Tb_zscore( N_catd, tile_coord, date_time, this_obs_param, & - tmp_obs, tmp_std_obs, tmp_assim ) - - ! Scale Tb obs to model climatology via standard-normal-deviate (zscore) - ! scaling or mean-only scaling. - ! - ! The type of scaling is determined by the first 5 characters of the - ! nml input "this_obs_param%scalename" as follows: - ! - ! this_obs_param%scalename = 'ScZS_' : Scale using ZScore (mean and std-dev) - ! this_obs_param%scalename = 'ScMO_' : Scale using Mean Only - ! - ! These first 5 characters are NOT part of the file name for the scaling file. - ! - ! Use matlab functions "get_model_and_obs_clim_stats_oct11.m" - ! and "scaling_prep_multi_year.m" by Gabrielle De Lannoy to create - ! global input scaling files for each pentad. - ! - ! Note that the tiles in the input scaling parameter files do NOT need - ! to be in the same order as in the domain tile_coord vector (although - ! the fastest execution is obtained when the scaling parameter files - ! and the domain tile_coord vector are for exactly the same tiles in - ! the same order. - ! - ! The vector "tmp_obs" is of length N_catd. The observations in "tmp_obs" - ! are mapped into tile space ONLY for book-keeping (each observation has - ! been assigned to a model tile). The observations are not necessarily - ! representative of the assigned tile and could be for a larger area. - ! The scaling parameter file therefore is specific to a model tile space. - ! Global scaling parameter files *can* be used with subdomains. - ! - ! Valid statistics are not necessarily available for each observed - ! location and day-of-year. - ! - ! Gabrielle De Lannoy (GDL), 10 Sep 2012 - first draft - ! reichle, 12 Oct 2012 - revised and merged into CVS trunk - ! reichle, 6 Jun 2016 - keep obs that can *not* be scaled, - ! but set tmp_assim=.false. - - implicit none - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(date_time_type), intent(in) :: date_time - - type(obs_param_type), intent(in) :: this_obs_param - - ! inout - - real, intent(inout), dimension(N_catd) :: tmp_obs - real, intent(inout), dimension(N_catd) :: tmp_std_obs - logical, intent(inout), dimension(N_catd) :: tmp_assim - - ! ---------------------------------------------------------- - - ! local variables - - real, parameter :: no_data_stats = -9999. - - real, parameter :: tol = 1e-2 - - ! ------------------- - - logical :: hpol, scale_mean_only - - character(300) :: fname - - character( 80) :: tmpstring80 - character( 2) :: tmpstring2, orbit_flag - - integer :: i, ind, istat, ind_angle - - integer :: asc_flag, N_data_min, N_sclprm, N_ang - - real :: tmpreal - - integer, dimension(:), allocatable :: sclprm_tile_id - - real, dimension(:), allocatable :: sclprm_ang - real, dimension(:), allocatable :: sclprm_lon, sclprm_lat - real, dimension(:), allocatable :: sclprm_mean_obs, sclprm_std_obs - real, dimension(:), allocatable :: sclprm_mean_mod, sclprm_std_mod - - character(len=*), parameter :: Iam = 'scale_obs_Tb_zscore' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - - ! determine whether to scale mean and std-dev or mean only - - tmpstring80 = this_obs_param%scalename - - if (tmpstring80(1:5)=='ScZS_') then - - scale_mean_only = .false. - - elseif (tmpstring80(1:5)=='ScMO_') then - - scale_mean_only = .true. - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown scaling method') - - end if - - ! assemble the name of the file with scaling parameters - ! - ! - first 5 chars of this_obs_param%scalename are NOT part of the file name - ! - different scaling files for each orbit and pentad - - if (this_obs_param%orbit==1) then - - orbit_flag = '_A' - - elseif (this_obs_param%orbit==2) then - - orbit_flag = '_D' - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown orbit') - - end if - - write (tmpstring2, '(i2.2)') date_time%pentad - - fname = & - trim(this_obs_param%scalepath) // '/' // & - trim(this_obs_param%scalename(6:80)) // & - orbit_flag // '_p' // tmpstring2 // '.bin' - - if (logit) write (logunit,*) 'scaling obs species ', this_obs_param%species, ':' - if (logit) write (logunit,'(400A)') ' reading ', trim(fname) - - open(10, file=fname, form='unformatted',convert='big_endian',status='old', & - access='SEQUENTIAL', iostat=istat) - - if (istat/=0) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'could not open file') - end if - - - ! read file header - ! - ! file format of scaling files mirrors that of pre-processed SMOS obs files - - read(10) asc_flag, N_data_min - read(10) ! start time of interval for stats computation (not used) - read(10) ! end time of interval for stats computation (not used) - read(10) N_sclprm, N_ang - - ! minimal consistency checks - - if ( (this_obs_param%orbit==1 .and. asc_flag/=1) .or. & - (this_obs_param%orbit==2 .and. asc_flag/=0) ) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'orbit mismatch') - end if - - if (logit) write (logunit,*) ' asc_flag = ', asc_flag - if (logit) write (logunit,*) ' N_data_min = ', N_data_min - if (logit) write (logunit,*) ' N_sclprm = ', N_sclprm - if (logit) write (logunit,*) ' N_ang = ', N_ang - - allocate(sclprm_ang( N_ang )) - - allocate(sclprm_lon( N_sclprm)) - allocate(sclprm_lat( N_sclprm)) - allocate(sclprm_tile_id( N_sclprm)) - - allocate(sclprm_mean_obs(N_sclprm)) - allocate(sclprm_std_obs( N_sclprm)) - allocate(sclprm_mean_mod(N_sclprm)) - allocate(sclprm_std_mod( N_sclprm)) - - ! read angle and location information - - read(10) sclprm_ang - - read(10) sclprm_lon !only valid values where obs were available - read(10) sclprm_lat !only valid values where obs were available - read(10) sclprm_tile_id - - ! find the index for the angle of interest - ! NOTE: after processing of namelist inputs, each species - ! has a unique angle (see subroutine read_ens_upd_inputs()) - - ind_angle = -9999 - - do i=1,N_ang - - if (abs(sclprm_ang(i)-this_obs_param%ang(1))<0.01) ind_angle = i - - end do - - if (ind_angle<0) then - err_msg = 'problem with incidence angle' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! need h-pol or v-pol? - - if (this_obs_param%pol==1) then - - hpol = .true. - - elseif (this_obs_param%pol==2) then - - hpol = .false. - - else - - err_msg = 'unknown polarization' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! read scaling parameters - ! - ! for each field, loop over all angles, read stats for angle of interest - ! - ! blocks (1- 5) after header: Tbh stats - ! blocks (6-10) after header: Tbv stats - - if (.not. hpol) then ! in case of V-pol, skip through H-pol entries - - do i=1,N_ang ! block 1 - mean_obs Tbh - read(10) - end do - - do i=1,N_ang ! block 2 - std_obs Tbh - read(10) - end do - - do i=1,N_ang ! block 3 - mean_mod Tbh - read(10) - end do - - do i=1,N_ang ! block 4 - std_mod Tbh - read(10) - end do - - do i=1,N_ang ! block 5 - N_data Tbh - read(10) - end do - - end if - - ! from each block, read stats for angle of interest - - do i=1,N_ang ! block 1 (h-pol) or 6 (v-pol) - mean_obs - - if (i==ind_angle) then - read(10) sclprm_mean_obs - else - read(10) - end if - - end do - - do i=1,N_ang ! block 2 (h-pol) or 7 (v-pol) - std_obs - - if (i==ind_angle) then - read(10) sclprm_std_obs - else - read(10) - end if - - end do - - do i=1,N_ang ! block 3 (h-pol) or 8 (v-pol) - mean_mod - - if (i==ind_angle) then - read(10) sclprm_mean_mod - else - read(10) - end if - - end do - - do i=1,N_ang ! block 4 (h-pol) or 9 (v-pol) - std_mod - - if (i==ind_angle) then - read(10) sclprm_std_mod - else - read(10) - end if - - end do - - !do i=1,N_ang ! block 5 (h-pol) or 10 (v-pol) - N_data - ! - ! if (i==ind_angle) then - ! read(10) sclprm_Ndata - ! else - ! read(10) - ! end if - ! - !end do - - close(10,status='keep') - - - ! -------------------------------------------------------------- - - ! scale observations (at this point all obs are of type Tb because - ! of the way the subroutine is called from subroutine read_obs()) - - do i=1,N_catd - - ! check for no-data-values in observation (any neg Tb is no_data) - - if (tmp_obs(i)>=0.) then - - ! find ind for current tile id in scaling parameters - - ind = -9999 ! initialize to negative integer - - if (N_sclprm==N_catd) then - - ! try an educated guess (to avoid an additional loop) - - if (sclprm_tile_id(i)==tile_coord(i)%tile_id) ind = i - - end if - - if (ind<0) then ! the educated guess failed, try again - - do ind=1,N_sclprm - - if (sclprm_tile_id(ind)==tile_coord(i)%tile_id) exit - - end do - - if (ind>N_sclprm) then - err_msg = 'tile_id not found in scaling parameter file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - ! check for no-data-values in observation and fit parameters - ! (any negative number could be no-data-value for observations) - - if ( sclprm_mean_obs(ind)>0. .and. & - sclprm_mean_mod(ind)>0. .and. & - sclprm_std_obs( ind)>0. .and. & - sclprm_std_mod( ind)>0. ) then - - - ! sanity check (against accidental use of wrong tile space) - - if ( abs(tile_coord(i)%com_lat-sclprm_lat(ind))>tol .or. & - abs(tile_coord(i)%com_lon-sclprm_lon(ind))>tol ) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'something wrong') - end if - - ! scale - - if (scale_mean_only) then - - ! adjust mean only - - tmp_obs(i) = & - tmp_obs(i) - sclprm_mean_obs(ind) + sclprm_mean_mod(ind) - - else - - ! scale via standard normal deviates - - tmpreal = sclprm_std_mod(ind)/sclprm_std_obs(ind) - - tmp_obs(i) = sclprm_mean_mod(ind) & - + tmpreal*(tmp_obs(i)-sclprm_mean_obs(ind)) - - ! scale observation error std - - tmp_std_obs(i) = tmpreal*tmp_std_obs(i) - - end if - - else - - ! keep unscaled obs, provide only "do not assimilate" info - ! reichle, 6 Jun 2016 - - tmp_assim(i) = .false. - - !tmp_obs(i) = this_obs_param%nodata - - end if - - end if - - end do - - deallocate(sclprm_ang) - - deallocate(sclprm_tile_id) - deallocate(sclprm_lon) - deallocate(sclprm_lat) - - deallocate(sclprm_mean_obs) - deallocate(sclprm_std_obs) - deallocate(sclprm_mean_mod) - deallocate(sclprm_std_mod) - - end subroutine scale_obs_Tb_zscore - - ! ***************************************************************** - - subroutine collect_obs( & - work_path, exp_id, date_time, dtstep_assim, & - N_catl, & - N_catf, tile_coord_f, tile_grid_f, N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - N_catl_vec, low_ind, l2f, & - N_obs_param, obs_param, N_obsl_max, write_obslog, & - N_obsl, Observations_l, found_obs_f ) - - ! check for observations that must be assimilated, - ! collect into measurement vector - ! - ! a total of "N_obsl" observations are returned in "Observations_l" - ! - ! 25 Jul 2005 - rewritten - ! 10 Jun 2011 - re-structured for MPI, incl. removal of model-based QC - ! (now done in connection with get_obs_pred()) - ! 24 Dec 2013 - added "obslog" output files (not yet implemented for all readers!) - ! 31 Dec 2014 - added time stamp to Observations - ! 21 Mar 2014 - sort Observations_l by tilenum and then species to avoid lay-out - ! dependency for MPI parallel execution - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: dtstep_assim - integer, intent(in) :: N_catl, N_catf - - integer, dimension(numprocs), intent(in) :: N_catl_vec, low_ind - - integer, dimension(N_catl), intent(in) :: l2f - - ! tile_coord_f of catchments in domain (length N_catf) - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! input - - type(grid_def_type), intent(in) :: tile_grid_f - - ! N_tile_in_cell_ij and tile_num_in_cell_ij are on the "full" domain - ! and guaranteed to be allocated ONLY for the root_proc - ! (but may be allocated on all processors depending on obs_param%FOV) - - integer, dimension(:,:), pointer :: N_tile_in_cell_ij_f ! input - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij_f ! input - - integer, intent(in) :: N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - integer, intent(in) :: N_obsl_max - - logical, intent(in) :: write_obslog - - integer, intent(out) :: N_obsl - - type(obs_type), dimension(N_obsl_max), intent(out) :: Observations_l - - logical, intent(out) :: found_obs_f - - ! ---------------------------- - - ! locals - - logical :: found_obs, scaled_obs, any_scaled_obs - - integer :: obs_count, species - integer :: ii, ind_start, ind_end, N_tmp, this_tilenum, this_tilenum_new - - real, dimension(N_catl) :: tmp_obs, tmp_std_obs, tmp_lon, tmp_lat - real, dimension(N_catf) :: tmp_obs_f, tmp_std_obs_f, tmp_lon_f, tmp_lat_f - - real*8, dimension(N_catl) :: tmp_time - real*8, dimension(N_catf) :: tmp_time_f - - logical, dimension(N_catl) :: tmp_assim - logical, dimension(N_catf) :: tmp_assim_f - - integer, dimension(numprocs) :: N_obsl_vec - - integer, dimension(N_obs_param) :: tmp_species - - integer, dimension(:), allocatable :: indx, tilenums - - character( 12) :: tmpstr12 - character(300) :: tmpstr300 - - character(len=*), parameter :: Iam = 'collect_obs' - character(len=400) :: err_msg - - ! --------------------------------------------------------------- - - if (logit) write (logunit,*) 'collecting observations...' - - ! obs_count serves as counter for total number of observations, - ! excluding no-data-values - - obs_count = 0 - - any_scaled_obs = .false. ! initialize - - ! ---------------------------------------------------------- - - do species = 1,N_obs_param - - ! make sure species number here is consistent with - ! definitions in nml input file - - if (obs_param(species)%species .ne. species) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'something wrong') - end if - - if (root_proc) then - - ! subroutine read_obs() reads all observations in obs files - ! (typically global) and returns a vector in (full domain) - ! tile space with the values of the observations (at most one - ! observation per tile and per species) - - call read_obs( & - work_path, exp_id, & - date_time, dtstep_assim, N_catf, tile_coord_f, & - tile_grid_f, N_tile_in_cell_ij_f, tile_num_in_cell_ij_f, & - obs_param(species), write_obslog, & - found_obs, scaled_obs, & - tmp_obs_f, tmp_std_obs_f, tmp_lon_f, tmp_lat_f, tmp_time_f, tmp_assim_f) - - if (scaled_obs) any_scaled_obs = .true. - - end if - - ! put "tmp_obs" (in "tile" space) into "compressed" vector "Observations_l" - ! - ! each observation is "managed" ("administered") by the processor that - ! contains the tile to which the observation was assigned - ! - ! the assignment of each observation to tile space does NOT imply that - ! only the observations from one (local) processor impact the increments - ! for that processor --> see "halo" below - -#ifdef LDAS_MPI - - call MPI_BCAST(found_obs, 1, MPI_LOGICAL, 0,mpicomm, mpierr) - -#endif - - if (found_obs) then - - ! map from full to local domain - - call f2l_real( N_catf,N_catl,N_catl_vec,low_ind, tmp_obs_f, tmp_obs) - call f2l_real( N_catf,N_catl,N_catl_vec,low_ind, tmp_std_obs_f, tmp_std_obs) - call f2l_real( N_catf,N_catl,N_catl_vec,low_ind, tmp_lon_f, tmp_lon) - call f2l_real( N_catf,N_catl,N_catl_vec,low_ind, tmp_lat_f, tmp_lat) - - call f2l_real8( N_catf,N_catl,N_catl_vec,low_ind, tmp_time_f, tmp_time) - - call f2l_logical(N_catf,N_catl,N_catl_vec,low_ind, tmp_assim_f, tmp_assim) - - - ! NOTE: "Observations" here are l(ocal) obs only - - call put_into_Observations( obs_param(species), N_obsl_max, N_catl, l2f, & - tmp_obs, tmp_std_obs, tmp_lon, tmp_lat, tmp_time, tmp_assim, & - obs_count, Observations_l ) - - end if - - end do - -#ifdef LDAS_MPI - - call MPI_BCAST(any_scaled_obs, 1, MPI_LOGICAL, 0,mpicomm, mpierr) - -#endif - - N_obsl = obs_count - - ! ----------------------------------------------------------------- - ! - ! sort relevant elements of Observations_l by tilenum and then by species - ! to avoid lay-out dependency for MPI parallel execution - ! - reichle, 21 March 2014 - - if (N_obsl>1) then ! sort only if 2 or more obs - - allocate(indx( N_obsl)) - - allocate(tilenums(N_obsl)) - - tilenums = Observations_l(1:N_obsl)%tilenum - - ! get index vector, NOTE: - ! nr_indexx() does not change input "arr" - ! nr_indexx() only works with *real* input "arr" - - call nr_indexx( N_obsl, real(tilenums), indx(1:N_obsl) ) - - ! apply sort by tilenum - - Observations_l(1:N_obsl) = Observations_l(indx(1:N_obsl)) - - ! now make sure that within each tilenum, Observations_l are sorted by species - - ind_start = 1 - - this_tilenum = Observations_l(ind_start)%tilenum - - do ii=2,N_obsl - - this_tilenum_new = Observations_l(ii)%tilenum - - if ( (this_tilenum_new/=this_tilenum) .or. (ii==N_obsl) ) then - - if ( (this_tilenum_new/=this_tilenum) .and. (ii<=N_obsl) ) then - - ind_end = ii-1 - - else - - ind_end = N_obsl - - end if - - ! Observations_l(ind_start:ind_end) are the complete subset - ! of (local) obs with the same tilenum - - N_tmp = ind_end - ind_start + 1 - - if (N_tmp>1) then - - tmp_species(1:N_tmp) = Observations_l(ind_start:ind_end)%species - - ! get index vector for sorting by species (see NOTES above!) - - call nr_indexx( N_tmp, real(tmp_species(1:N_tmp)), indx(1:N_tmp) ) - - ! apply sort by species - - indx(1:N_tmp) = indx(1:N_tmp) + ind_start - 1 ! add offset - - Observations_l(ind_start:ind_end) = Observations_l(indx(1:N_tmp)) - - end if - - ! re-initialize - - ind_start = ii - - this_tilenum = this_tilenum_new - - end if - - end do - - ! clean up - - deallocate(indx) - deallocate(tilenums) - - end if - - ! ----------------------------------------------------------------- - ! - ! check whether number of obs exceeds max number allowed - - if (N_obsl>N_obsl_max) then - err_msg = 'N_obsl > N_obsl_max, too many observations' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! make sure L1C_Tb obs are not assimilated at the same time/place where - ! corresponding disaggregated L2AP_Tb observations are assimilated - - call turn_off_assim_SMAP_L1CTb(N_obs_param, obs_param, N_obsl, Observations_l) - - ! gather information about number of observations assigned to each processor - -#ifdef LDAS_MPI - - call MPI_AllGather( & - N_obsl, 1, MPI_integer, & - N_obsl_vec, 1, MPI_integer, & - mpicomm, mpierr ) - -#else - - N_obsl_vec(1) = N_obsl - -#endif - - if (any(N_obsl_vec>0)) then - - found_obs_f = .true. ! found obs somewhere in full domain - - else - - found_obs_f = .false. - - end if - - ! ----------------------------------------------------------------- - - ! TO DO: scale Observations (note: no scaling for moisture contents) - - ! may be needed for multi-variate assimilation, reichle, 10 Jun 2011 - - !!do i=1,N_obs - !! - !! select case (Observations(i)%species) - !! - !! case (5) - !! - !! Observations(i)%obs = Observations(i)%obs / scale_temp - !! Observations(i)%obsvar = Observations(i)%obsvar /(scale_temp**2) - !! - !! end select - !! - !!end do - - ! ----------------------------------------------------------------- - - ! determine total number of observations to be assimilated - ! - ! NOTE: This number may be different from the total number of obs - ! recorded in the "obslog" file because: - ! (i) the number of obs recorded in the "obslog" file is - ! before obs from separate files may have been aggregated - ! to "super-obs", and - ! (ii) older obs readers may not contribute to the "obslog" file. - - write (tmpstr12,'(i12)') sum(N_obsl_vec) ! convert integer to string - - tmpstr300 = 'collect_obs(): read N_obsf = ' // tmpstr12 // & - ' [after obs-based QC, super-obbing' - - if (.not. any_scaled_obs) then - - tmpstr300 = trim(tmpstr300) // ']' - - else - - tmpstr300 = trim(tmpstr300) // ', scaling]' - - end if - - if (logit) write (logunit,'(400A)') trim(tmpstr300) - - ! ------------------------------------- - - end subroutine collect_obs - - - ! ************************************************************** - - subroutine put_into_Observations( this_obs_param, N_obs_max, N_catd, l2f, & - tmp_obs, tmp_std_obs, tmp_lon, tmp_lat, tmp_time, tmp_assim, & - obs_count, Observations ) - - ! Put one type of observations into the general "Observations" vector: - ! throw out no-data-values and keep track of which components have - ! been filled ("obs_count") - ! All observations (except no-data-values) are included at this stage - ! regardless of whether they will be assimilated or whether only - ! innovations will be computed. - ! - ! added "l2f" index vector that maps "local" tilenum to tilenum - ! within "full" domain - ! - reichle, 17 Oct 2011 - ! - ! reichle, 31 Jan 2014: added "tmp_time" - ! reichle, 6 Jun 2016: added flag "tmp_assim" to facilitate retaining unscaled obs - - implicit none - - type(obs_param_type), intent(in) :: this_obs_param - - integer, intent(in) :: N_obs_max, N_catd - - integer, dimension(N_catd), intent(in) :: l2f - - real, dimension(N_catd), intent(in) :: tmp_obs, tmp_std_obs, tmp_lon, tmp_lat - - real*8, dimension(N_catd), intent(in) :: tmp_time - - logical, dimension(N_catd), intent(in) :: tmp_assim - - integer, intent(inout) :: obs_count - - type(obs_type), dimension(N_obs_max), intent(inout) :: Observations - - ! ------------------------------------------------------ - - integer :: i - - real :: nodatavalue, tol - - ! ------------------------------------------------------ - - nodatavalue = this_obs_param%nodata - - tol = abs(nodatavalue*nodata_tolfrac_generic) - - do i=1,N_catd - - if (abs(tmp_obs(i)-nodatavalue) > tol) then ! check for no-data-value - - obs_count = obs_count+1 ! augment observation counter - - Observations(obs_count)%obs = tmp_obs(i) - - ! check if std has been set already; if not, use default value - ! (no-data-value for std is any negative value) - - if (tmp_std_obs(i) > .0) then - - Observations(obs_count)%obsvar = tmp_std_obs(i)**2 - - else - - Observations(obs_count)%obsvar = this_obs_param%errstd**2 - - end if - - Observations(obs_count)%tilenum = l2f(i) - - Observations(obs_count)%time = tmp_time(i) - - Observations(obs_count)%lat = tmp_lat(i) - Observations(obs_count)%lon = tmp_lon(i) - - Observations(obs_count)%species = this_obs_param%species - - Observations(obs_count)%assim = this_obs_param%assim .and. tmp_assim(i) - - Observations(obs_count)%fcst = this_obs_param%nodata - Observations(obs_count)%fcstvar = this_obs_param%nodata - - Observations(obs_count)%ana = this_obs_param%nodata - Observations(obs_count)%anavar = this_obs_param%nodata - - end if - end do - - end subroutine put_into_Observations - - - ! ***************************************************************** - - subroutine add_to_obslog( & - date_time_string, obs_param_descr, subroutine_name, num_obs_string, file_name ) - - implicit none - - character( *), intent(in) :: date_time_string ! format: YYYYMMDD_HHMMSSz - character( *), intent(in) :: obs_param_descr - character( *), intent(in) :: subroutine_name - character( *), intent(in) :: num_obs_string - character(*), intent(in) :: file_name - - ! obslog file format (comma-separated values; CSV): - ! - ! analysis time, obs species descriptor, subroutine name, obs_count, file name - - write (unitnum_obslog,'(500A)') & - date_time_string // ', ' // & - trim(obs_param_descr) // ', ' // & - trim(subroutine_name) // ', ' // & - num_obs_string // ', ' // & - trim(file_name) - - end subroutine add_to_obslog - - ! ***************************************************************** - - subroutine get_tile_num_for_obs(N_catd, tile_coord, & - tile_grid, N_tile_in_cell_ij, tile_num_in_cell_ij, N_latlon, lat, lon, & - this_obs_param, & - tile_num, & - shift_lat, shift_lon ) - - ! find one tile for each obs that "administers" the obs - ! - ! designed to work only for a vector of obs from a *single* species - ! (to be called from within obs readers) - ! - ! - reichle, 2015/02/20 - - implicit none - - integer, intent(in) :: N_catd, N_latlon - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid - - integer, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(in) :: N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - real, dimension(N_latlon), intent(in) :: lat, lon - - type(obs_param_type), intent(in) :: this_obs_param - - integer, dimension(N_latlon), intent(out) :: tile_num - - real, optional, intent(in) :: shift_lat - real, optional, intent(in) :: shift_lon - - ! ------------------------ - - ! local variables - - real, dimension(N_latlon) :: max_dist_x ! vector [deg] - real :: max_dist_y ! scalar [deg] - - character(len=*), parameter :: Iam = 'get_tile_num_for_obs' - - real, dimension(N_latlon) :: tmp_lon, tmp_lat - - ! ----------------------------------------------------------------------------- - ! - ! get "max_dist" in deg lat/lon from field-of-view (FOV) - ! - ! "max_dist" = Maximum distance allowed between obs lat/lon and tile com_lat/com_lon - ! when searching for a tile to which the obs will be assigned. - ! - ! NOTE: Subroutine get_tile_num_from_latlon() computes distances in Minkowski norm. - - if ( trim(this_obs_param%FOV_units)=='deg' ) then - - max_dist_y = this_obs_param%FOV - max_dist_x = this_obs_param%FOV - - elseif ( trim(this_obs_param%FOV_units)=='km' ) then - - ! convert from [km] (FOV) to [deg] (max_dist_*) - - call dist_km2deg( this_obs_param%FOV, N_latlon, lat, max_dist_x, max_dist_y ) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units') - - end if - - if (max_dist_y<0. .or. any(max_dist_x<0.)) & - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'encountered negative max_dist') - - - ! SMAP 36 km EASE grid readers require special accommodation: - ! - ! temporarily shift lat/lon of obs for computation of nearest tile to - ! avoid ambiguous assignment of M09 model tile within M36 obs grid cell - ! (center of M36 grid cell is equidistant from at least two M09 model - ! tiles) -- reichle, 23 Aug 2013 - - tmp_lat = lat - tmp_lon = lon - - if (present(shift_lat)) tmp_lat = tmp_lat + shift_lat - if (present(shift_lon)) tmp_lon = tmp_lon + shift_lon - - - ! find tile numbers - - call get_tile_num_from_latlon(N_catd, tile_coord, & - tile_grid, N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_latlon, tmp_lat, tmp_lon, & - tile_num, max_dist_x, max_dist_y ) - - - end subroutine get_tile_num_for_obs - - ! ***************************************************************** - -end module clsm_ensupd_read_obs - -#if 0 - -! test programs - -program test - - use clsm_ensupd_read_obs - - implicit none - - integer, parameter :: N_files = 3 - - character(200), parameter :: fpath = & - '/land/l_data/AMSR/data/AMSR_E_L2_Land_V001/2002/M09/' - character(37), dimension(N_files), parameter :: fname = (/ & - 'AMSR_E_L2_Land_B01_200209050129_A.hdf', & - 'AMSR_E_L2_Land_B01_200209091008_D.hdf', & - 'AMSR_E_L2_Land_B01_200209092002_D.hdf' /) - - integer :: N_data - - real, dimension(:), pointer :: lon, lat, ae_l2_sm - - character(300), dimension(N_files) :: infiles - - integer :: i - - do i=1,N_files - - infiles(i) = trim(fpath) // trim(fname(i)) - - end do - - call read_ae_l2_sm_hdf(N_files, infiles, N_data, lon, lat, ae_l2_sm ) - - write (*,*) 'N_data = ', N_data - - do i=1,3 - write (*,*) i, lon(i), lat(i), ae_l2_sm(i) - end do - - do i=N_data-2,N_data - write (*,*) i, lon(i), lat(i), ae_l2_sm(i) - end do - -end program test - -#endif - -! ******* EOF ************************************************************* - diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_upd_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_upd_routines.F90 deleted file mode 100644 index c8398b61..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/clsm_ensupd_upd_routines.F90 +++ /dev/null @@ -1,5690 +0,0 @@ -! this file contains a collection of subroutines that are needed to -! run the Ensemble Kalman filter with the catchment model off-line driver -! -! reichle, 10 Apr 01 -! - -module clsm_ensupd_upd_routines - - use nr_ran2_gasdev, ONLY: & - NRANDSEED - - use MAPL_BaseMod, ONLY: & - MAPL_UNDEF, & - MAPL_LAND - - use MAPL_ConstantsMod, ONLY: & - MAPL_TICE, & - MAPL_RADIUS, & - MAPL_PI, & - MAPL_ALHF - - use LDAS_ensdrv_Globals, ONLY: & - logit, & - logunit, & - nodata_generic, & - nodata_tol_generic - - use clsm_ensupd_glob_param, ONLY: & - N_obs_species_nml, & - unitnum_obslog, & - scale_temp, & - scale_catdef, & - scale_rzexc, & - scale_srfexc, & - scale_ght1, & - FT_ANA_FT_THRESHOLD, & - FT_ANA_LOWERBOUND_ASNOW, & - FT_ANA_LOWERBOUND_TEFF, & - FT_ANA_UPPERBOUND_TEFF, & - SCF_ANA_ALPHA, & - SCF_ANA_BETA, & - SCF_ANA_MAXINCRSWE - - use my_matrix_functions, ONLY: & - row_variance, & - unique_rows_3col - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename, & - is_in_rectangle - - use LDAS_DateTimeMod, ONLY: & - date_time_type - - use catch_types, ONLY: & - cat_param_type, & - cat_progn_type, & - catprogn2wesn, & - catprogn2htsn, & - catprogn2ghtcnt, & - assignment (=), & - operator (+), & - operator (/) - - use enkf_types, ONLY: & - obs_type, & - obs_param_type, & - write_obs_param, & - N_obs_ang_max - - use LDAS_DriverTypes, ONLY: & - met_force_type - - use mwRTM_types, ONLY: & - mwRTM_param_type - - use LDAS_PertTypes, ONLY: & - pert_param_type, & - allocate_pert_param, & - deallocate_pert_param - - use LDAS_TileCoordType, ONLY: & - tile_coord_type, & - grid_def_type - - use LDAS_TilecoordRoutines, ONLY: & - get_tile_num_in_ellipse, & - get_number_of_tiles_in_cell_ij, & - get_tile_num_in_cell_ij, & - get_minExtent_grid, & - get_ij_ind_from_latlon - - use land_pert_routines, ONLY: & - get_pert - - use mwRTM_routines, ONLY: & - mwRTM_get_Tb, & - catch2mwRTM_vars - - use catchment_model, ONLY: & - catch_calc_tsurf, & - catch_calc_tsurf_excl_snow - - use lsm_routines, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght, & - catch_calc_FT - - use catch_constants, ONLY: & - N_snow => CATCH_N_SNOW, & - N_gt => CATCH_N_GT, & - RHOFS => CATCH_SNOW_RHOFS, & - CATCH_SNOW_DZPARAM, & - PEATCLSM_POROS_THRESHOLD - - use SurfParams, ONLY: & - WEMIN - - use STIEGLITZSNOW, ONLY: & - StieglitzSnow_calc_asnow, & - StieglitzSnow_calc_tpsnow, & - StieglitzSnow_relayer, & - StieglitzSnow_CPW, & - StieglitzSnow_MINSWE, & - N_constit - - use LDAS_ensdrv_mpi, ONLY: & - numprocs, & - myid, & - mpicomm, & - MPI_obs_type, & - mpistatus, & - mpierr - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use enkf_general, ONLY: & - enkf_increments - - ! ----------------------------------------------------------------------- - - implicit none - - include 'mpif.h' - - private - - public :: read_ens_upd_inputs - public :: finalize_obslog - public :: get_cat_progn_ens_avg - public :: get_obs_pred - public :: get_halo_obs - public :: get_obs_pert - public :: cat_enkf_increments - public :: get_ind_obs_assim - public :: get_ind_obs_lat_lon_box - public :: get_halo_around_tile - public :: TileNnzObs - public :: dist_km2deg - - ! threshold below which FOV is considered zero (regardless of units) - - real, parameter, public :: FOV_threshold = 1e-4 - - type, public :: halo_type - real :: minlon, minlat, maxlon, maxlat - end type halo_type - -contains - - ! ******************************************************************** - - subroutine read_ens_upd_inputs( & - work_path, & - exp_id, & - date_time, & - N_catf, tile_coord_f, & - N_progn_pert, progn_pert_param, & - N_force_pert, force_pert_param, & - need_mwRTM_param, & - update_type, & - xcompact, ycompact, & - fcsterr_inflation_fac, & - N_obs_param, & - obs_param, & - out_obslog, & - out_ObsFcstAna, & - out_smapL4SMaup, & - N_obsbias_max & - ) - - ! read EnKF inputs from namelist file - ! - ! runtime options are read in three steps: - ! - ! 1.) read options from default namelist file called - ! ens_upd_inputs.nml in working directory (must be present) - ! - ! 2.) overwrite options from special namelist file (if present) - ! specified at the command line using -ens_upd_inputs_path - ! and -ens_upd_inputs_file - ! - ! reichle, 19 Jul 2005 - ! reichle, 14 Apr 2006 - added "update_type" to namelist and outputs - ! - removed reading from "stored"/"saved" nml file - ! reichle, 27 Mar 2014 - added "obslog" - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: N_catf, N_progn_pert, N_force_pert - - type(tile_coord_type), dimension(N_catf), intent(in) :: tile_coord_f - - type(pert_param_type), dimension(N_progn_pert), intent(in) :: progn_pert_param - type(pert_param_type), dimension(N_force_pert), intent(in) :: force_pert_param - - logical, intent(inout) :: need_mwRTM_param - - integer, intent(out) :: update_type - - real, intent(out) :: xcompact, ycompact - real, intent(out) :: fcsterr_inflation_fac - - integer, intent(out) :: N_obs_param - - type(obs_param_type), dimension(:), pointer :: obs_param ! output - - logical, intent(out) :: out_obslog - logical, intent(out) :: out_ObsFcstAna - logical, intent(out) :: out_smapL4SMaup - - integer, intent(out) :: N_obsbias_max - - ! ------------------------ - - ! locals - - ! frequency range for determining "need_mwRTM_param" - - real, parameter :: min_freq = 1.e9 ! GHz ! include L-band (SMOS, SMAP) - real, parameter :: max_freq = 10.e9 ! GHz ! include X-band (TRMM, AMSR-E) - - ! tolerance for checking xcorr against FOV (xcorr + tol >= "FOV") - - real, parameter :: tol = 1.e-5 ! units of deg lat/lon - - character(300) :: fname - - character(200) :: ens_upd_inputs_path - character( 40) :: ens_upd_inputs_file, dir_name, file_tag, file_ext - - integer :: i, j, k, N_tmp, k_hD, k_hA, k_vD, k_vA - - real :: r_y - - real, dimension(1) :: tmp_lat, r_x - - logical :: smap_species, smos_species - - type(obs_param_type), dimension(N_obs_species_nml) :: obs_param_nml - - character(len=*), parameter :: Iam = 'read_ens_upd_inputs' - character(len=400) :: err_msg - character(len= 6) :: tmpstring6 - logical :: file_exists - - ! ----------------------------------------------------------------- - - namelist /ens_upd_inputs/ & - update_type, & - out_obslog, & - out_ObsFcstAna, & - out_smapL4SMaup, & - xcompact, ycompact, & - fcsterr_inflation_fac, & - obs_param_nml - - ! ------------------------------------------------------------------ - ! - ! Set default file name for EnKF inputs namelist file - - ens_upd_inputs_path = '.' ! set default - ens_upd_inputs_file = 'LDASsa_DEFAULT_inputs_ensupd.nml' - - ! Read data from default ens_upd_inputs namelist file - - fname = trim(ens_upd_inputs_path) // '/' // trim(ens_upd_inputs_file) - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *default* EnKF inputs from ' // trim(fname) - if (logit) write (logunit,*) - - read (10, nml=ens_upd_inputs) - - close(10,status='keep') - - - ! Get name and path for special EnKF inputs file from - ! command line (if present) - - ens_upd_inputs_path = '.' - ens_upd_inputs_file = 'LDASsa_SPECIAL_inputs_ensupd.nml' - - ! Read data from special EnKF inputs namelist file - - fname = trim(ens_upd_inputs_path)//'/'//trim(ens_upd_inputs_file) - inquire(file=fname, exist=file_exists) - - if(file_exists) then - - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (logit) write (logunit,*) - if (logit) write (logunit,'(400A)') 'reading *special* EnKF inputs from ' // trim(fname) - if (logit) write (logunit,*) - - read (10, nml=ens_upd_inputs) - - close(10,status='keep') - - end if - - ! --------------------------------- - - ! overwrite EnKF inputs with command line options, if any - ! - ! none implemented so far (reichle, 19 Jul 2005) - - ! ----------------------------------------------------------------- - ! - ! consistency checks etc - - if (update_type==0) then - err_msg = 'executable was built for assimilation but update_type=0' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - N_obsbias_max = 0 ! initialize - - do i=1,N_obs_species_nml - - ! make sure "getinnov" is .true. if innovations are needed for state - ! or obs bias updates - - if ( obs_param_nml(i)%assim .or. obs_param_nml(i)%bias_Npar>0 ) & - obs_param_nml(i)%getinnov = .true. - - ! determine maximum "bias_Npar" - - N_obsbias_max = max( N_obsbias_max, obs_param_nml(i)%bias_Npar ) - - end do - - ! ----------------------------------------------------------------- - ! - ! Extract only species of interest (i.e., %getinnov=.true.) from nml inputs: - ! - ! NOTE: multi-angular obs (eg, SMOS Tb h-pol ascending) are defined - ! as *one* species obs_param_nml in namelist file and are - ! split here into a new set of species, each with a unique incidence angle - - ! first loop: count number of species of interest (those with %getinnov=.true.) - - j = 0 - - do i=1,N_obs_species_nml - - if (obs_param_nml(i)%getinnov) then - - N_tmp = max( obs_param_nml(i)%N_ang, 1 ) ! some species have N_ang=0 - - j = j + N_tmp - - end if - - end do - - N_obs_param = j - - allocate(obs_param(N_obs_param)) - - ! second loop: extract species of interest - - j = 0 - - do i=1,N_obs_species_nml - - if (obs_param_nml(i)%getinnov) then - - ! check for consistency between "varname" and "RTMid" - - if ( (trim(obs_param_nml(i)%varname)=='Tb') .and. & - ( obs_param_nml(i)%RTM_ID == 0 ) ) then - - write (tmpstring6,*) i - - err_msg = 'inconsistent obs_param_nml%varname and obs_param_nml%RTM_ID ' - err_msg = trim(err_msg) // 'in ensupd nml inputs for species=' // tmpstring6 - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! extract species into obs_param - - N_tmp = max( obs_param_nml(i)%N_ang, 1 ) - - do k=1,N_tmp - - j = j + 1 - - obs_param(j) = obs_param_nml(i) ! inherit everything - - obs_param(j)%species = j ! provide unique species ID - - obs_param(j)%N_ang = 1 ! overwrite N_ang - - obs_param(j)%ang(1) = obs_param_nml(i)%ang(k) ! overwrite ang(1) - - obs_param(j)%ang(2:N_obs_ang_max) = nodata_generic ! fill rest with nodata - - end do - - end if - - end do - - ! ----------------------------------------------------------------- - ! - ! echo variables of ens_upd_inputs - - if (logit) write (logunit,*) 'EnKF inputs are:' - if (logit) write (logunit,*) - if (logit) write (logunit, nml=ens_upd_inputs) - if (logit) write (logunit,*) - - ! ----------------------------------------------------------------- - ! - ! more consistency checks (only done on species of interest) - - do i=1,N_obs_param - - ! check xcorr, ycorr (spatial correlation scale of obs error) - ! against some measure of FOV - - ! get FOV in units of [deg] - - if ( trim(obs_param(i)%FOV_units)=='deg' ) then - - r_x(1) = obs_param(i)%FOV - r_y = obs_param(i)%FOV - - elseif ( trim(obs_param(i)%FOV_units)=='km' ) then - - ! compute FOV in units of [deg] at (area-weighted) average abs latitude of tiles - - tmp_lat(1) = sum( abs(tile_coord_f%com_lat) * tile_coord_f%area )/sum(tile_coord_f%area) - - call dist_km2deg( obs_param(i)%FOV, 1, tmp_lat, r_x, r_y ) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units') - - end if - - ! enforce (xcorr >= "FOV") and (ycorr >= "FOV") (with some tolerance) - - if ( ( obs_param(i)%xcorr < (r_x(1) - tol) ) .or. & - ( obs_param(i)%ycorr < (r_y - tol) ) ) then - - if (logit) write (logunit,*) 'i = ', i - if (logit) write (logunit,*) 'obs_param(i)%xcorr = ', obs_param(i)%xcorr - if (logit) write (logunit,*) 'obs_param(i)%ycorr = ', obs_param(i)%ycorr - if (logit) write (logunit,*) 'r_x(1) = ', r_x(1) - if (logit) write (logunit,*) 'r_y = ', r_y - - err_msg = 'found xcorr= min_freq ) .and. & - ( obs_param(i)%freq <= max_freq ) ) then - - need_mwRTM_param = .true. - - end if - - end do - - end if - - ! when L4SMaup files are written, ensure that species of interest do not - ! simultaneously include "SMAP_L*_Tb*" and "SMOS_fit_Tb*" obs - - if (out_smapL4SMaup) then - - smap_species = .false. - smos_species = .false. - - do i=1,N_obs_param - - select case (trim(obs_param(i)%descr)) - - case('SMAP_L2AP_Tbh_D', 'SMAP_L2AP_Tbv_D', & - 'SMAP_L2AP_Tbh_A', 'SMAP_L2AP_Tbv_A', & - 'SMAP_L1C_Tbh_D', 'SMAP_L1C_Tbv_D', & - 'SMAP_L1C_Tbh_A', 'SMAP_L1C_Tbv_A', & - 'SMAP_L1C_Tbh_E09_D', 'SMAP_L1C_Tbv_E09_D', & - 'SMAP_L1C_Tbh_E09_A', 'SMAP_L1C_Tbv_E09_A', & - 'SMAP_L1C_Tbh_E27_D', 'SMAP_L1C_Tbv_E27_D', & - 'SMAP_L1C_Tbh_E27_A', 'SMAP_L1C_Tbv_E27_A' & - ) - - smap_species = .true. - - - case('SMOS_fit_Tbh_D', 'SMOS_fit_Tbv_D', & - 'SMOS_fit_Tbh_A', 'SMOS_fit_Tbv_A' & - ) - - smos_species = .true. - - case default - - ! do nothing - - end select - - end do - - ! stop if SMAP and SMOS species are present simultaneously - - if (smap_species .and. smos_species) then - - err_msg = 'out_smapL4SMaup=.true. is *not* compatible with ' // & - 'simultaneously using "SMAP_L*_Tb*" and "SMOS_fit_Tb*"' // & - 'obs species. Use "out_ObsFcstAna" or remove either' // & - 'SMAP or SMOS obs species.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end if - - ! stop if two or more SMAP L1C Tb sub-species of same polarization and orbit - ! direction are assimilated (it is ok to have more than one as passive obs) - - k_hD=0 - k_hA=0 - k_vD=0 - k_vA=0 - - ! count number of assimilated L1C Tb sub-species (per polarization and orbit dir) - - do i=1,N_obs_param - - if (obs_param(i)%assim) then - - select case (trim(obs_param(i)%descr)) - - case('SMAP_L1C_Tbh_D','SMAP_L1C_Tbh_E09_D','SMAP_L1C_Tbh_E27_D'); k_hD=k_hD+1 - case('SMAP_L1C_Tbh_A','SMAP_L1C_Tbh_E09_A','SMAP_L1C_Tbh_E27_A'); k_hA=k_hA+1 - case('SMAP_L1C_Tbv_D','SMAP_L1C_Tbv_E09_D','SMAP_L1C_Tbv_E27_D'); k_vD=k_vD+1 - case('SMAP_L1C_Tbv_A','SMAP_L1C_Tbv_E09_A','SMAP_L1C_Tbv_E27_A'); k_vA=k_vA+1 - - end select - - end if - - end do - - if (k_hD>1 .or. k_hA>1 .or. k_vD>1 .or. k_vA>1) then - - err_msg = & - 'for given polarization and orbit dir must not assimilate ' // & - 'more than one of L1C_Tb, L1C_Tb E09, L1C_Tb E27' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - - - ! ------------------------------------------------------------- - ! - ! save ens update inputs into *ens_upd_inputs.nml file - - dir_name = 'rc_out' - file_tag = 'ldas_ensupd_inputs' - file_ext = '.nml' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') 'writing ens upd inputs to ' // trim(fname) - if (logit) write (logunit,*) - - open (10, file=fname, status='new', action='write', delim='apostrophe' ) - - write(10, nml=ens_upd_inputs) - - close(10, status='keep') - - ! ------------------------------------------------------------- - ! - ! save obs_param into *obsparam.txt file - - dir_name = 'rc_out' - file_tag = 'ldas_obsparam' - file_ext = '.txt' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') 'writing obs parameters to ' // trim(fname) - if (logit) write (logunit,*) - - open (10, file=fname, status='new', action='write', delim='apostrophe' ) - - call write_obs_param( 10, N_obs_param, obs_param) - - close(10, status='keep') - - ! ------------------------------------------------------------------------- - ! - ! if requested, open obslog file and write header - - if (out_obslog) call init_obslog( work_path, exp_id, date_time ) - - ! ------------------------------------------------------------- - - end subroutine read_ens_upd_inputs - - ! ******************************************************************** - - subroutine init_obslog( work_path, exp_id, date_time ) - - ! open obslog file and write header - - implicit none - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - ! local variables - - character(300) :: fname - character( 40) :: dir_name, file_tag, file_ext - - integer :: istat - - logical :: is_open - - character(len=*), parameter :: Iam = 'init_obslog' - character(len=400) :: err_msg - - ! ---------------------------------------------------------------------------- - - dir_name = 'rc_out' - file_tag = 'ldas_obslog' - file_ext = '.txt' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - ! make sure "unitnum_obslog" is not already in use - - inquire( unit=unitnum_obslog, opened=is_open ) - - if (is_open) then - err_msg = '"unitnum_obslog" is taken, edit src code ' // & - 'to automatically detect suitable "unitnum_obslog"' - end if - - ! open "obslog" file and write header lines - - open( unitnum_obslog, file=fname, form='formatted', action='write', iostat=istat) - - if (istat/=0) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'cannot open "obslog" file') - end if - - if (logit) write (logunit,'(400A)') 'writing header of obslog file: ' // trim(fname) - if (logit) write (logunit,*) - - ! header line 1 -- objective and guidance - - write (unitnum_obslog,'(200A)') & - 'Obs log for EnKF analysis, includes obs counts and file names ' // & - 'from which obs have been read. Obs count is *after* initial, ' // & - 'obs-based QC and *before* model-based QC. ' - - ! header line 2 -- warnings - - write (unitnum_obslog,'(200A)') & - 'IMPORTANT: Provides log ONLY for select obs species/readers! ' // & - 'SMAP L1C_Tb obs have not yet been cross-masked against L2AP_Tb obs!' - - ! header line 3 -- file format - - write (unitnum_obslog,'(200A)') & - 'Format (comma-separated values; last line: "EOF"): ' // & - 'EnKF analysis time [YYYYMMDD_HHMMSSz], obs species descriptor, ' // & - 'subroutine name, obs_count, file name' - - ! obslog file remains open (similar to "logunit") - - end subroutine init_obslog - - ! ******************************************************************** - - subroutine finalize_obslog() - - ! finalize and close "obslog" file - - implicit none - - write (unitnum_obslog,'(3A)') 'EOF' - - close (unitnum_obslog, status='keep') - - if (logit) write(logunit,*) 'done writing obslog file' - - end subroutine finalize_obslog - - ! ******************************************************************** - - subroutine get_cat_progn_ens_avg(N_catd, N_ens, cat_progn, cat_progn_ensavg) - - implicit none - - integer, intent(in) :: N_catd, N_ens - - type(cat_progn_type), dimension(N_catd,N_ens), intent(in) :: cat_progn - - type(cat_progn_type), dimension(N_catd), intent(out) :: cat_progn_ensavg - - ! locals - - integer :: i, n_e - - ! ------------------------------------- - - do i=1,N_catd - - cat_progn_ensavg(i) = 0. - - do n_e=1,N_ens - - cat_progn_ensavg(i) = cat_progn_ensavg(i) + cat_progn(i,n_e) - - end do - - cat_progn_ensavg(i) = cat_progn_ensavg(i)/real(N_ens) - - end do - - end subroutine get_cat_progn_ens_avg - - ! ********************************************************************* - - ! subroutine recompute_diagnostic( ) - ! - ! moved to clsm_ensdrv_drv_routines.F90 - ! -reichle+csdraper, 30 Oct 2013 - ! - ! end subroutine recompute_diagnostic - - ! ******************************************************************** - - subroutine assemble_obs_cov(N_obs, N_obs_param, obs_param, Observations, Obs_cov) - - ! assemble measurements error covariance - - ! reichle, 27 Jul 2005 - - implicit none - - integer, intent(in) :: N_obs, N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(obs_type), dimension(N_obs), intent(in) :: Observations - - real, intent(out), dimension(N_obs,N_obs) :: Obs_cov - - ! ------------------------------------------------------------- - - ! locals - - integer :: i, j, i_species, j_species !! inum, jnum - - real :: fac, xcorr_tmp, ycorr_tmp - - ! ------------------------------------------------------------- - - if (N_obs==0) return - - ! assemble measurement error covariance - - ! initialize - - Obs_cov = 0. - - ! diagonal elements - - do i=1,N_obs - - Obs_cov(i,i) = Observations(i)%obsvar - - end do - - ! off-diagonal elements - - do i=1,N_obs - do j=(i+1),N_obs - - i_species = Observations(i)%species - j_species = Observations(j)%species - - ! have non-zero correlation only between observations of same type - - if (i_species == j_species) then - - xcorr_tmp = obs_param(i_species)%xcorr - ycorr_tmp = obs_param(i_species)%ycorr - - ! check for zero correlation distance - - if (xcorr_tmp>0. .and. ycorr_tmp>0.) then - - ! compute correlation between observation locations - - !!inum = Observations(i)%tilenum - !!jnum = Observations(j)%tilenum - - ! compute Gaussian correlation - - !!fac = & - !! ((tile_coord(inum)%com_lon-tile_coord(jnum)%com_lon)**2 & - !! /xcorr_tmp**2 ) & - !! + & - !! ((tile_coord(inum)%com_lat-tile_coord(jnum)%com_lat)**2 & - !! /ycorr_tmp**2 ) - - fac = & - ((Observations(i)%lon-Observations(j)%lon)**2 & - /xcorr_tmp**2 ) & - + & - ((Observations(i)%lat-Observations(j)%lat)**2 & - /ycorr_tmp**2 ) - - fac = exp(-.5*fac) - - ! bug fix - ! GDL+reichle, 17 Oct 2014 - !Obs_cov(i,j) = Observations(i)%obsvar * fac - Obs_cov(i,j) = sqrt(Observations(i)%obsvar * Observations(j)%obsvar) * fac - - Obs_cov(j,i) = Obs_cov(i,j) - - end if - end if - - end do - end do - - end subroutine assemble_obs_cov - - ! ********************************************************************* - - subroutine get_obs_pred( & - beforeEnKFupdate, & - N_obs_param, N_ens, & - N_catl, tile_coord_l, & - N_catf, tile_coord_f, f2l, & - N_catl_vec, low_ind, tile_grid_g, & - obs_param, & - met_force, lai, cat_param, cat_progn, mwRTM_param, & - N_obsl, Observations_l, Obs_pred_l, obsbias_ok, & - fcsterr_inflation_fac ) - - ! Compute ensemble of measurement predictions from ensemble - ! of tile-space Catchment prognostics. - ! Return only those Observations that pass model-based QC. - ! - ! Overview: - ! 1.) Determine which diagnostics are needed. - ! 2.) Compute diagnostics for local domain, apply model-based QC. - ! 3.) Get diagnostics from processors within halo. - ! 4.) Aggregate from tile space to obs space. - ! 5.) Deal with no-data-values, compute ens mean and var of Obs_pred. - ! - ! - ! 27 Jul 2005 - ! 7 Jul 2006 - reichle: use temporary dimension(1) vectors for Absoft - ! 13 Jun 2011 - reichle: re-structured for MPI - ! added field-of-view (FOV) for observations - ! moved model-based QC here (from read_obs()) - ! 1 Dec 2011 - reichle: added QC for Tb vs. model *soil* temp (RFI-motivated) - ! 18 Jun 2012 - reichle: rewritten for better memory management w/ MPI - ! 26 Mar 2014 - reichle: apply all model-based QC only before EnKF update - ! 25 Sep 2020 - wjiang+reichle: accommodate processors that have no tiles - - implicit none - - logical, intent(in) :: beforeEnKFupdate - - integer, intent(in) :: N_obs_param, N_ens - integer, intent(in) :: N_catl, N_catf - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l ! input - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! input - - integer, intent(in), dimension(numprocs) :: N_catl_vec, low_ind - - type(grid_def_type), intent(in) :: tile_grid_g - - type(obs_param_type), intent(in), dimension(N_obs_param) :: obs_param - - integer, intent(in), dimension(N_catf) :: f2l - type(met_force_type), intent(in), dimension(N_catl) :: met_force - real, intent(in), dimension(N_catl) :: lai - type(cat_param_type), intent(in), dimension(N_catl) :: cat_param - type(cat_progn_type), intent(in), dimension(N_catl,N_ens) :: cat_progn - type(mwRTM_param_type), intent(in), dimension(N_catl) :: mwRTM_param - - integer, intent(inout) :: N_obsl ! InOut !!! - - type(obs_type), dimension(:), pointer :: Observations_l ! InOut - - real, dimension(:,:), pointer :: Obs_pred_l ! output - - logical, intent(in), dimension(N_obsl), optional :: obsbias_ok - - real, intent(in), optional :: fcsterr_inflation_fac - - ! -------------------------------------------------------------------------------- - ! - ! locals - - real, parameter :: Tbobs_minus_stemp_max = 5. ! [K] - - real, parameter :: fac_search_FOV_km = 2. ! [-] - - real, parameter :: EASE_max_water_frac = 0.05 ! [-] - - integer :: N_catlH, n_e, i, j, k, N_tmp, ii, jj - integer :: N_fields, N_Tbspecies, N_TbuniqFreqAngRTMid - integer :: this_species, this_tilenum, this_pol - integer :: this_Tbspecies, this_TbuniqFreqAngRTMid, RTM_id - integer :: istart, iend - - real :: this_lon, this_FOV, r_y - real, dimension(1) :: this_lat, r_x - - real :: freq, inc_angle - - real, dimension(numprocs) :: xhalo, yhalo, tmplatvec, tmprx - - real :: tmpreal, tmp_stemp, tmp_fraccell - - logical :: tmpRFI, tmpWater, use_distance_weights - - real, dimension(1) :: tmpmean, tmpvar - - logical :: get_sfmc_l, get_sfmc_lH - logical :: get_rzmc_l, get_rzmc_lH - logical :: get_tsurf_l, get_tsurf_lH - logical :: get_tp_l - logical :: get_Tb_l, get_Tb_lH - logical :: get_FT_l, get_FT_lH - logical :: get_asnow_l, get_asnow_lH - type(grid_def_type) :: tile_grid_lH - - integer, dimension(N_obs_param) :: ind_obsparam2Tbspecies - integer, dimension(N_obs_param) :: ind_Tbspecies2TbuniqFreqAngRTMid - - real, dimension(N_obs_param,3) :: Tb_freq_ang_RTMid - - ! dimension "N_catl" - - real, dimension(N_catl) :: srfexc, rzexc, catdef, prmc_l - - real, dimension(N_catl) :: ar1_l, ar2_l, ar4_l - - real, dimension(N_catl) :: asnow, tsurf_excl_snow - - real, dimension(N_gt,N_catl) :: tp_l ! NOTE dims: N_gt-by-N_catl - ! for consistency w/ calc_tp - - real, dimension(N_catl) :: Tb_h_vec, Tb_v_vec - - real, dimension(N_catl) :: precip, SWE, smoist - - ! dimension "N_catl-[by-N_XXXX-]by-N_ens" - ! (need to be communicated between processors) - - real, dimension(N_catl,N_ens) :: sfmc_l, rzmc_l - real, dimension(N_catl,N_ens) :: tsurf_l, stemp_l - real, dimension(N_catl,N_ens) :: FT_l, asnow_l - - real, dimension(:,:,:), allocatable :: Tb_h_l, Tb_v_l - - real, dimension(:,:,:), allocatable :: tile_data_l - - ! dimension "N_catlH" - - type(tile_coord_type), dimension(:), pointer :: tile_coord_lH => null() - - integer, dimension(:), allocatable :: ind_tmp - - real, dimension(:), allocatable :: tmp_ndst2, tmp_wFOV, tmp_weights, tmp_data - - ! dimension "N_catlH-[by-N_XXXX-]by-N_ens" - ! (need to be communicated between processors) - - real, dimension(:,:), allocatable :: sfmc_lH, rzmc_lH - real, dimension(:,:), allocatable :: tsurf_lH, stemp_lH - real, dimension(:,:), allocatable :: FT_lH, asnow_lH - - real, dimension(:,:,:), allocatable :: Tb_h_lH, Tb_v_lH - - real, dimension(:,:,:), pointer :: tile_data_lH => null() - - ! dimension "N_catlH-by-OTHER" - - integer, dimension(:,:), pointer :: N_tile_in_cell_ij_lH => null() - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij_lH => null() - - ! dimension "N_obsl" (as in N_obsl upon input) - - logical, dimension(N_obsl) :: obsbias_ok_tmp - - real :: inflation_factor - - character(len=*), parameter :: Iam = 'get_obs_pred' - character(len=400) :: err_msg - - ! -------------------------------------------------------------- - ! - ! allocate and initialize - - allocate(Obs_pred_l(N_obsl,N_ens)) - - if (N_catl == 0) return ! return if processor has no tiles - - if (N_obsl > 0) Obs_pred_l = nodata_generic - - ! deal with optional arguments - - if (present(obsbias_ok)) then - - obsbias_ok_tmp = obsbias_ok - - else - - obsbias_ok_tmp = .false. - - end if - - if (present(fcsterr_inflation_fac) .and. beforeEnKFupdate) then - - ! ONLY inflate *before* EnKF update!!! - - inflation_factor = fcsterr_inflation_fac - - else - - inflation_factor = -9999. - - end if - - ! -------------------------------------------------------------- - ! - ! determine which diagnostics are needed (based on obs_param because - ! observations on local proc may not reflect all obs) - - ! get_*_l : may include additional fields needed to compute observed fields - - get_sfmc_l = .false. - get_rzmc_l = .false. - get_tsurf_l = .false. - get_tp_l = .false. - get_FT_l = .false. - get_Tb_l = .false. - get_asnow_l = .false. - - ! get_*_lH : directly match observed fields - - get_sfmc_lH = .false. - get_rzmc_lH = .false. - get_tsurf_lH = .false. - get_FT_lH = .false. - get_Tb_lH = .false. - get_asnow_lH = .false. - - ! loop through obs_param b/c obs on local proc may not reflect all obs - - ind_obsparam2Tbspecies = -999 - - j = 0 - - do i=1,N_obs_param - - select case (trim(obs_param(i)%varname)) - - case ('sfmc', 'sfds') - - get_sfmc_l = .true. - get_sfmc_lH = .true. - get_tsurf_l = .true. ! needed for model-based QC - - case ('rzmc') - - get_rzmc_l = .true. - get_rzmc_lH = .true. - get_tsurf_l = .true. ! needed for model-based QC - - case ('tsurf') - - get_tsurf_l = .true. - get_tsurf_lH = .true. - get_tp_l = .true. ! needed for model-based QC - get_sfmc_l = .true. ! needed to get ar1, ar2, and ar4 - - case ('FT') - - get_FT_l = .true. - get_FT_lH = .true. - get_sfmc_l = .true. ! needed to get ar1, ar2, and ar4 - get_tp_l = .true. ! needed as input to calc_FT - - case ('Tb') - - j=j+1 ! count number of Tb species - - ind_obsparam2Tbspecies(i) = j - - Tb_freq_ang_RTMid(j,1) = obs_param(i)%freq - Tb_freq_ang_RTMid(j,2) = obs_param(i)%ang(1) - Tb_freq_ang_RTMid(j,3) = real(obs_param(i)%RTM_ID) - - get_sfmc_l = .true. - get_tsurf_l = .true. - get_tp_l = .true. - get_Tb_l = .true. - - get_Tb_lH = .true. - - case('asnow') - - get_asnow_l = .true. - get_asnow_lH = .true. - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown obs_param%varname') - - end select - - end do - - N_Tbspecies = j - - ! determine unique combinations of Tb frequency, angle, and RTM_ID - ! - ! Step 1: - ! determine unique combinations of Tb frequency and angle - ! (obs_param usually has separate species for H- and V-pol and - ! for ascending and descending orbits, but the mwRTM model - ! always provides both polarizations and does not depend on the - ! orbit direction --> avoid computing and communicating redundant - ! information) - - call unique_rows_3col( & - N_Tbspecies, Tb_freq_ang_RTMid(1:N_Tbspecies,:), & - N_TbuniqFreqAngRTMid, ind_Tbspecies2TbuniqFreqAngRTMid(1:N_Tbspecies) ) - - if (get_Tb_l) allocate(Tb_h_l(N_catl,N_TbuniqFreqAngRTMid,N_ens)) - if (get_Tb_l) allocate(Tb_v_l(N_catl,N_TbuniqFreqAngRTMid,N_ens)) - - ! ------------------------- - - ! determine xhalo, yhalo in units of [deg] based on some measure of FOV - - xhalo = 0. ! initialize - yhalo = 0. ! initialize - - ! for FOV_units in 'km', all processors need to know the xhalo of each processor, - ! which in turn depends on latitude - - tmplatvec = 0. - - do jj=1,numprocs - - if (N_catl_vec(jj) <= 0) cycle ! nothing to do for this processor - - istart = low_ind(jj) - iend = istart + N_catl_vec(jj) - 1 - - ! largest abs(lat) will have largest FOV - - tmplatvec(jj) = maxval( abs( tile_coord_f(istart:iend)%com_lat )) - - end do - - ! find maximum FOV in units of [deg] across all obs params - - do ii=1,N_obs_param - - if ( trim(obs_param(ii)%FOV_units)=='deg' ) then - - xhalo = max( xhalo, obs_param(ii)%FOV ) - yhalo = max( yhalo, obs_param(ii)%FOV ) - - elseif ( trim(obs_param(ii)%FOV_units)=='km' ) then - - ! convert from [km] (FOV) to [deg] - - call dist_km2deg( obs_param(ii)%FOV, numprocs, tmplatvec, tmprx, r_y ) - - ! for now, ignore what happens to xhalo for processors without tiles (fixed below) - - xhalo = max( xhalo, tmprx ) - yhalo = max( yhalo, r_y ) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units (i)') - - end if - - end do - - where (N_catl_vec<=0) xhalo = 0. ! set xhalo=0. for processors without tiles - - ! FOV is *radius*, leave some room - - xhalo = 2.5 * xhalo - yhalo = 2.5 * yhalo - - ! ------------------------------------------------------------------ - ! - ! compute required diagnostics for locally managed tiles - - precip = met_force%Rainf + met_force%Snowf ! for model-based QC - - do n_e=1,N_ens - - ! compute observed fields in tile space (for local domain) - - ! total SWE (for model-based QC) - - do k=1,N_catl - - SWE(k) = sum( cat_progn(k,n_e)%wesn(1:N_snow) ) - - end do - - if (get_sfmc_l .or. get_rzmc_l) then - - srfexc = cat_progn(:,n_e)%srfexc - rzexc = cat_progn(:,n_e)%rzexc - catdef = cat_progn(:,n_e)%catdef - - ! updated to new interface - reichle, 3 Apr 2012 - - call catch_calc_soil_moist( & - N_catl, cat_param%dzsf, cat_param%vgwmax, & - cat_param%cdcr1, cat_param%cdcr2, cat_param%psis, & - cat_param%bee, cat_param%poros, cat_param%wpwet, & - cat_param%ars1, cat_param%ars2, cat_param%ars3, & - cat_param%ara1, cat_param%ara2, cat_param%ara3, & - cat_param%ara4, cat_param%arw1, cat_param%arw2, & - cat_param%arw3, cat_param%arw4, & - cat_param%bf1, cat_param%bf2, & - srfexc, rzexc, catdef, & - ar1_l, ar2_l, ar4_l, & - sfmc_l(:,n_e), rzmc_l(:,n_e), prmc_l ) - - end if - - if (get_tsurf_l) then - - ! updated to new interface, - ! need ar1, ar2, ar4 from call to catch_calc_soil_moist() above - ! - reichle, 3 Apr 2012 - - call catch_calc_tsurf( N_catl, & - cat_progn(:,n_e)%tc1, cat_progn(:,n_e)%tc2, cat_progn(:,n_e)%tc4, & - catprogn2wesn(N_catl,cat_progn(:,n_e)), & - catprogn2htsn(N_catl,cat_progn(:,n_e)), & - ar1_l, ar2_l, ar4_l, & - tsurf_l(:,n_e) ) - - end if - - if (get_tp_l) then - - ! NOTE: "tp" is returned in CELSIUS [for consistency w/ catchment.F90] - - ! updated to new interface - reichle, 3 Apr 2012 - - call catch_calc_tp( N_catl, cat_param%poros, & - catprogn2ghtcnt(N_catl,cat_progn(:,n_e)), tp_l ) - - end if - - if (get_FT_l) then - - call StieglitzSnow_calc_asnow( N_snow, N_catl, & - catprogn2wesn(N_catl,cat_progn(:,n_e)), & - asnow ) - - call catch_calc_tsurf_excl_snow( N_catl, & - cat_progn(:,n_e)%tc1, cat_progn(:,n_e)%tc2, cat_progn(:,n_e)%tc4, & - ar1_l, ar2_l, ar4_l, tsurf_excl_snow ) - - ! catch_calc_FT() expects "tp" in CELSIUS - - call catch_calc_FT( N_catl, asnow, tp_l(1,:), tsurf_excl_snow, FT_l(:,n_e)) - - end if - - if (get_asnow_l) then - - call StieglitzSnow_calc_asnow( N_snow, N_catl, & - catprogn2wesn(N_catl,cat_progn(:,n_e)), & - asnow_l(:,n_e) ) - - end if - - if (get_Tb_l) then - - ! convert Catchment model variables into inputs suitable for the mwRTM - - call catch2mwRTM_vars( N_catl, cat_param%vegcls, cat_param%poros, & - mwRTM_param%poros, sfmc_l(:,n_e), tsurf_l(:,n_e), tp_l(1,:), & - smoist, stemp_l(:,n_e) ) - - ! calculate brightness temperatures - - do j=1,N_TbuniqFreqAngRTMid - - freq = Tb_freq_ang_RTMid(j,1) - inc_angle = Tb_freq_ang_RTMid(j,2) - RTM_id = nint(Tb_freq_ang_RTMid(j,3)) - - ! Select a specific configuration of the RTM via the field - ! "RTM_ID" in the "obs_param" type. - ! - ! %RTM_ID = ID of radiative transfer model to use for Tb forward modeling - ! (subroutine get_obs_pred()) - ! 0 = none - ! 1 = L-band tau-omega model as in De Lannoy et al. 2013 (doi:10.1175/JHM-D-12-092.1) (SMOS) - ! 2 = same as 1 but without Pellarin atm corr (SMAP) - ! 3 = same as 1 but with Mironov and SMAP L2_SM pol mixing (SMOS) - ! 4 = same as 3 but without Pellarin atm corr (targeted for SMAP L4_SM Version 8) - - call mwRTM_get_Tb( & - N_catl, freq, inc_angle, mwRTM_param, tile_coord_l%elev, & - lai, smoist, stemp_l(:,n_e), SWE, met_force%Tair, RTM_ID, & - Tb_h_vec, Tb_v_vec ) - - Tb_h_l(:,j,n_e) = Tb_h_vec - Tb_v_l(:,j,n_e) = Tb_v_vec - - end do - - end if - - ! ---------------------------------------------------------------- - ! - ! model-based QC in *l*ocal tile space: - ! - ! - overwrite obs_pred fields w/ no-data-values as needed - ! - whether QC is needed depends on get_*_lH (NOT get_*_l)! - ! - ! perform model-based QC only before the EnKF update - ! (not needed afterwards) - - if (beforeEnKFupdate) then - - if (get_sfmc_lH) & - call qc_model_based_for_sat_sfmc( N_catl, precip, SWE, tsurf_l(:,n_e), & - sfmc_l(:,n_e) ) - - if (get_tsurf_lH) & - call qc_model_based_for_sat_tsurf(N_catl, precip, SWE, tp_l(1,:), & - tsurf_l(:,n_e) ) - - if (get_Tb_lH) then - - do j=1,N_TbuniqFreqAngRTMid - - call qc_model_based_for_Tb( N_catl, precip, Tb_h_l(:,j,n_e) ) - call qc_model_based_for_Tb( N_catl, precip, Tb_v_l(:,j,n_e) ) - - end do - - end if - - end if - - end do ! loop through ens members - - ! ---------------------------------------------------------------- - ! - ! gather observed fields into local halo domain (for all processors) - - ! determine N_catlH and tile_coord_lH - - N_fields = 0 ! set to zero temporarily, not yet needed - ! move up the allocation. The input should be allocated in debug mode although it is not used - ! allocate and assemble tile_data_l - allocate(tile_data_l(0,0,0)) ! for debugging to pass - call get_tiles_in_halo( N_catl, N_fields, N_ens, tile_data_l, tile_coord_l, & - tile_coord_f, N_catl_vec, low_ind, xhalo, yhalo, & - N_catlH, tile_coord_lH=tile_coord_lH ) - - if (get_sfmc_lH) allocate(sfmc_lH( N_catlH, N_ens)) - if (get_rzmc_lH) allocate(rzmc_lH( N_catlH, N_ens)) - if (get_tsurf_lH) allocate(tsurf_lH(N_catlH, N_ens)) - if (get_FT_lH) allocate(FT_lH( N_catlH, N_ens)) - if (get_asnow_lH) allocate(asnow_lH(N_catlH, N_ens)) - if (get_Tb_lH) allocate(stemp_lH(N_catlH, N_ens)) - if (get_Tb_lH) allocate(Tb_h_lH( N_catlH,N_TbuniqFreqAngRTMid,N_ens)) - if (get_Tb_lH) allocate(Tb_v_lH( N_catlH,N_TbuniqFreqAngRTMid,N_ens)) - -#ifdef LDAS_MPI - - ! count number of fields that need to be communicated (N_fields), allocate as needed - - call get_obs_pred_comm_helper( N_catl, N_ens, N_TbuniqFreqAngRTMid, & - get_sfmc_lH, get_rzmc_lH, get_tsurf_lH, get_FT_lH, get_asnow_lH, get_Tb_lH, N_fields) - - ! allocate and assemble tile_data_l - - if (allocated(tile_data_l)) deallocate(tile_data_l) - allocate(tile_data_l(N_catl,N_fields,N_ens)) - call get_obs_pred_comm_helper( N_catl, N_ens, N_TbuniqFreqAngRTMid, & - get_sfmc_lH, get_rzmc_lH, get_tsurf_lH, get_FT_lH, get_asnow_lH, get_Tb_lH, N_fields, & - option=1, tile_data=tile_data_l, & - sfmc=sfmc_l, rzmc=rzmc_l, tsurf=tsurf_l, FT=FT_l, stemp=stemp_l, & - Tb_h=Tb_h_l, Tb_v=Tb_v_l, asnow=asnow_l ) - - ! communicate tile_data_l as needed and get tile_data_lH - - call get_tiles_in_halo( N_catl, N_fields, N_ens, tile_data_l, tile_coord_l, & - tile_coord_f, N_catl_vec, low_ind, xhalo, yhalo, & - N_catlH, tile_data_lH=tile_data_lH ) - - ! read out sfmc, rzmc, etc. from tile_data_lH - - call get_obs_pred_comm_helper( N_catlH, N_ens, N_TbuniqFreqAngRTMid, & - get_sfmc_lH, get_rzmc_lH, get_tsurf_lH, get_FT_lH, get_asnow_lH, get_Tb_lH, N_fields, & - option=2, tile_data=tile_data_lH, & - sfmc=sfmc_lH, rzmc=rzmc_lH, tsurf=tsurf_lH, asnow=asnow_lH, FT=FT_l, stemp=stemp_lH, & - Tb_h=Tb_h_lH, Tb_v=Tb_v_lH ) - - ! clean up - - if (associated(tile_data_lH)) deallocate(tile_data_lH) - -#else - - if (get_sfmc_lH) sfmc_lH = sfmc_l - if (get_rzmc_lH) rzmc_lH = rzmc_l - if (get_tsurf_lH) tsurf_lH = tsurf_l - if (get_FT_lH) FT_lH = FT_l - if (get_asnow_lH) asnow_lH = asnow_l - if (get_Tb_lH) stemp_lH = stemp_l - if (get_Tb_lH) Tb_h_lH = Tb_h_l - if (get_Tb_lH) Tb_v_lH = Tb_v_l - -#endif - if (allocated(tile_data_l)) deallocate(tile_data_l) - ! ---------------------------------------------------------------- - ! - ! Get additional grid/tile information that is needed to map from tile - ! to obs space - - if ( any(obs_param(1:N_obs_param)%FOV>FOV_threshold) ) then - - ! determine tile_grid_lH from tile_coord_lH - - tile_grid_lH = get_minExtent_grid( N_catlH, tile_coord_lH%pert_i_indg, tile_coord_lH%pert_j_indg,& - tile_coord_lH%min_lon, tile_coord_lH%min_lat, tile_coord_lH%max_lon, tile_coord_lH%max_lat, & - tile_grid_g) - - allocate(N_tile_in_cell_ij_lH(tile_grid_lH%N_lon,tile_grid_lH%N_lat)) - - ! first call: count how many tiles are in each tile_grid_lH cell - - call get_number_of_tiles_in_cell_ij( N_catlH, & - tile_coord_lH%pert_i_indg, tile_coord_lH%pert_j_indg, & - tile_grid_lH, N_tile_in_cell_ij_lH ) - - ! second call: find out which tiles are in each tile_grid_lH cell - ! [tile numbers in "tile_num_in_cell_ij_lH" are relative - ! to local halo ("lH") domain] - - call get_tile_num_in_cell_ij( N_catlH, & - tile_coord_lH%pert_i_indg, tile_coord_lH%pert_j_indg, & - tile_grid_lH, maxval(N_tile_in_cell_ij_lH), tile_num_in_cell_ij_lH ) - - end if - - ! ----------------------- - - allocate(ind_tmp( N_catlH)) - allocate(tmp_ndst2( N_catlH)) - allocate(tmp_wFOV( N_catlH)) - allocate(tmp_weights(N_catlH)) - allocate(tmp_data( N_catlH)) - - do i=1,N_obsl - - this_species = Observations_l(i)%species - - this_Tbspecies = ind_obsparam2Tbspecies(Observations_l(i)%species) - - if (this_Tbspecies>0) then - - this_TbuniqFreqAngRTMid = ind_Tbspecies2TbuniqFreqAngRTMid(this_Tbspecies) - - else - - this_TbuniqFreqAngRTMid = -999 - - end if - - this_tilenum = Observations_l(i)%tilenum ! tilenum w.r.t. "full" domain - - this_lon = Observations_l(i)%lon - this_lat(1) = Observations_l(i)%lat - - this_FOV = obs_param(this_species)%FOV - - this_pol = obs_param(this_species)%pol - - ! ---------------------------------------- - ! - ! map from full domain to this Observation - - use_distance_weights = .false. ! initialize - - if (this_FOV < FOV_threshold) then - - ! equate obs footprint with nearest tile - - N_tmp = 1 - - ind_tmp(1) = f2l(this_tilenum) ! requires that "lH" starts w/ "local" tiles - - else - - ! find all tiles w/in given distance from obs, see - ! LDASsa_DEFAULT_inputs_ensupd.nml for details! - - ! get appropriate distances in units of [deg] - - if ( trim(obs_param(this_species)%FOV_units)=='deg' ) then - - ! IMPORTANT: search distance is FOV when FOV_units='deg' !!! - - r_x(1) = this_FOV - r_y = this_FOV - - elseif ( trim(obs_param(this_species)%FOV_units)=='km' ) then - - ! convert from [km] (FOV) to [deg] - - ! IMPORTANT: search distance is fac_search_FOV_km*FOV when FOV_units='km' !!! - - call dist_km2deg( fac_search_FOV_km*this_FOV, 1, this_lat, r_x, r_y ) - - use_distance_weights = .true. - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units (ii)') - - end if - - call get_tile_num_in_ellipse( this_lon, this_lat(1), r_x(1), r_y, & - N_catlH, tile_coord_lH, tile_grid_lH, & - N_tile_in_cell_ij_lH, tile_num_in_cell_ij_lH, & - N_tmp, ind_tmp, tmp_ndst2 ) - - ! N_tmp could be zero (if ellipse straddles dateline) - ! - reichle, 17 Apr 2017 - - end if - - - if (N_tmp>0) then ! map from tiles to obs space - - ! compute weights based on tile area and (if applicable) based on distance from obs - - if (.not. use_distance_weights) then - - ! ignore tmp_weights from get_tile_num_in_ellipse(), - ! weights based only on tile area - - tmp_wFOV( 1:N_tmp) = 1. - - tmp_weights(1:N_tmp) = tile_coord_lH(ind_tmp(1:N_tmp))%area - - else - - ! use distance weights along with tile area weights - - ! convert normalized square distance "ndst2" from get_tile_num_in_ellipse() - ! into distance-based weights - - ! normalized distance from get_tile_num_in_ellipse() is relative to r_x and r_y, - ! first scale back so that distance is w.r.t. FOV - - tmp_ndst2( 1:N_tmp) = (fac_search_FOV_km**2) * tmp_ndst2(1:N_tmp) - - tmp_wFOV( 1:N_tmp) = exp( -0.5*tmp_ndst2(1:N_tmp) ) - - ! further adjust weights based on tile area - - tmp_weights(1:N_tmp) = tmp_wFOV(1:N_tmp) * tile_coord_lH(ind_tmp(1:N_tmp))%area - - end if - - do n_e=1,N_ens - - ! ----------------------------------------- - ! - ! fill Obs_pred with observed field, aggregated - ! from tiles as appropriate for this Observation - - select case (trim(obs_param(this_species)%varname)) - - case ('sfmc', 'sfds') - - tmp_data(1:N_tmp) = sfmc_lH( ind_tmp(1:N_tmp), n_e ) - - case ('rzmc') - - tmp_data(1:N_tmp) = rzmc_lH( ind_tmp(1:N_tmp), n_e ) - - case ('tsurf') - - tmp_data(1:N_tmp) = tsurf_lH( ind_tmp(1:N_tmp), n_e ) - - case ('FT') - - tmp_data(1:N_tmp) = FT_lH( ind_tmp(1:N_tmp), n_e ) - - case ('asnow') - - tmp_data(1:N_tmp) = asnow_lH( ind_tmp(1:N_tmp), n_e ) - - case('Tb') - - ! start with QC based on model *soil* temperature, motivated by RFI - ! (requires model estimates *and* observation together; - ! only performed before the EnKF update b/c not needed afterwards) - - if (beforeEnKFupdate) then - - tmp_data(1:N_tmp) = stemp_lH( ind_tmp(1:N_tmp), n_e ) - - call tile2obs_helper( & - N_tmp, tmp_weights(1:N_tmp), tmp_data(1:N_tmp), tmp_stemp) - - ! if Tb is too warm, RFI is likely - - tmpRFI = ((Observations_l(i)%obs-tmp_stemp) > Tbobs_minus_stemp_max) - - else - - tmpRFI = .false. - - end if - - ! for EASE grids *ONLY*: screen for non-land surfaces (e.g., lakes) - ! - reichle, 28 Mar 2015 - - if (index(tile_grid_g%gridtype, 'EASEv') /=0) then - - ! ASSUMPTIONS: - ! - at most one land tile per grid cell - ! - grid cells have the same area (or at least have nearly - ! identical areas in the surrounding region; that is, - ! a regular lat/lon grid with just one tile per grid - ! cell would be ok if that property could be asserted here) - - ! compute FOV-weighted average "frac_cell" - - tmp_data(1:N_tmp) = tile_coord_lH(ind_tmp(1:N_tmp))%frac_cell - - call tile2obs_helper( & - N_tmp, tmp_wFOV(1:N_tmp), tmp_data(1:N_tmp), tmp_fraccell) - - ! check whether there is too much non-land in FOV - ! (typically water, but could be land-ice) - - tmpWater = ( 1. - tmp_fraccell > EASE_max_water_frac ) - - else - - tmpWater = .false. - - end if - - - ! compute Obs_pred - - if (tmpRFI .or. tmpWater) then - - ! apply model-based QC (suspected RFI, too much non-land in FOV) - - tmp_data(1:N_tmp) = nodata_generic ! results in Obs_pred(i,n_e) = nodata - - else - - select case (this_pol) - - case (1) ! H-pol - - tmp_data(1:N_tmp) = Tb_h_lH( ind_tmp(1:N_tmp), this_TbuniqFreqAngRTMid, n_e) - - case (2) ! V-pol - - tmp_data(1:N_tmp) = Tb_v_lH( ind_tmp(1:N_tmp), this_TbuniqFreqAngRTMid, n_e) - - case default - - err_msg = 'unknown obs_param%pol for varname=Tb' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end if - - case default - - err_msg = 'unknown obs_param%varname' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - ! average from tiles to obs - - call tile2obs_helper(N_tmp, tmp_weights(1:N_tmp), tmp_data(1:N_tmp), tmpreal) - - Obs_pred_l(i,n_e) = tmpreal - - end do ! loop through ens members - - end if ! N_tmp>0 - - ! ---------------------------------------------------- - - ! additional, model-based QC (only done before EnKF update): - ! potentially remove obs if innovation is too large - - ! IMPORTANT: - ! The calibration of mwRTM parameters relies on the "getinnov" capability - ! of LDASsa in conjunction with a (poor) prior guess of mwRTM_param. - ! If model-based QC for Tb is added that in any way uses mwRTM_param, - ! observations might be discarded when they should not be during runs that - ! prepare for the mwRTM parameter calibration - ! - reichle, 12 Dec 2013 - - if (beforeEnKFupdate) then - - if (trim(obs_param(this_species)%varname)=='tsurf') then - - ! potentially eliminate obs (except if "bias_Npar>0" and "obsbias_ok==FALSE") - - if ( obs_param(this_species)%bias_Npar>0 .and. (.not. obsbias_ok_tmp(i)) ) then - - ! do nothing (ie, keep obs), obs bias estimate is spinning up - - else - - ! compute ensemble mean innovation - - tmpreal = Observations_l(i)%obs - sum(Obs_pred_l(i,1:N_ens))/real(N_ens) - - ! check whether innovation is considered too large - ! - ! rough estimate of innovations variance: R + HPH^t ~ 2*R - ! - ! threshold for acceptance: innovation**2 < (fac**2) * (2*R) - ! - ! changed threshold from fac=2 to fac=5 times innovations std-dev because - ! cat_bias estimation might never get started otherwise; - ! typical values of sqrt(obsvar) are between 1.3K (night) and 2.1K (day), - ! which corresponds to thresholds of between 9K (night) and 15K (day) - ! for innovations values; - ! egregious outliers of Tskin retrievals that result from sensing cloud - ! tops would presumably still be filtered out. - ! - reichle, 30 Jun 2015 - - if ( tmpreal**2 > (5.**2)*2.*Observations_l(i)%obsvar ) then - - Obs_pred_l(i,1:N_ens) = nodata_generic ! eliminate obs - - end if - - end if - - end if - - end if - - end do ! loop through Observations - - ! ---------------------------------------------------------------- - ! - ! clean up - - if (associated(N_tile_in_cell_ij_lH)) deallocate(N_tile_in_cell_ij_lH) - if (associated(tile_num_in_cell_ij_lH)) deallocate(tile_num_in_cell_ij_lH) - - if (allocated(ind_tmp)) deallocate(ind_tmp) - if (allocated(tmp_ndst2)) deallocate(tmp_ndst2) - if (allocated(tmp_weights)) deallocate(tmp_weights) - if (allocated(tmp_data)) deallocate(tmp_data) - - if (associated(tile_coord_lH)) deallocate(tile_coord_lH) - - if (get_Tb_l) deallocate(Tb_h_l) - if (get_Tb_l) deallocate(Tb_v_l) - - if (get_sfmc_lH) deallocate(sfmc_lH) - if (get_rzmc_lH) deallocate(rzmc_lH) - if (get_tsurf_lH) deallocate(tsurf_lH) - if (get_FT_lH) deallocate(FT_lH) - if (get_asnow_lH) deallocate(asnow_lH) - if (get_Tb_lH) deallocate(stemp_lH) - if (get_Tb_lH) deallocate(Tb_h_lH) - if (get_Tb_lH) deallocate(Tb_v_lH) - - ! ---------------------------------------------------------------- - ! - ! deal with no-data-values, compute ens mean and var of Obs_pred - - if (beforeEnKFupdate) then - - ! when used for "forecast" delete obs if Obs_pred is no-data-value - - j = 0 - - do i=1,N_obsl - - if (all(abs(Obs_pred_l(i,1:N_ens)-nodata_generic)>nodata_tol_generic)) then - - ! keep this obs - - j = j + 1 - - Observations_l(j ) = Observations_l(i ) - - Obs_pred_l( j,1:N_ens) = Obs_pred_l( i,1:N_ens) - - ! fill in fcst and fcstvar - - if (N_ens>1) then - - call row_variance( 1, N_ens, Obs_pred_l(j,1:N_ens), tmpvar, tmpmean ) - - ! inflate fcstvar - - if (inflation_factor > 0.) tmpvar(1) = tmpvar(1) * inflation_factor**2 - - else - - tmpmean(1) = Obs_pred_l(j,1) - - tmpvar(1) = nodata_generic - - end if - - Observations_l(j)%fcst = tmpmean(1) - Observations_l(j)%fcstvar = tmpvar(1) - - end if - - end do - - N_obsl = j - - else - - ! keep *all* obs even if Obs_pred turns out to be nodata - ! - ! Obs_pred can still be no-data (e.g., if model soil temperature is too cold, - ! mwRTM_get_Tb() returns a no-data-value) - - do i=1,N_obsl - - ! fill in ana and anavar - - if (N_ens>1) then - - if (any(abs(Obs_pred_l(i,1:N_ens)-nodata_generic) precip_threshold) .or. & - (SWE(i) > SWE_threshold) .or. & - (tsurf(i) < tsurf_threshold) ) & - sfmc(i) = nodata_generic - - end do - - end subroutine qc_model_based_for_sat_sfmc - - - ! ***************************************************************** - - subroutine qc_model_based_for_sat_tsurf( N_cat, precip, SWE, tp1, & - tsurf ) - - ! simple model-based quality control for satellite tsurf observations - ! - ! set tsurf "Obs_pred" to no-data when model indicates difficult - ! retrieval conditions - ! - ! reichle, 2 Nov 2004 - ! reichle, 14 Jun 2011 - moved from clsm_ensupd_read_obs.F90 and edited - ! reichle, 23 Nov 2011 - changed precip_threshold b/c QC now done for individual - ! ensemble members rather than the ensemble mean - ! reichle, 14 Feb 2013 - added hard-coded option to eliminate frozen conditions in QC - ! based on tsurf and top layer soil temperature (tp1) - ! reichle, 26 Mar 2014 - set "avoid_frozen=.false." following advice from Clara - ! - ! -------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_cat - - real, dimension(N_cat), intent(in) :: precip ! Rainf+Snowf [kg/m2/s] - real, dimension(N_cat), intent(in) :: SWE ! total SWE [kg/m2] - real, dimension(N_cat), intent(in) :: tp1 ! soil temperature [C] - - real, dimension(N_cat), intent(inout) :: tsurf - - ! local variables - - real, parameter :: precip_threshold = 10./86400. ! [kg/m2/s] - - real, parameter :: SWE_threshold = 1.e-4 ! [kg/m2] - - logical, parameter :: avoid_frozen = .false. - - real, parameter :: temp_threshold = MAPL_TICE + 2. ! [K] - - integer :: i - - logical, dimension(N_cat) :: frozen - - real, dimension(N_cat) :: tp1_in_Kelvin - - ! --------------------------------------- - - frozen = .false. - - if (avoid_frozen) then - - tp1_in_Kelvin = tp1 + MAPL_TICE - - do i=1,N_cat - - if ( (tsurf( i) < temp_threshold) .or. & - (tp1_in_Kelvin( i) < temp_threshold) & - ) & - frozen(i) = .true. - - end do - - end if - - - do i=1,N_cat - - ! delete obs - ! - if there is snow on the ground - ! - if it is raining/snowing - ! - if "avoid_frozen" and frozen - - if ( (precip(i) > precip_threshold) .or. & - (SWE(i) > SWE_threshold) .or. & - (frozen(i)) & - ) & - tsurf(i) = nodata_generic - - end do - - end subroutine qc_model_based_for_sat_tsurf - - - ! ***************************************************************** - - subroutine qc_model_based_for_Tb( N_cat, precip, Tb ) - - ! simple model-based quality control for Tb observations - ! - ! set Tb "Obs_pred" to no-data when model indicates difficult conditions - ! - ! - ! GDL, 15 Nov 2010 - ! reichle, 27 May 2011 - included in LDASsa - ! reichle, 14 Jun 2011 - moved from clsm_ensupd_read_obs.F90 and edited - ! reichle, 23 Nov 2011 - changed precip_threshold b/c QC now done for individual - ! ensemble members rather than the ensemble mean - ! - ! -------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_cat - - real, dimension(N_cat), intent(in) :: precip ! Rainf+Snowf [kg/m2/s] - - real, dimension(N_cat), intent(inout) :: Tb ! brightness temp. [K] - - ! local variables - - ! relatively large threshold for precip indirectly screens for standing water - - !real, parameter :: precip_threshold = 25./86400. ! [kg/m2/s] - real, parameter :: precip_threshold = 50./86400. ! [kg/m2/s] - - integer :: i - - ! --------------------------------------- - - do i=1,N_cat - - ! delete obs - ! - if there is heavy rain or snow - - ! NOTE: subroutine mwRTM_get_Tb already returns no-data-values - ! - if there is snow on the ground - ! - if surface temperature is around or below freezing - - if ( (precip(i) > precip_threshold) ) & - Tb(i) = nodata_generic - - ! IMPORTANT: - ! The calibration of mwRTM parameters relies on the "getinnov" capability - ! of LDASsa in conjunction with a (poor) prior guess of mwRTM_param. - ! If model-based QC for Tb is added that in any way uses mwRTM_param, - ! observations might be discarded when they should not be during runs that - ! prepare for the mwRTM parameter calibration - ! - reichle, 12 Dec 2013 - - end do - - end subroutine qc_model_based_for_Tb - - ! ********************************************************************* - - subroutine get_halo_obs( N_ens, N_obsl, Observations_l, Obs_pred_l, & - tile_coord_l, xcompact, ycompact, & - N_obslH, Observations_lH, Obs_pred_lH ) - - ! collect observations from other local domains (processors) that are - ! within the halo of the current local domain (processor) - ! - ! ONLY collect obs with flag assim==.true. - ! - ! Current implementation: - ! - ! 1. Determine min/max lat/lon for locally managed Observations_l and - ! min/max lat/lon for local halo - ! 2. MPI *all*gather this information to all processors - ! 3. Determine which processors need to communicate - ! 4. Pairwise MPI_SENDRECV as needed - ! - ! - ! A shorter and simpler but somewhat wasteful implementation (in terms of memory - ! and communications) could be as follows: - ! - ! 1. MPI *all*gather local Observations_l to all processors - ! 2. Determine index of (full domain) obs that are in halo of given local domain - ! 3. MPI *all*gather local Obs_pred and extract as needed - ! - ! - ! reichle, 2 Aug 2011 - ! reichle, 30 Sep 2011 - ! - ! ---------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_ens, N_obsl - - type(obs_type), dimension(N_obsl), intent(in) :: Observations_l - - real, dimension(N_obsl,N_ens), intent(in) :: Obs_pred_l - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l ! in - - real, intent(in) :: xcompact, ycompact - - integer, intent(out) :: N_obslH - - type(obs_type), dimension(:), pointer :: Observations_lH ! out - - real, dimension(:,:), pointer :: Obs_pred_lH ! out - - ! local variables - - integer :: i, j, m, n, N_obslH_max - - integer :: N_recv, N_recvi, N_sendi, tag1, tag2 - - real :: lon, lat - - real :: obsl_minlon, obsl_maxlon, obsl_minlat, obsl_maxlat - real :: halo_minlon, halo_maxlon, halo_minlat, halo_maxlat - - real :: minlon, maxlon, minlat, maxlat - real :: ll_lon, ur_lon, ll_lat, ur_lat - - integer, dimension(numprocs) :: N_obsl_vec - - real, dimension(numprocs) :: obsl_minlon_vec, obsl_maxlon_vec - real, dimension(numprocs) :: obsl_minlat_vec, obsl_maxlat_vec - - real, dimension(numprocs) :: halo_minlon_vec, halo_maxlon_vec - real, dimension(numprocs) :: halo_minlat_vec, halo_maxlat_vec - - logical, dimension(numprocs,numprocs) :: need_obsl - - type(obs_type), dimension(:), pointer :: Observations_l_recv => null() - - real, dimension(:,:), allocatable :: Obs_pred_l_recv - - ! ------------------------------------------------- - ! - ! determine and communicate min/max lat/lon of Observations_l - ! managed by given processor - ! - ! WARNING: this will most likely create problems if a given local domain - ! crosses the dateline! - ! - ! - ! NOTE: All Observations lat/lon values must be "good" - ! (ie, *not* no-data-values) - - if (N_obsl>0) then - - ! make sure the rectangle does not have zero area - ! (which might happen if there is only one obs) - - obsl_minlon = minval(Observations_l%lon) - 0.01 - obsl_maxlon = maxval(Observations_l%lon) + 0.01 - obsl_minlat = minval(Observations_l%lat) - 0.01 - obsl_maxlat = maxval(Observations_l%lat) + 0.01 - - else - - obsl_minlon = nodata_generic - obsl_maxlon = nodata_generic - obsl_minlat = nodata_generic - obsl_maxlat = nodata_generic - - end if - -#ifdef LDAS_MPI - - call MPI_AllGather( & - N_obsl, 1, MPI_integer, & - N_obsl_vec, 1, MPI_integer, & - mpicomm, mpierr ) - - call MPI_AllGather( & - obsl_minlon, 1, MPI_real, & - obsl_minlon_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - obsl_maxlon, 1, MPI_real, & - obsl_maxlon_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - obsl_minlat, 1, MPI_real, & - obsl_minlat_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - obsl_maxlat, 1, MPI_real, & - obsl_maxlat_vec, 1, MPI_real, & - mpicomm, mpierr ) - -#else - - N_obsl_vec(1) = N_obsl - - obsl_minlon_vec(1) = obsl_minlon - obsl_maxlon_vec(1) = obsl_maxlon - obsl_minlat_vec(1) = obsl_minlat - obsl_maxlat_vec(1) = obsl_maxlat - -#endif - - ! ------------------------------------------------------------ - ! - ! determine and communicate min/max lat/lon of halo - - halo_minlon = minval(tile_coord_l%com_lon) - 1.25*xcompact - halo_maxlon = maxval(tile_coord_l%com_lon) + 1.25*xcompact - halo_minlat = minval(tile_coord_l%com_lat) - 1.25*ycompact - halo_maxlat = maxval(tile_coord_l%com_lat) + 1.25*ycompact - - ! simple approach to dateline issue (cut halo back to at most -180:180, -90:90) - ! - reichle, 28 May 2013 - - halo_minlon = max(halo_minlon,-180.) - halo_maxlon = min(halo_maxlon, 180.) - halo_minlat = max(halo_minlat, -90.) - halo_maxlat = min(halo_maxlat, 90.) - - -#ifdef LDAS_MPI - - call MPI_AllGather( & - halo_minlon, 1, MPI_real, & - halo_minlon_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - halo_maxlon, 1, MPI_real, & - halo_maxlon_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - halo_minlat, 1, MPI_real, & - halo_minlat_vec, 1, MPI_real, & - mpicomm, mpierr ) - - call MPI_AllGather( & - halo_maxlat, 1, MPI_real, & - halo_maxlat_vec, 1, MPI_real, & - mpicomm, mpierr ) - -#else - - halo_minlon_vec(1) = halo_minlon - halo_maxlon_vec(1) = halo_maxlon - halo_minlat_vec(1) = halo_minlat - halo_maxlat_vec(1) = halo_maxlat - -#endif - - ! ------------------------------------------------------------ - ! - ! determine which processors need to communicate (directional!) - ! - ! need_obsl(i,j) = .true. - ! ==> processor i needs Observations_l from processor j - - need_obsl = .false. - - do i=1,numprocs ! i = "tile-space" - - ll_lon = halo_minlon_vec(i) - ur_lon = halo_maxlon_vec(i) - ll_lat = halo_minlat_vec(i) - ur_lat = halo_maxlat_vec(i) - - do j=1,numprocs ! j = "obs-space" - - if ( (N_obsl_vec(j)>0) .and. (i/=j) ) then - - minlon = obsl_minlon_vec(j) - maxlon = obsl_maxlon_vec(j) - minlat = obsl_minlat_vec(j) - maxlat = obsl_maxlat_vec(j) - - ! processor i needs Observations_l from processor j - ! if bounding box around Observations_l from j overlaps - ! with bounding box plus halo of processor i - - if ( (min(ur_lon,maxlon) - max(ll_lon,minlon))>0. .and. & - (min(ur_lat,maxlat) - max(ll_lat,minlat))>0. ) & - need_obsl(i,j) = .true. - - else - - need_obsl(i,i) = .true. - - end if - - end do - end do - - ! determine maximum number of obs within halo (incl locally managed obs) - - N_obslH_max = 0 ! note: need_obsl(j,j)=.true. - - do j=1,numprocs - - if (need_obsl(myid+1,j)) N_obslH_max = N_obslH_max + N_obsl_vec(j) - - end do - - ! allocate Observations_lH, Obs_pred_lH - - allocate(Observations_lH(N_obslH_max )) - - allocate(Obs_pred_lH( N_obslH_max,N_ens)) - - ! ------------------------------------------------------------ - ! - ! initialize Observations_lH, Obs_pred_lH with local Observations - ! (use only those with flag "assim"==.true.) - - m = 0 - - do n=1,N_obsl - - if (Observations_l(n)%assim) then - - m = m+1 - - Observations_lH(m ) = Observations_l(n) - - Obs_pred_lH( m,:) = Obs_pred_l(n,:) - - end if - - end do - - N_obslH = m - -#ifdef LDAS_MPI - - ! pairwise communication - ! - ! use MPI_SENDRECV to avoid "hung" or "deadlocked" communications - - do i=1,numprocs - - do j=i+1,numprocs ! loop only through upper triangle of (i,j) matrix - - ! determine how many Observations should be - ! - received by i (same as sent by j), and - ! - sent by i (same as received by j) - - if (need_obsl(i,j)) then - - N_recvi = N_obsl_vec(j) - - else - - N_recvi = 0 - - end if - - if (need_obsl(j,i)) then - - N_sendi = N_obsl_vec(i) - - else - - N_sendi = 0 - - end if - - tag1 = 1 - tag2 = 2 - - if (N_recvi>0 .or. N_sendi>0) then - - if (myid+1==i) then - - ! allocate Observations_l_recv, Obs_pred_recv - - allocate(Observations_l_recv(N_recvi )) - allocate(Obs_pred_l_recv( N_recvi,N_ens)) - - ! obtain Observations_l from processor j - ! send Observations_l to processor j - - call MPI_SENDRECV( & - Observations_l, N_sendi, MPI_obs_type, j-1, tag1, & - Observations_l_recv, N_recvi, MPI_obs_type, j-1, tag2, & - mpicomm, mpistatus, mpierr ) - - call MPI_SENDRECV( & - Obs_pred_l, N_sendi*N_ens, MPI_real, j-1, tag1, & - Obs_pred_l_recv, N_recvi*N_ens, MPI_real, j-1, tag2, & - mpicomm, mpistatus, mpierr ) - - elseif (myid+1==j) then - - ! allocate Observations_l_recv, Obs_pred_recv - - allocate(Observations_l_recv(N_sendi )) - allocate(Obs_pred_l_recv( N_sendi,N_ens)) - - call MPI_SENDRECV( & - Observations_l, N_recvi, MPI_obs_type, i-1, tag2, & - Observations_l_recv, N_sendi, MPI_obs_type, i-1, tag1, & - mpicomm, mpistatus, mpierr ) - - call MPI_SENDRECV( & - Obs_pred_l, N_recvi*N_ens, MPI_real, i-1, tag2, & - Obs_pred_l_recv, N_sendi*N_ens, MPI_real, i-1, tag1, & - mpicomm, mpistatus, mpierr ) - - end if - - ! put received obs into Observations_lH - - if (myid+1==i .or. myid+1==j) then - - if (myid+1==i) then - - N_recv = N_recvi - - ll_lon = halo_minlon_vec(i) - ur_lon = halo_maxlon_vec(i) - ll_lat = halo_minlat_vec(i) - ur_lat = halo_maxlat_vec(i) - - else ! my_id+1==j - - N_recv = N_sendi - - ll_lon = halo_minlon_vec(j) - ur_lon = halo_maxlon_vec(j) - ll_lat = halo_minlat_vec(j) - ur_lat = halo_maxlat_vec(j) - - end if - - m = N_obslH - - do n=1,N_recv - - lon = Observations_l_recv(n)%lon - lat = Observations_l_recv(n)%lat - - if ( Observations_l_recv(n)%assim .and. & - is_in_rectangle(lon,lat,ll_lon,ll_lat,ur_lon,ur_lat) ) then - - m = m+1 - - Observations_lH(m ) = Observations_l_recv(n) - - Obs_pred_lH( m,:) = Obs_pred_l_recv( n,:) - - end if - - end do - - N_obslH = m - - end if - - end if - - call MPI_BARRIER( mpicomm, mpierr ) - - if (associated(Observations_l_recv)) deallocate(Observations_l_recv) - - if (allocated(Obs_pred_l_recv)) deallocate(Obs_pred_l_recv) - - end do - end do - -#else - - ! previous block kicks in only for numprocs>1 (not for OpenMP and sequential) - -#endif - - end subroutine get_halo_obs - - ! ********************************************************************* - - subroutine get_tiles_in_halo( N_catl, N_fields, N_ens, tile_data_l, tile_coord_l, & - tile_coord_f, N_catl_vec, low_ind, xhalo, yhalo, & - N_catlH, tile_coord_lH, tile_data_lH ) - - ! collect (bundled) tile_data from other local domains (processors) that are - ! within the halo of the current local domain (processor) for the purpose - ! of calculating Obs_pred - ! - ! Current implementation: - ! - ! 1. Determine min/max lat/lon for all local domains - ! 2. Determine which processors need to communicate - ! 3. Pairwise MPI_SENDRECV as needed - ! - ! reichle, 19 Jun 2012 - ! reichle, 27 Mar 2014 - renamed to better distinguish from "get_halo_around_tile()" - ! - ! ---------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_catl, N_fields - integer, intent(in) :: N_ens - - real, dimension(N_catl,N_fields,N_ens), intent(in) :: tile_data_l - - type(tile_coord_type), dimension(:), pointer :: tile_coord_l ! in - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! in - - integer, dimension(numprocs), intent(in) :: N_catl_vec - integer, dimension(numprocs), intent(in) :: low_ind - - real, dimension(numprocs), intent(in) :: xhalo, yhalo - - integer, intent(out) :: N_catlH - - real, dimension(:,:,:), pointer, optional :: tile_data_lH ! out - - type(tile_coord_type), dimension(:), pointer, optional :: tile_coord_lH ! out - - ! local variables - - integer :: i, j, istart, iend, istart_f, iend_f - - integer :: N_recv, N_recvi, N_sendi, tag1, tag2 - - real :: minlon, maxlon, minlat, maxlat - real :: ll_lon, ur_lon, ll_lat, ur_lat - - real, dimension(numprocs) :: catl_minlon_vec, catl_maxlon_vec - real, dimension(numprocs) :: catl_minlat_vec, catl_maxlat_vec - - real, dimension(numprocs) :: halo_minlon_vec, halo_maxlon_vec - real, dimension(numprocs) :: halo_minlat_vec, halo_maxlat_vec - - logical, dimension(numprocs,numprocs) :: need_catl - - real, dimension(:,:,:), allocatable :: tile_data_l_recv - - ! ------------------------------------------------- - ! - ! each processor determines min/max lat/lon of tiles managed by all - ! processors (without and with halo) - ! - ! WARNING: this will most likely create problems if a given local domain - ! crosses the dateline! - - do i=1,numprocs - - if (N_catl_vec(i) <= 0) cycle ! nothing to do for this processor - - istart = low_ind(i) - iend = istart + N_catl_vec(i) - 1 - - ! use center-of-mass of tiles (rather than min/max_lon, min/max_lat) - - catl_minlon_vec(i) = minval( tile_coord_f(istart:iend)%com_lon ) - catl_maxlon_vec(i) = maxval( tile_coord_f(istart:iend)%com_lon ) - catl_minlat_vec(i) = minval( tile_coord_f(istart:iend)%com_lat ) - catl_maxlat_vec(i) = maxval( tile_coord_f(istart:iend)%com_lat ) - - halo_minlon_vec(i) = catl_minlon_vec(i) - xhalo(i) - halo_maxlon_vec(i) = catl_maxlon_vec(i) + xhalo(i) - halo_minlat_vec(i) = catl_minlat_vec(i) - yhalo(i) - halo_maxlat_vec(i) = catl_maxlat_vec(i) + yhalo(i) - - end do - - ! ------------------------------------------------------------ - ! - ! determine which processors need to communicate (symmetric!) - ! - ! need_catl(i,j) = .true. - ! ==> processors i and j need to exchange tile_data_l - - need_catl = .false. - - do i=1,numprocs - - if (N_catl_vec(i) >0) need_catl(i,i) = .true. - - end do - - do i=1,numprocs - - ! all tiles within the following rectangle are needed by proc i - - if ( N_catl_vec(i) <= 0) cycle ! nothing to do for this processor - - ll_lon = halo_minlon_vec(i) - ur_lon = halo_maxlon_vec(i) - ll_lat = halo_minlat_vec(i) - ur_lat = halo_maxlat_vec(i) - - do j=i+1,numprocs - - if (N_catl_vec(j) <= 0) cycle ! nothing to do for this processor - - minlon = catl_minlon_vec(j) - maxlon = catl_maxlon_vec(j) - minlat = catl_minlat_vec(j) - maxlat = catl_maxlat_vec(j) - - ! processor i needs tile_data_l from processor j - ! if bounding box around tile_data_l(j) overlaps - ! with bounding box plus halo of processor i - - if ( (min(ur_lon,maxlon) - max(ll_lon,minlon))>0. .and. & - (min(ur_lat,maxlat) - max(ll_lat,minlat))>0. ) & - need_catl(i,j) = .true. - - need_catl(j,i) = need_catl(i,j) - end do - end do - - ! determine number of tiles within halo (incl local tiles) - - N_catlH = 0 ! note: need_catl(j,j)=.true. - - do j=1,numprocs - - if (need_catl(myid+1,j)) N_catlH = N_catlH + N_catl_vec(j) - - end do - - ! allocate tile_coord_lH, tile_data_lH - - if (present(tile_coord_lH)) allocate(tile_coord_lH(N_catlH )) - if (present(tile_data_lH)) allocate(tile_data_lH( N_catlH,N_fields,N_ens)) - - ! ------------------------------------------------------------ - ! - ! initialize tile_coord_lH, tile_data_lH with local tile_coord_l, - ! tile_data_l - - N_catlH = N_catl ! will grow as data from other processors are appended - - if (present(tile_coord_lH)) tile_coord_lH(1:N_catlH) = tile_coord_l(1:N_catlH) - - if (present(tile_data_lH)) tile_data_lH(1:N_catlH,1:N_fields,1:N_ens) = tile_data_l - -#ifdef LDAS_MPI - - ! pairwise communication (symmetric!) - ! - ! use MPI_SENDRECV to avoid "hung" or "deadlocked" communications - - do i=1,numprocs - - do j=i+1,numprocs ! loop only through upper triangle of (i,j) matrix - - ! determine how many elements should be - ! - received by i (same as sent by j), and - ! - sent by i (same as received by j) - - if (need_catl(i,j)) then - - N_recvi = N_catl_vec(j) - N_sendi = N_catl_vec(i) - - else - - N_recvi = 0 - N_sendi = 0 - - end if - - tag1 = 1 - tag2 = 2 - - if (N_recvi>0 .or. N_sendi>0) then - - if (myid+1==i) then - - if (present(tile_data_lH)) then - - ! allocate tile_data_l_recv - - allocate(tile_data_l_recv(N_recvi,N_fields,N_ens)) - - ! obtain tile_data_l from processor j - ! send tile_data_l to processor j - - call MPI_SENDRECV( & - tile_data_l, N_sendi*N_fields*N_ens,MPI_real,j-1,tag1, & - tile_data_l_recv,N_recvi*N_fields*N_ens,MPI_real,j-1,tag2, & - mpicomm, mpistatus, mpierr ) - - end if - - elseif (myid+1==j) then - - if (present(tile_data_lH)) then - - ! allocate tile_data_l_recv - - allocate(tile_data_l_recv(N_sendi,N_fields,N_ens)) ! N_sendi=N_recvj - - ! obtain tile_data_l from processor i - ! send tile_data_l to processor i - - call MPI_SENDRECV( & - tile_data_l, N_recvi*N_fields*N_ens,MPI_real,i-1,tag2, & - tile_data_l_recv,N_sendi*N_fields*N_ens,MPI_real,i-1,tag1, & - mpicomm, mpistatus, mpierr ) - - end if - - end if - - ! put received data into tile_data_lH - - if (myid+1==i .or. myid+1==j) then - - if (myid+1==i) then - - N_recv = N_recvi - istart_f = low_ind(j) - - else ! my_id+1==j - - N_recv = N_sendi ! N_sendi=N_recvj - istart_f = low_ind(i) - - end if - - iend_f = istart_f + N_recv - 1 - - istart = N_catlH + 1 - - iend = istart + N_recv - 1 - - ! append tile_data_l_recv to tile_data_lH - ! (similarly for tile_coord_lH) - - if (present(tile_coord_lH)) & - tile_coord_lH(istart:iend) = tile_coord_f(istart_f:iend_f) - - if (present(tile_data_lH)) & - tile_data_lH(istart:iend,1:N_fields,1:N_ens) = tile_data_l_recv - - N_catlH = iend - - end if - - end if - - if (allocated(tile_data_l_recv)) deallocate(tile_data_l_recv) - - end do - end do - -#else - - ! previous block kicks in only for numprocs>1 (not for OpenMP and sequential) - -#endif - - end subroutine get_tiles_in_halo - - ! ********************************************************************* - - subroutine get_obs_pert( N_ens, N_obs, N_obs_param, & - pert_grid_f, & - obs_param, Observations, & - Pert_rseed, & - Obs_pert ) - - ! reichle, 27 Jul 2005 - ! reichle, 3 Oct 2011 --- rewritten for obs w/in halo - ! reichle, 14 Feb 2013 --- bug fix in call to get_pert() - - implicit none - - integer, intent(in) :: N_ens, N_obs, N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(obs_type), dimension(N_obs), intent(in) :: Observations - - type(grid_def_type), intent(in) :: pert_grid_f - - integer, dimension(NRANDSEED,N_ens), intent(inout) :: Pert_rseed - - real, dimension(N_obs,N_ens), intent(out) :: Obs_pert - - ! -------------------------------- - - ! local variables - - real, parameter :: dtstep = 0. - - type(pert_param_type), dimension(:), pointer :: obs_pert_param => null() - - real :: this_lon, this_lat, delta_lon, delta_lat - - real :: obs_minlon, obs_minlat, obs_maxlon, obs_maxlat - - integer :: i, j, k, lon_ind, lat_ind, N_assim_species, max_species_id - - integer :: ind_minlon, ind_minlat, ind_maxlon, ind_maxlat - - integer :: ind_i_min, ind_j_min, ind_i_max, ind_j_max - - type(grid_def_type) :: pert_grid_lH - - integer, dimension(N_obs_param) :: ind_assim_species - - integer, dimension(:), allocatable :: ind_species2obsparam - - real, dimension(:,:,:,:), allocatable :: Obs_pert_ntrmdt, Obs_pert_grid - - character(len=*), parameter :: Iam = 'get_obs_pert' - character(len=400) :: err_msg - - ! ----------------------------------------------------------------- - - nullify(obs_pert_param) - - ! determine pert_grid_lH - ! - pert_grid_lH is the local grid for which perturbations are needed - ! - pert_grid_lH is larger than pert_grid_l by the "halo" - - ! inherit select properties from pert_grid_f - - pert_grid_lH%gridtype = pert_grid_f%gridtype - pert_grid_lH%ind_base = pert_grid_f%ind_base - pert_grid_lH%i_dir = pert_grid_f%i_dir - pert_grid_lH%j_dir = pert_grid_f%j_dir - - if (N_obs>0) then - - ! determine grid extent from Observations within local halo - ! - ! inherit simple approach to dateline issue from get_halo_obs(), that is: - ! obs_minlon>=-180, obs_maxlon<=180, obs_minlat>=-90, obs_maxlat<=90 - - obs_minlon = minval(Observations%lon) - obs_maxlon = maxval(Observations%lon) - obs_minlat = minval(Observations%lat) - obs_maxlat = maxval(Observations%lat) - - ! get i/j_ind of corner grid cells w.r.t. pert_grid_f - - call get_ij_ind_from_latlon( pert_grid_f, obs_minlat, obs_minlon, & - ind_minlon, ind_minlat) - - call get_ij_ind_from_latlon( pert_grid_f, obs_maxlat, obs_maxlon, & - ind_maxlon, ind_maxlat) - - else - - ! create a dummy 1-by-1 grid - - ind_minlon = 1 - ind_maxlon = 1 - ind_minlat = 1 - ind_maxlat = 1 - - end if - - ! convert indices associated with lat/lon to min/max indices - ! (note that ind_minlon>=ind_maxlon if j_dir==-1) - ! (note that ind_minlon, ind_minlat, etc will be needed again below) - - ind_i_min = min( ind_minlon, ind_maxlon) - ind_i_max = max( ind_minlon, ind_maxlon) - - ind_j_min = min( ind_minlat, ind_maxlat) - ind_j_max = max( ind_minlat, ind_maxlat) - - pert_grid_lH%N_lon = ind_i_max - ind_i_min + 1 - pert_grid_lH%N_lat = ind_j_max - ind_j_min + 1 - - pert_grid_lH%i_offg = ind_i_min - 1 + pert_grid_f%i_offg - pert_grid_lH%j_offg = ind_j_min - 1 + pert_grid_f%j_offg - - if (index(pert_grid_lH%gridtype,'LatLon')/=0) then - - pert_grid_lH%dlon = pert_grid_f%dlon - pert_grid_lH%dlat = pert_grid_f%dlat - - delta_lon = real(ind_minlon-1)*pert_grid_lH%dlon - delta_lat = real(ind_minlat-1)*pert_grid_lH%dlat - - pert_grid_lH%ll_lon = pert_grid_f%ll_lon + delta_lon - pert_grid_lH%ll_lat = pert_grid_f%ll_lat + delta_lat - - delta_lon = real(pert_grid_lH%N_lon)*pert_grid_lH%dlon - delta_lat = real(pert_grid_lH%N_lat)*pert_grid_lH%dlat - - pert_grid_lH%ur_lon = pert_grid_lH%ll_lon + delta_lon - pert_grid_lH%ur_lat = pert_grid_lH%ll_lat + delta_lat - - elseif ( index(pert_grid_lH%gridtype,'EASEv') /=0 ) then - - pert_grid_lH%dlon = pert_grid_f%dlon - - pert_grid_lH%dlat = nodata_generic ! not needed here - - pert_grid_lH%ll_lon = nodata_generic ! not needed here - pert_grid_lH%ll_lat = nodata_generic ! not needed here - pert_grid_lH%ur_lon = nodata_generic ! not needed here - pert_grid_lH%ur_lat = nodata_generic ! not needed here - - else - - err_msg = 'not yet implemented for ' // pert_grid_lH%gridtype - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! --------------------------------------------------------------------- - ! - ! Find out which species are assimilated in general (even there are - ! none of a given assimilated species among the Observations at this time - ! and for this processor, or even none at all of a given species for this - ! time step). - ! This is necessary because this subroutine is called by all - ! processors, and Pert_rseed can only stay consistent across processors - ! if all processors generate random fields for the same number of - ! species. (Alternatively, could implement a query across the Observations - ! from all processors, but this would require communications.) - - ind_assim_species = -9999 - - max_species_id = -9999 - - j = 0 - - do i=1,N_obs_param - - if (obs_param(i)%assim) then - - j = j+1 - - ind_assim_species(j) = i - - max_species_id = max( max_species_id, obs_param(i)%species) - - end if - - end do - - N_assim_species = j - - ! get mapping from assimilated species counter (j) back to "species" id - - allocate(ind_species2obsparam(max_species_id)) - - ind_species2obsparam = -9999 - - do j=1,N_assim_species - - i = ind_assim_species(j) - - ind_species2obsparam(obs_param(i)%species) = j - - end do - - ! -------------------------------------------------------------------- - ! - ! get obs_pert_param for use with get_pert() - - call allocate_pert_param( N_assim_species, & - pert_grid_lH%N_lon, pert_grid_lH%N_lat, obs_pert_param) - - do j=1,N_assim_species - - ! Use land_pert module to generate spatially correlated and - ! standard-normally distributed perturbations. - ! - ! For observation perturbations, always use: - ! - ! tcorr = 0. (never temporally correlated) - ! typ = 0 (always additive) - ! ccorr = 0. (never cross-correlated) - ! - - i = ind_assim_species(j) - - obs_pert_param(j)%descr = obs_param(i)%descr - obs_pert_param(j)%typ = 0 - obs_pert_param(j)%std_normal_max = obs_param(i)%std_normal_max - obs_pert_param(j)%zeromean = obs_param(i)%zeromean - obs_pert_param(j)%coarsen = obs_param(i)%coarsen_pert - - obs_pert_param(j)%mean(:,:) = 0. ! need N(0,1) perturbations - obs_pert_param(j)%std( :,:) = 1. ! need N(0,1) perturbations - - obs_pert_param(j)%ccorr(:,:,:) = 0. - obs_pert_param(j)%ccorr(j,:,:) = 1. - - obs_pert_param(j)%xcorr = obs_param(i)%xcorr - obs_pert_param(j)%ycorr = obs_param(i)%ycorr - obs_pert_param(j)%tcorr = 0 - - end do - - ! -------------------------------------------------------------------- - ! - ! get gridded perturbations - - allocate(Obs_pert_ntrmdt(pert_grid_lH%N_lon, pert_grid_lH%N_lat, N_assim_species, N_ens)) - allocate(Obs_pert_grid( pert_grid_lH%N_lon, pert_grid_lH%N_lat, N_assim_species, N_ens)) - - call get_pert( & - N_assim_species, N_assim_species, N_ens, & - pert_grid_lH, pert_grid_f, & ! switched order (reichle, 17 Jul 2020) - dtstep, & - obs_pert_param, & - Pert_rseed, & - Obs_pert_ntrmdt, & - Obs_pert_grid ) - - ! clean up - - deallocate(Obs_pert_ntrmdt) - - call deallocate_pert_param(N_assim_species, obs_pert_param) - - ! -------------------------------------------------------------------- - ! - ! map gridded perturbations to observations one at a time, - ! scale to desired error standard deviation - - do k=1,N_obs - - ! map from grid to obs - - this_lon = Observations(k)%lon - this_lat = Observations(k)%lat - - call get_ij_ind_from_latlon( pert_grid_lH, this_lat, this_lon, lon_ind, lat_ind ) - - j = ind_species2obsparam(Observations(k)%species) - - Obs_pert(k,1:N_ens) = Obs_pert_grid( lon_ind, lat_ind, j, 1:N_ens ) - - Obs_pert(k,1:N_ens) = Obs_pert(k,1:N_ens) * sqrt(Observations(k)%obsvar) - - end do - - deallocate(Obs_pert_grid) - - deallocate(ind_species2obsparam) - - ! ----------------------------------------------------------------- - ! - ! enforce physical constraints - - ! Skip this step. It has only been used for soil moisture content, - ! where a perturbation may result in an observation outside of the - ! physical range, but because of the physical checks on the analysis - ! this step should not be necessary. - ! reichle, 3 Oct 2011 - - !call check_obs_pert( N_ens, N_catd, N_obs, cat_param, Observations, & - ! Obs_pert ) - - end subroutine get_obs_pert - - ! ********************************************************************* - - subroutine cat_enkf_increments( & - N_ens, N_obs, N_catd, N_obs_param, & - update_type, obs_param, & - tile_coord, l2f, & - Observations, Obs_pred, Obs_pert, & - met_force, cat_param, & - xcompact, ycompact, fcsterr_inflation_fac, & - cat_progn, cat_progn_incr ) - - ! get increments for Catchment prognostic variables - ! - ! reichle, 27 Jan 2005 - eliminated update of Mod_err - ! reichle, 27 Jul 2005 - ! reichle, 18 Oct 2005 - return increments (instead of updated cat_progn) - ! reichle, 17 Oct 2011 - added "l2f" for revised (MPI) analysis - ! jpark50, 28 Jul 2020 - added met_force to argument list for MODIS SCF assimilation - ! reichle, 20 Feb 2022 - modified update_type 10 for PEATCLSM - ! amfox, 6 Feb 2024 - added update type 13 for combination of ASCAT SM and SMAP Tb - ! - ! -------------------------------------------------------------- - - ! IMPORTANT: - ! on input, cat_progn must contain cat_progn_minus(1:N_catd,1:N_ens) - ! on output, cat_progn_incr contains INCREMENTS - - ! type of update is selected by "update_type" - - ! ********************************************************************* - ! **************** WARNING WARNING WARNING WARNING **************** - ! ********************************************************************* - ! - ! "update_types" 1-5 below have NOT been fully tested after extensive - ! revisions re. obs handling and MPI implementation. - ! - reichle, 17 Oct 2011 - - ! ------------------------------------------------------------------- - - implicit none - - ! inputs - - integer, intent(in) :: N_ens, N_obs, N_catd, N_obs_param, update_type - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - integer, dimension(N_catd), intent(in) :: l2f - - type(obs_type), intent(in), dimension(N_obs) :: Observations ! input - - real, intent(in), dimension(N_obs,N_ens) :: Obs_pred - real, intent(in), dimension(N_obs,N_ens) :: Obs_pert - - type(met_force_type), dimension(N_catd), intent(in) :: met_force - type(cat_param_type), dimension(N_catd), intent(in) :: cat_param - - real, intent(in) :: xcompact, ycompact, fcsterr_inflation_fac - - type(cat_progn_type), intent(in), dimension(N_catd,N_ens) :: cat_progn - - ! output - - type(cat_progn_type), intent(out), dimension(N_catd,N_ens) :: & - cat_progn_incr - - ! ----------------------------- - ! - ! locals - - ! thresholds for identifying snow-free and non-frozen tiles - ! NOT YET USED - ! - reichle, 14 Oct 2014 - - real, parameter :: SWE_threshold = +HUGE(1.) ! = 1.e-4 ! [kg/m2] - - real, parameter :: tp1_threshold = -HUGE(1.) ! = 0.2 ! [CELSIUS] - - integer :: n, n_e, kk, ii, jj - - integer :: N_state_max, N_state, N_selected_obs, N_select_varnames, N_select_species, N_select_species_Tb - - real :: halo_minlon, halo_maxlon, halo_minlat, halo_maxlat - real :: tmp_minlon, tmp_maxlon, tmp_minlat, tmp_maxlat - - real :: tmp_obs, deltaT - - real :: fice_minus, tp1_minus, ght1_minus - real :: fice_plus, tp1_plus, ght1_plus - - integer, dimension(N_obs) :: ind_obs - - real, allocatable, dimension(:,:) :: State_incr - real, allocatable, dimension(:,:) :: Obs_cov ! measurement error covariance - - real, allocatable, dimension(:) :: State_lon, State_lat - - integer, dimension(N_obs_param) :: select_species, select_species_Tb ! alloc max possible length - - character(40), dimension(N_obs_param) :: select_varnames ! alloc max possible length - - integer, dimension(:), allocatable :: select_tilenum - - integer, dimension(:,:), pointer :: N_tile_in_cell_ij => null() - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij => null() - - character(len=*), parameter :: Iam = 'cat_enkf_increments' - - real, dimension( N_catd) :: r_x, tmp_dlon - real :: r_y, tmp_dlat - - real, dimension( N_catd) :: srfexc, rzexc, catdef - real, dimension( N_catd) :: ar1, ar2, ar4 - real, dimension( N_catd) :: FT_state - - real, dimension( N_catd,N_ens) :: sfmc, rzmc, prmc - real, dimension( N_catd,N_ens) :: tsurf, tsurf_excl_snow - real, dimension( N_catd,N_ens) :: SWE, asnow - real, dimension( N_catd,N_ens) :: FT_Teff - - real, dimension(N_gt,N_catd,N_ens) :: tp, fice - - real, dimension( N_catd) :: tsurf_ensavg - real, dimension( N_catd) :: SWE_ensavg - real, dimension( N_catd) :: tp1_ensavg - real, dimension( N_catd) :: asnow_ensavg - - type(obs_param_type) :: this_obs_param - - integer :: isnow - real :: asnow_fcst, swe_fcst, swe_ratio, snow_dens, snow_temp, fice_snow - real :: asnow_ana, swe_ana - logical :: log_dum, log_dum2 - real, dimension(N_catd,N_ens) :: swe_incr - real, dimension(N_catd,N_ens,N_snow) :: tmp_wesn, tmp_htsn, tmp_sndz - - real, dimension(N_snow) :: tpsn, fice_snow_vec ! for snow model relayer - real, dimension(N_snow,N_constit) :: rconstit - - logical :: found_Tb_obs - -! ----------------------------------------------------------------------- - - if (logit) write (logunit,*) & - 'cat_enkf_increments(): getting assimilation increments...' - - ! initialize - needed regardless of (local) N_obs - - do kk=1,N_catd - do n_e=1,N_ens - cat_progn_incr(kk,n_e) = 0. - end do - end do - - ! avoid unnecessary work or subroutine calls - - if (N_obs<=0) return ! nothing left to do - - ! more initializations - - N_select_varnames = 0 - N_select_species = 0 - - select_varnames = '' - select_species = -8888 ! intentionally differs from init in get_select_species() - - ! ---------------------------------------------------------------------- - ! - ! IMPORTANT: do *NOT* add MPI calls to the remainder of this subroutine - ! or to subroutines called from there because not all - ! processors continue past this point - ! - ! In future, perhaps make sure that all processors can safely proceed, - ! which is not clear right now. reichle, 26 Sep 2013 - ! - ! ---------------------------------------------------------------------- - - ! compute soil temperature and snow diagnostics for - ! - screening tiles for which increments should not be computed (typically 3d updates) - ! - FT analysis - - ! total SWE - - do kk=1,N_catd - do n_e=1,N_ens - - SWE(kk,n_e) = sum( cat_progn(kk,n_e)%wesn(1:N_snow) ) - - end do - end do - - ! soil moisture, tsurf, and soil temperature diagnostics - - do n_e=1,N_ens - - ! soil moisture - - srfexc = cat_progn(:,n_e)%srfexc - rzexc = cat_progn(:,n_e)%rzexc - catdef = cat_progn(:,n_e)%catdef - - call catch_calc_soil_moist( & - N_catd, cat_param%dzsf, cat_param%vgwmax, & - cat_param%cdcr1, cat_param%cdcr2, cat_param%psis, & - cat_param%bee, cat_param%poros, cat_param%wpwet, & - cat_param%ars1, cat_param%ars2, cat_param%ars3, & - cat_param%ara1, cat_param%ara2, cat_param%ara3, & - cat_param%ara4, cat_param%arw1, cat_param%arw2, & - cat_param%arw3, cat_param%arw4, & - cat_param%bf1, cat_param%bf2, & - srfexc, rzexc, catdef, ar1, ar2, ar4, & - sfmc(:,n_e), rzmc(:,n_e), prmc(:,n_e) ) - - ! tsurf - - call catch_calc_tsurf( N_catd, & - cat_progn(:,n_e)%tc1, cat_progn(:,n_e)%tc2, cat_progn(:,n_e)%tc4, & - catprogn2wesn(N_catd,cat_progn(:,n_e)), & - catprogn2htsn(N_catd,cat_progn(:,n_e)), & - ar1, ar2, ar4, tsurf(:,n_e) ) - - ! tsurf excluding snow - - call catch_calc_tsurf_excl_snow( N_catd, & - cat_progn(:,n_e)%tc1, cat_progn(:,n_e)%tc2, cat_progn(:,n_e)%tc4, & - ar1, ar2, ar4, tsurf_excl_snow(:,n_e) ) - - ! soil temperature - ! - ! NOTE: "tp" is returned in CELSIUS - - call catch_calc_tp( N_catd, cat_param%poros, & - catprogn2ghtcnt(N_catd,cat_progn(:,n_e)), & - tp(:,:,n_e), fice(:,:,n_e) ) - - ! snow cover fraction - - call StieglitzSnow_calc_asnow( N_snow, N_catd, & - catprogn2wesn(N_catd,cat_progn(:,n_e)), asnow(:,n_e) ) - - end do - - ! compute ensemble average of select variables - - SWE_ensavg = 0. - tsurf_ensavg = 0. - tp1_ensavg = 0. - asnow_ensavg = 0. - - do n_e=1,N_ens - - SWE_ensavg = SWE_ensavg + SWE( :,n_e) - tsurf_ensavg = tsurf_ensavg + tsurf( :,n_e) - tp1_ensavg = tp1_ensavg + tp( 1,:,n_e) - asnow_ensavg = asnow_ensavg + asnow( :,n_e) - - end do - - SWE_ensavg = SWE_ensavg /real(N_ens) - tsurf_ensavg = tsurf_ensavg /real(N_ens) - tp1_ensavg = tp1_ensavg /real(N_ens) - asnow_ensavg = asnow_ensavg /real(N_ens) - - ! --------------------------------------------------------------------- - - select_update_type: select case (update_type) - - case (1) select_update_type ! 1d soil moisture analysis; sfmc and/or sfds obs - - ! this 1d update requires that obs are on same tile space as model - - if (logit) write (logunit,*) 'get 1d soil moisture increments; sfmc obs' - - ! disable update_type=1 (b/c it includes catdef in state vector for mineral soil) - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'update_type=1 no longer supported; use update_type=13 instead') - - N_select_varnames = 2 - - select_varnames(1) = 'sfmc' - select_varnames(2) = 'sfds' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 3 - - allocate( State_incr(N_state,N_ens) ) - allocate( select_tilenum(1)) - - allocate(Obs_cov(N_obs,N_obs)) - - call assemble_obs_cov( N_obs, N_obs_param, obs_param, & - Observations(1:N_obs), Obs_cov ) - - do n=1,N_catd - - ! find observations for catchment n - - select_tilenum(1) = l2f(n) - - call get_ind_obs( & - N_obs, Observations, & - 1, select_tilenum, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn(n,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn(n,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn(n,:)%catdef/scale_catdef - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov( & - ind_obs(1:N_selected_obs), ind_obs(1:N_selected_obs)), & - State_incr, & - fcsterr_inflation_fac=fcsterr_inflation_fac ) - - ! assemble cat_progn increments - - cat_progn_incr(n,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(n,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(n,:)%catdef = State_incr(3,:)*scale_catdef - - end if - - end do - - case (2) select_update_type ! 3d soil moisture analysis; sfmc+sfds obs - - ! update each tile separately using all observations within - ! the customized halo around each tile - - if (logit) write (logunit,*) 'get 3d soil moisture increments; sfmc obs' - - ! disable update_type=2 (b/c it includes catdef in state vector for mineral soil) - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'update_type=2 no longer supported; use update_type=13 instead') - - N_select_varnames = 2 - - select_varnames(1) = 'sfmc' - select_varnames(2) = 'sfds' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 3 - - allocate( State_incr(N_state,N_ens)) - allocate( State_lon( N_state )) - allocate( State_lat( N_state )) - - do kk=1,N_catd - - ! find observations within halo around tile kk - - halo_minlon = tile_coord(kk)%com_lon - xcompact - halo_maxlon = tile_coord(kk)%com_lon + xcompact - halo_minlat = tile_coord(kk)%com_lat - ycompact - halo_maxlat = tile_coord(kk)%com_lat + ycompact - - ! simple approach to dateline issue (cut halo back to at most -180:180, -90:90) - ! - reichle, 28 May 2013 - - halo_minlon = max(halo_minlon,-180.) - halo_maxlon = min(halo_maxlon, 180.) - halo_minlat = max(halo_minlat, -90.) - halo_maxlat = min(halo_maxlat, 90.) - - call get_ind_obs_lat_lon_box( & - N_obs, Observations, & - halo_minlon, halo_maxlon, halo_minlat, halo_maxlat, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs>0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn( kk,:)%catdef/scale_catdef - - State_lon( :) = tile_coord(kk )%com_lon - State_lat( :) = tile_coord(kk )%com_lat - - allocate(Obs_cov(N_selected_obs,N_selected_obs)) - - call assemble_obs_cov( N_selected_obs, N_obs_param, obs_param, & - Observations(ind_obs(1:N_selected_obs)), Obs_cov ) - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov, & - State_incr, State_lon, State_lat, xcompact, ycompact, & - fcsterr_inflation_fac ) - - deallocate(Obs_cov) - - ! assemble cat_progn increments - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(kk,:)%catdef = State_incr(3,:)*scale_catdef - - end if - - end do - - ! ---------------------------------- - - case (3) select_update_type ! 1d Tskin analysis; tskin obs - - ! update_type = 3: 1d Tskin (incr NOT applied, use w/ cat bias corr) - - ! this 1d update requires that obs are on same tile space as model - - if (logit) write (logunit,*) 'get 1d Tskin increments; tskin obs' - - N_select_varnames = 1 - - select_varnames(1) = 'tskin' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 3 - - allocate( State_incr(N_state,N_ens) ) - allocate( select_tilenum(1)) - - allocate(Obs_cov(N_obs,N_obs)) - - call assemble_obs_cov( N_obs, N_obs_param, obs_param, & - Observations(1:N_obs), Obs_cov ) - - do n=1,N_catd - - ! find observations for catchment n - - select_tilenum(1) = l2f(n) - - call get_ind_obs( & - N_obs, Observations, & - 1, select_tilenum, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn(n,:)%tc1/scale_temp - State_incr(2,:) = cat_progn(n,:)%tc2/scale_temp - State_incr(3,:) = cat_progn(n,:)%tc4/scale_temp - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov( & - ind_obs(1:N_selected_obs), ind_obs(1:N_selected_obs)), & - State_incr, & - fcsterr_inflation_fac=fcsterr_inflation_fac ) - - ! assemble cat_progn increments - - cat_progn_incr(n,:)%tc1 = State_incr(1,:)*scale_temp - cat_progn_incr(n,:)%tc2 = State_incr(2,:)*scale_temp - cat_progn_incr(n,:)%tc4 = State_incr(3,:)*scale_temp - - end if - - end do - - ! ---------------------------------- - - case (4,5) select_update_type ! 1d Tskin/ght(1) analysis; tskin obs - - ! update_type = 4: 1d Tskin/ght(1) (incr applied, use w/ or w/o cat bias corr) - ! update_type = 5: 1d Tskin/ght(1) (incr NOT applied, use w/ cat bias corr) - - ! this 1d update requires that obs are on same tile space as model - - if (logit) write (logunit,*) 'get 1d Tskin/ght(1) increments; tskin obs' - - N_select_varnames = 1 - - select_varnames(1) = 'tskin' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 4 - - allocate( State_incr(N_state,N_ens) ) - allocate( select_tilenum(1)) - - allocate(Obs_cov(N_obs,N_obs)) - - call assemble_obs_cov( N_obs, N_obs_param, obs_param, & - Observations(1:N_obs), Obs_cov ) - - do n=1,N_catd - - ! find observations for catchment n - - select_tilenum(1) = l2f(n) - - call get_ind_obs( & - N_obs, Observations, & - 1, select_tilenum, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn(n,:)%tc1/scale_temp - State_incr(2,:) = cat_progn(n,:)%tc2/scale_temp - State_incr(3,:) = cat_progn(n,:)%tc4/scale_temp - State_incr(4,:) = cat_progn(n,:)%ght(1)/scale_ght1 - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov( & - ind_obs(1:N_selected_obs), ind_obs(1:N_selected_obs)), & - State_incr, & - fcsterr_inflation_fac=fcsterr_inflation_fac ) - - ! assemble cat_progn increments - - cat_progn_incr(n,:)%tc1 = State_incr(1,:)*scale_temp - cat_progn_incr(n,:)%tc2 = State_incr(2,:)*scale_temp - cat_progn_incr(n,:)%tc4 = State_incr(3,:)*scale_temp - cat_progn_incr(n,:)%ght(1) = State_incr(4,:)*scale_ght1 - - end if - - end do - - ! ---------------------------------- - - case (6) select_update_type ! 1d soil moisture/Tskin/ght(1) analysis; Tb obs - - ! this 1d update requires that obs are on same tile space as model - - if (logit) write (logunit,*) 'get 1d soil moisture/Tskin/ght(1) increments; Tb obs' - - N_select_varnames = 1 - - select_varnames(1) = 'Tb' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 7 - - allocate( State_incr(N_state,N_ens) ) - allocate( select_tilenum(1)) - - allocate(Obs_cov(N_obs,N_obs)) - - call assemble_obs_cov( N_obs, N_obs_param, obs_param, & - Observations(1:N_obs), Obs_cov ) - - do n=1,N_catd - - ! find observations for catchment n - - select_tilenum(1) = l2f(n) - - call get_ind_obs( & - N_obs, Observations, & - 1, select_tilenum, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn(n,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn(n,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn(n,:)%catdef/scale_catdef - - State_incr(4,:) = cat_progn(n,:)%tc1/scale_temp - State_incr(5,:) = cat_progn(n,:)%tc2/scale_temp - State_incr(6,:) = cat_progn(n,:)%tc4/scale_temp - State_incr(7,:) = cat_progn(n,:)%ght(1)/scale_ght1 - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov( & - ind_obs(1:N_selected_obs), ind_obs(1:N_selected_obs)), & - State_incr, & - fcsterr_inflation_fac=fcsterr_inflation_fac ) - - ! assemble cat_progn increments - - cat_progn_incr(n,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(n,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(n,:)%catdef = State_incr(3,:)*scale_catdef - - cat_progn_incr(n,:)%tc1 = State_incr(4,:)*scale_temp - cat_progn_incr(n,:)%tc2 = State_incr(5,:)*scale_temp - cat_progn_incr(n,:)%tc4 = State_incr(6,:)*scale_temp - cat_progn_incr(n,:)%ght(1) = State_incr(7,:)*scale_ght1 - - end if - - end do - - ! ---------------------------------- - - case (7) select_update_type ! 3d Tskin/ght(1) analysis; tskin obs - - ! update each tile separately using all observations within - ! the customized halo around each tile - ! - ! replaces previous approach ("3d update over each grid cell") - ! - reichle, 26 March 2014 - - if (logit) write (logunit,*) 'get 3d Tskin/ght(1) increments; tskin obs' - - N_select_varnames = 1 - - select_varnames(1) = 'tskin' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state = 4 - - allocate( State_incr(N_state,N_ens)) - allocate( State_lon( N_state )) - allocate( State_lat( N_state )) - - do kk=1,N_catd - - ! find observations within halo around tile kk - - halo_minlon = tile_coord(kk)%com_lon - xcompact - halo_maxlon = tile_coord(kk)%com_lon + xcompact - halo_minlat = tile_coord(kk)%com_lat - ycompact - halo_maxlat = tile_coord(kk)%com_lat + ycompact - - ! simple approach to dateline issue (cut halo back to at most -180:180, -90:90) - ! - reichle, 28 May 2013 - - halo_minlon = max(halo_minlon,-180.) - halo_maxlon = min(halo_maxlon, 180.) - halo_minlat = max(halo_minlat, -90.) - halo_maxlat = min(halo_maxlat, 90.) - - call get_ind_obs_lat_lon_box( & - N_obs, Observations, & - halo_minlon, halo_maxlon, halo_minlat, halo_maxlat, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs>0) then - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - State_incr(1,:) = cat_progn( kk,:)%tc1 /scale_temp - State_incr(2,:) = cat_progn( kk,:)%tc2 /scale_temp - State_incr(3,:) = cat_progn( kk,:)%tc4 /scale_temp - State_incr(4,:) = cat_progn( kk,:)%ght(1)/scale_ght1 - - State_lon( :) = tile_coord(kk )%com_lon - State_lat( :) = tile_coord(kk )%com_lat - - allocate(Obs_cov(N_selected_obs,N_selected_obs)) - - call assemble_obs_cov( N_selected_obs, N_obs_param, obs_param, & - Observations(ind_obs(1:N_selected_obs)), Obs_cov ) - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov, & - State_incr, State_lon, State_lat, xcompact, ycompact, & - fcsterr_inflation_fac ) - - deallocate(Obs_cov) - - ! assemble cat_progn increments - - cat_progn_incr(kk,:)%tc1 = State_incr(1,:)*scale_temp - cat_progn_incr(kk,:)%tc2 = State_incr(2,:)*scale_temp - cat_progn_incr(kk,:)%tc4 = State_incr(3,:)*scale_temp - cat_progn_incr(kk,:)%ght(1) = State_incr(4,:)*scale_ght1 - - end if - - end do - - ! ---------------------------------- - - case (8,10) select_update_type ! 3d soil moisture/Tskin/ght(1) analysis; Tb obs - - ! update each tile separately using all observations within customized halo around each tile - ! - ! state vector includes different subsets of Catchment model soil moisture prognostics: - ! - ! update_type | subset of tiles | state vector - ! =================================================================================================== - ! 8 | all | srfexc, rzexc, catdef, tc1, tc2, tc4, ght1 - ! --------------------------------------------------------------------------------------------------- - ! 10 | PEATCLSM tiles | srfexc, rzexc, catdef, tc1, tc2, tc4, ght1 - ! | otherwise | srfexc, rzexc, tc1, tc2, tc4, ght1 (incl. NLv4 peat tiles) - ! --------------------------------------------------------------------------------------------------- - ! - ! reichle, 27 Nov 2017 - ! reichle, 20 Feb 2022 - modified for PEATCLSM - - if (logit) write (logunit,*) 'get 3d soil moisture/Tskin/ght(1) increments; Tb obs' - - N_select_varnames = 1 - - select_varnames(1) = 'Tb' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - N_state_max = 7 - - allocate( State_incr(N_state_max,N_ens)) - allocate( State_lon( N_state_max )) - allocate( State_lat( N_state_max )) - - do kk=1,N_catd - - ! compute increments only snow-free and non-frozen tiles - - if ( (SWE_ensavg(kk) < SWE_threshold) .and. & - (tp1_ensavg(kk) > tp1_threshold) ) then - - ! find observations within halo around tile kk - - halo_minlon = tile_coord(kk)%com_lon - xcompact - halo_maxlon = tile_coord(kk)%com_lon + xcompact - halo_minlat = tile_coord(kk)%com_lat - ycompact - halo_maxlat = tile_coord(kk)%com_lat + ycompact - - ! simple approach to dateline issue (cut halo back to at most -180:180, -90:90) - ! - reichle, 28 May 2013 - - halo_minlon = max(halo_minlon,-180.) - halo_maxlon = min(halo_maxlon, 180.) - halo_minlat = max(halo_minlat, -90.) - halo_maxlat = min(halo_maxlat, 90.) - - call get_ind_obs_lat_lon_box( & - N_obs, Observations, & - halo_minlon, halo_maxlon, halo_minlat, halo_maxlat, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs>0) then - - if ( (update_type== 8 ) .or. & - (update_type==10 .and. cat_param(kk)%poros>=PEATCLSM_POROS_THRESHOLD) & - ) then - - N_state = 7 ! srfexc, rzexc, catdef, tc1, tc2, tc4, ght1 - - else - - N_state = 6 ! srfexc, rzexc, tc1, tc2, tc4, ght1 - - end if - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - if ( N_state==7 ) then - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn( kk,:)%catdef/scale_catdef ! catdef in State - - State_incr(4,:) = cat_progn( kk,:)%tc1 /scale_temp - State_incr(5,:) = cat_progn( kk,:)%tc2 /scale_temp - State_incr(6,:) = cat_progn( kk,:)%tc4 /scale_temp - State_incr(7,:) = cat_progn( kk,:)%ght(1)/scale_ght1 - - else - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - - State_incr(3,:) = cat_progn( kk,:)%tc1 /scale_temp - State_incr(4,:) = cat_progn( kk,:)%tc2 /scale_temp - State_incr(5,:) = cat_progn( kk,:)%tc4 /scale_temp - State_incr(6,:) = cat_progn( kk,:)%ght(1)/scale_ght1 - - end if - - State_lon( :) = tile_coord(kk )%com_lon - State_lat( :) = tile_coord(kk )%com_lat - - allocate(Obs_cov(N_selected_obs,N_selected_obs)) - - call assemble_obs_cov( N_selected_obs, N_obs_param, obs_param, & - Observations(ind_obs(1:N_selected_obs)), Obs_cov ) - - ! EnKF update - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov, & - State_incr(1:N_state,:), & - State_lon( 1:N_state ), & - State_lat( 1:N_state ), & - xcompact, ycompact, & - fcsterr_inflation_fac ) - - deallocate(Obs_cov) - - ! assemble cat_progn increments - - if (N_state==7) then - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(kk,:)%catdef = State_incr(3,:)*scale_catdef ! catdef in State - - cat_progn_incr(kk,:)%tc1 = State_incr(4,:)*scale_temp - cat_progn_incr(kk,:)%tc2 = State_incr(5,:)*scale_temp - cat_progn_incr(kk,:)%tc4 = State_incr(6,:)*scale_temp - cat_progn_incr(kk,:)%ght(1) = State_incr(7,:)*scale_ght1 - - else - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - - cat_progn_incr(kk,:)%tc1 = State_incr(3,:)*scale_temp - cat_progn_incr(kk,:)%tc2 = State_incr(4,:)*scale_temp - cat_progn_incr(kk,:)%tc4 = State_incr(5,:)*scale_temp - cat_progn_incr(kk,:)%ght(1) = State_incr(6,:)*scale_ght1 - - end if - - end if - - end if ! thresholds - - end do - - ! ---------------------------------- - - case (9) select_update_type ! 1d Tskin/ght(1) analysis; FT obs - - if (logit) write (logunit,*) 'get 1d Tskin/ght(1) increments; FT obs' - - ! rule-based FT analysis similar to Farhadi et al., JHM, 2014 - - ! "1d" update using obs that may or may not be in the model tile space. - ! This approach differs from the early "1d" updates that assume obs are - ! provided in the model tile space. - ! The "1d" update here implies that tiles are not updated using obs - ! beyond the obs FOV, even if model errors are spatially correlated - ! beyond the obs FOV. - ! - reichle, 20 Oct 2014 - - ! determine "effective" temperature for landscape-average FT - - do n_e=1,N_ens - - ! tp must be in CELSIUS; FT_Teff is returned in Kelvin - - call catch_calc_FT( N_catd, asnow(:,n_e), tp(1,:,n_e), & - tsurf_excl_snow(:,n_e), FT_state(:), FT_Teff(:,n_e ) ) - - end do - - ! identify species ID numbers of interest - - N_select_varnames = 1 - - select_varnames(1) = 'FT' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - - - ! determine appropriate lat/lon distances (in units of [deg]) - ! within which to look for obs (see comment above) - - tmp_dlon = FOV_threshold - TINY(tmp_dlon) ! initialize - tmp_dlat = FOV_threshold - TINY(tmp_dlat) ! initialize - - ! find maximum FOV in units of [deg] across all obs params - - do ii=1,N_select_species - - this_obs_param = obs_param(select_species(ii)) - - if ( trim(this_obs_param%FOV_units)=='deg' ) then - - tmp_dlon = max( tmp_dlon, this_obs_param%FOV ) - tmp_dlat = max( tmp_dlat, this_obs_param%FOV ) - - elseif ( trim(this_obs_param%FOV_units)=='km' ) then - - ! convert from [km] (FOV) to [deg] - - call dist_km2deg( & - this_obs_param%FOV, N_catd, tile_coord%com_lat, r_x, r_y ) - - tmp_dlon = max( tmp_dlon, r_x ) - tmp_dlat = max( tmp_dlat, r_y ) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units') - - end if - - end do - - - ! loop through tiles and compute increments - - do kk=1,N_catd - - ! find observations near tile kk - - ! TO DO: MAKE DLAT DEPENDENT ON LAT FOR SMAP EASE GRID OBS?? - ! (For obs on the EASE grid the current approach might not work well.) - - tmp_minlon = tile_coord(kk)%com_lon - tmp_dlon(kk) - tmp_maxlon = tile_coord(kk)%com_lon + tmp_dlon(kk) - tmp_minlat = tile_coord(kk)%com_lat - tmp_dlat - tmp_maxlat = tile_coord(kk)%com_lat + tmp_dlat - - ! simple approach to dateline issue (cut back to at most -180:180, -90:90) - - tmp_minlon = max(tmp_minlon,-180.) - tmp_maxlon = min(tmp_maxlon, 180.) - tmp_minlat = max(tmp_minlat, -90.) - tmp_maxlat = min(tmp_maxlat, 90.) - - call get_ind_obs_lat_lon_box( & - N_obs, Observations, & - tmp_minlon, tmp_maxlon, tmp_minlat, tmp_maxlat, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! compute average obs value - - tmp_obs = sum(Observations(ind_obs(1:N_selected_obs))%obs) - - tmp_obs = tmp_obs/real(N_selected_obs) - - ! compute increments - - do n_e=1,N_ens - - ! TO DO: RESTRICT ANALYSIS TO SITUATIONS WHERE OBS AND MODEL - ! CONTRADICT EACH OTHER - - ! TO DO: COMPUTE deltaT BASED ON ENS AVG TEFF??? - ! USE ENS AVG OF ASNOW VS. THRESHOLD??? - - ! determine target (landscape-average) temperature increment - - if (tmp_obs <= FT_ANA_FT_THRESHOLD) then - - ! obs thawed --> deltaT >= 0. - - deltaT = max( (FT_ANA_LOWERBOUND_TEFF - FT_Teff(kk,n_e)), 0.) - - elseif (asnow(kk,n_e) <= FT_ANA_LOWERBOUND_ASNOW) then - - ! obs frozen and model snow below threshold --> deltaT <= 0. - - deltaT = min( (FT_ANA_UPPERBOUND_TEFF - FT_Teff(kk,n_e)), 0.) - - end if - - ! set temperature increment for each component temperature - ! (do nothing if deltaT=0. because cat_progn_incr was initialized to 0.) - - if (abs(deltaT)>0.) then - - ! TO DO: SHOULD PHASE CHANGE BE PREVENTED FOR TC1, TC2, TC4 AS WELL? - ! SHOULD PHASE CHANGE BE PREVENTED BASED ON LAND COVER/CSOIL? - - ! surface temperature increments - - cat_progn_incr(kk,n_e)%tc1 = deltaT - cat_progn_incr(kk,n_e)%tc2 = deltaT - cat_progn_incr(kk,n_e)%tc4 = deltaT - - ! soil temperature increment - - ght1_minus = cat_progn(kk,n_e)%ght(1) ! model forecast - - fice_minus = fice(1,kk,n_e) ! model forecast - - tp1_minus = tp(1,kk,n_e) ! model forecast [CELSIUS] - - fice_plus = fice_minus ! ice fraction does not change - - tp1_plus = tp1_minus + deltaT ! tentative tp1 analysis [CELSIUS] - - ! avoid phase change of soil temp - - if ((tp1_minus*tp1_plus) < 0.) tp1_plus = 0. - - ! compute ght1_plus from tp1_plus and fice_plus - - call catch_calc_ght( cat_param(kk)%dzgt(1), & - cat_param(kk)%poros, tp1_plus, fice_plus, ght1_plus ) - - cat_progn_incr(kk,n_e)%ght(1) = ght1_plus - ght1_minus - - end if - - end do - - end if - - end do - - ! ---------------------------------- - - case (11) select_update_type ! 1d snow analysis (Toure et al. 2018 empirical gain); snow cover fraction obs - - if (logit) write (logunit, *) 'get 1d snow increments (Toure et al. 2018 empirical gain); snow cover fraction obs' - - ! ensure that max SWE increment parameter is less than WEMIN; larger increments make no sense because - ! at SWE=WEMIN, the tile is fully snow covered (asnow=1) - - if (SCF_ANA_MAXINCRSWE>WEMIN) call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'must use SCF_ANA_MAXINCRSWE<=WEMIN') - - ! identify the obs species of interest - - N_select_varnames = 1 - - select_varnames(1) = 'asnow' - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - allocate(select_tilenum(1)) - - swe_incr = 0. ! total SWE increment; initialize to NO CHANGE - - ! loop through tiles and compute increments - - do kk=1,N_catd - - ! find observations for tile kk - - select_tilenum(1) = l2f(kk) - - call get_ind_obs( & - N_obs, Observations, & - 1, select_tilenum, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs > 0) then - - ! average in case there are multiple "asnow" obs (e.g., from MODIS and VIIRS) - - tmp_obs = sum(Observations(ind_obs(1:N_selected_obs))%obs) - - if (N_selected_obs > 1) tmp_obs = tmp_obs/real(N_selected_obs) - - do n_e=1,N_ens ! compute analysis separately for each ensemble member - - ! 1. Diagnose model forecast snow cover area fraction and total SWE - - asnow_fcst = asnow(kk,n_e) - swe_fcst = sum(cat_progn(kk,n_e)%wesn(1:N_snow)) - - ! 2. Calculate SWE increment based on modified eq 1 of Toure et al (2018) - - if (asnow_fcst .lt. tmp_obs * SCF_ANA_ALPHA) then - - ! ADD SNOW: Forecast SCF is less than observed SCF (after "bias" adjustment with alpha) - - swe_incr(kk,n_e) = SCF_ANA_MAXINCRSWE * (tmp_obs - asnow_fcst/SCF_ANA_ALPHA) - - elseif (tmp_obs .lt. SCF_ANA_BETA) then - - ! REMOVE SNOW: Simulated SCF is greater than observed SCF (after "bias" adjustment) - ! and observed SCF is less than beta threshold - - swe_incr(kk,n_e) = (-1.) * SCF_ANA_MAXINCRSWE * asnow_fcst * (1. - tmp_obs/SCF_ANA_BETA) - - else - - cycle ! NO CHANGE, skip rest of increment calcs and go straight to next ens member - - endif ! (Toure et al. 2018 Equation 1) - - ! 3. Derive SWE, snow heat content, and snow depth increments for each layer from total SWE increment - - swe_ana = max(swe_fcst + swe_incr(kk,n_e), 0.0) ! total SWE after analysis - - call StieglitzSnow_calc_asnow( swe_ana, asnow_ana ) ! asnow after analysis - - if (swe_fcst>=StieglitzSnow_MINSWE) then - swe_ratio = swe_ana / swe_fcst - else - swe_ratio = MAPL_UNDEF ! swe_ratio unreliable; set to MAPL_UNDEF to expose inadvertent use - end if - - ! loop through snow layers and compute SWE, snow heat content, and snow depth analysis for each layer - - do isnow=1,N_snow - - if (asnow_ana == 0.0) then - - ! no snow in analysis, remove all snow - - tmp_wesn(kk,n_e,isnow) = 0.0 - tmp_htsn(kk,n_e,isnow) = 0.0 - tmp_sndz(kk,n_e,isnow) = 0.0 - - elseif (swe_fcst < StieglitzSnow_MINSWE) then - - ! too little snow in forecast, use generic properties for added snow - - tmp_wesn(kk,n_e,isnow) = swe_ana / N_snow ! distribute SWE evenly across layers - - ! assign heat content for snow at 0 deg C and without liquid water content (100% frozen) - ! (based on StieglitzSnow: htsn = (CPW*tsnow - fice*MAPL_ALHF)*swe ) - - tmp_htsn(kk,n_e,isnow) = (0.0 - MAPL_ALHF)*tmp_wesn(kk,n_e,isnow) - - ! assign snow depth consistent with density of freshly fallen snow (must have SCF_ANA_MAXINCRSWE<=WEMIN) - - tmp_sndz(kk,n_e,isnow) = (WEMIN / RHOFS) / N_snow - - else - - ! snow in forecast and analysis, derive properties of analysis snow from properties of forecast snow - - ! update SWE: - - tmp_wesn(kk,n_e,isnow) = cat_progn(kk,n_e)%wesn(isnow) * swe_ratio - - ! update snow heat content (keep snow temperature constant): - - call StieglitzSnow_calc_tpsnow( cat_progn(kk,n_e)%htsn(isnow), cat_progn(kk,n_e)%wesn(isnow), & - snow_temp, fice_snow, log_dum, log_dum2, .false. ) - - tmp_htsn(kk,n_e,isnow) = (StieglitzSnow_CPW*snow_temp - fice_snow*MAPL_ALHF)*tmp_wesn(kk,n_e,isnow) - - ! update snow depth: - - if (asnow_ana < 1. .and. asnow_fcst < 1.) then - - ! keep snow depth constant when less than full snow cover in fcst and ana - - tmp_sndz(kk,n_e,isnow) = cat_progn(kk,n_e)%sndz(isnow) - - else - - ! compute analysis snow depth by keeping snow density constant - ! - ! in this case, it is possible that either asnow_fcst<1 or asnow_ana<1; - ! when computing density or depth, make sure that SWE value (which is per unit area) is - ! adjusted to reflect SWE value (per unit area) in the snow-covered fraction of the tile - - ! i) diagnose (layer-specific) forecast snow density - - snow_dens = ( cat_progn(kk,n_e)%wesn(isnow)/asnow_fcst ) / cat_progn(kk,n_e)%sndz(isnow) - - ! ii) diagnose analysis snow depth using forecast density - - tmp_sndz(kk,n_e,isnow) = ( tmp_wesn(kk,n_e,isnow)/asnow_ana ) / snow_dens - - end if - - end if - - end do ! isnow=1,N_snow (compute SWE, snow heat content, and snow depth analysis for each layer) - - ! 4. Relayer to balance the snow column (call with optional args for adjustment of htsnn) - - call StieglitzSnow_relayer( N_snow, N_constit, & - MAPL_LAND, CATCH_SNOW_DZPARAM, & - tmp_htsn(kk,n_e,1:N_snow), & - tmp_wesn(kk,n_e,1:N_snow), & - tmp_sndz(kk,n_e,1:N_snow), & - rconstit, tpsn, fice_snow_vec ) - - ! print the old and new swe, heat content and snow density - - !if (logit) write (logunit, *) & - ! 'fcst_wesn = ', cat_progn(kk, n_e)%wesn(1:N_snow), & - ! 'tmp_wesn = ', tmp_wesn( kk,n_e, 1:N_snow), & - ! 'fcst_htsn = ', cat_progn(kk, n_e)%htsn(1:N_snow), & - ! 'tmp_htsn = ', tmp_htsn( kk, n_e, 1:N_snow), & - ! 'fcst_sndz = ', cat_progn(kk, n_e)%sndz(1:N_snow), & - ! 'tmp_sndz = ', tmp_sndz( kk ,n_e, 1:N_snow), & - ! '--------------------------------------' - - ! 5. Diagnose increments - - cat_progn_incr(kk,n_e)%wesn(1:N_snow) = tmp_wesn(kk,n_e,1:N_snow) - cat_progn(kk,n_e)%wesn(1:N_snow) - cat_progn_incr(kk,n_e)%htsn(1:N_snow) = tmp_htsn(kk,n_e,1:N_snow) - cat_progn(kk,n_e)%htsn(1:N_snow) - cat_progn_incr(kk,n_e)%sndz(1:N_snow) = tmp_sndz(kk,n_e,1:N_snow) - cat_progn(kk,n_e)%sndz(1:N_snow) - - end do ! n_e=1,N_ens - - end if ! if (N_selected_obs > 0) - - end do ! kk=1,N_catd - - ! ---------------------------------- - - case (13) select_update_type ! 3d soil moisture/Tskin/ght(1) analysis; Tb+sfmc+sfds obs - - ! update each tile separately using all observations within customized halo around each tile - ! - ! state vector differs for each tile depending on assimilated obs and soil type - ! - ! obs | soil | N_state | state vector - ! ---------------------------------------------------------------------- - ! sfcm/sfds only | mineral | 2 | srfexc, rzexc - ! sfcm/sfds only | peat | 3 | srfexc, rzexc, catdef, - ! sfcm/sfds & Tb | mineral | 6 | srfexc, rzexc, tc[x], ght(1) - ! sfcm/sfds & Tb | peat | 7 | srfexc, rzexc, catdef, tc[x], ght(1) - ! - ! amfox+rreichle, 26 Feb 2024 - - if (logit) write (logunit,*) 'get 3d soil moisture/Tskin/ght(1) increments; Tb+sfmc obs' - - N_select_varnames = 0 - - do ii = 1,N_obs_param - if (trim(obs_param(ii)%varname) == 'Tb') then - N_select_varnames = N_select_varnames + 1 - select_varnames(N_select_varnames) = 'Tb' - exit - end if - end do - - do ii = 1,N_obs_param - if (trim(obs_param(ii)%varname) == 'sfmc') then - N_select_varnames = N_select_varnames + 1 - select_varnames(N_select_varnames) = 'sfmc' - exit - end if - end do - - do ii = 1,N_obs_param - if (trim(obs_param(ii)%varname) == 'sfds') then - N_select_varnames = N_select_varnames + 1 - select_varnames(N_select_varnames) = 'sfds' - exit - end if - end do - - ! Will get all species associated with Tb or sfds observations - - call get_select_species( & - N_select_varnames, select_varnames(1:N_select_varnames), & - N_obs_param, obs_param, N_select_species, select_species ) - - ! Determine which species are Tb - - call get_select_species(1, 'Tb', N_obs_param, obs_param, N_select_species_Tb, select_species_Tb ) - - N_state_max = 7 - - allocate( State_incr(N_state_max,N_ens)) - allocate( State_lon( N_state_max )) - allocate( State_lat( N_state_max )) - - do kk=1,N_catd - - N_state = 2 ! initialize (always have srfexc and rzexc in state vector) - - ! compute increments only for snow-free and non-frozen tiles - - if ( (SWE_ensavg(kk) < SWE_threshold) .and. & - (tp1_ensavg(kk) > tp1_threshold) ) then - - ! find observations within halo around tile kk - - halo_minlon = tile_coord(kk)%com_lon - xcompact - halo_maxlon = tile_coord(kk)%com_lon + xcompact - halo_minlat = tile_coord(kk)%com_lat - ycompact - halo_maxlat = tile_coord(kk)%com_lat + ycompact - - ! simple approach to dateline issue (cut halo back to at most -180:180, -90:90) - ! - reichle, 28 May 2013 - - halo_minlon = max(halo_minlon,-180.) - halo_maxlon = min(halo_maxlon, 180.) - halo_minlat = max(halo_minlat, -90.) - halo_maxlat = min(halo_maxlat, 90.) - - call get_ind_obs_lat_lon_box( & - N_obs, Observations, & - halo_minlon, halo_maxlon, halo_minlat, halo_maxlat, & - N_select_species, select_species(1:N_select_species), & - N_selected_obs, ind_obs ) - - if (N_selected_obs>0) then - - ! Determine if Tb observations are present - - found_Tb_obs = .false. - - do ii = 1,N_select_species_Tb - do jj = 1,N_selected_obs - if (select_species_Tb(ii) == Observations(ind_obs(jj))%species) then - found_Tb_obs = .true. - exit - end if - end do - if (found_Tb_obs) exit - end do - - ! if Tb_obs are present, add tc[X] and ght(1) to state vector - - if (found_Tb_obs) N_state = N_state + 4 - - ! for peatland tile, add catdef to state vector - - if (cat_param(kk)%poros>=PEATCLSM_POROS_THRESHOLD) N_state = N_state + 1 - - ! assemble State_minus - ! (on input, cat_progn contains cat_progn_minus) - - if ( N_state==2 ) then - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - - elseif ( N_state==3 ) then - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn( kk,:)%catdef/scale_catdef ! catdef in State - - elseif ( N_state==6 ) then - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - - State_incr(4,:) = cat_progn( kk,:)%tc1 /scale_temp - State_incr(5,:) = cat_progn( kk,:)%tc2 /scale_temp - State_incr(6,:) = cat_progn( kk,:)%tc4 /scale_temp - State_incr(7,:) = cat_progn( kk,:)%ght(1)/scale_ght1 - - else - - State_incr(1,:) = cat_progn( kk,:)%srfexc/scale_srfexc - State_incr(2,:) = cat_progn( kk,:)%rzexc /scale_rzexc - State_incr(3,:) = cat_progn( kk,:)%catdef/scale_catdef ! catdef in State - - State_incr(3,:) = cat_progn( kk,:)%tc1 /scale_temp - State_incr(4,:) = cat_progn( kk,:)%tc2 /scale_temp - State_incr(5,:) = cat_progn( kk,:)%tc4 /scale_temp - State_incr(6,:) = cat_progn( kk,:)%ght(1)/scale_ght1 - - end if - - State_lon( :) = tile_coord(kk )%com_lon - State_lat( :) = tile_coord(kk )%com_lat - - allocate(Obs_cov(N_selected_obs,N_selected_obs)) - - call assemble_obs_cov( N_selected_obs, N_obs_param, obs_param, & - Observations(ind_obs(1:N_selected_obs)), Obs_cov ) - - call enkf_increments( & - N_state, N_selected_obs, N_ens, & - Observations(ind_obs(1:N_selected_obs)), & - Obs_pred(ind_obs(1:N_selected_obs),:), & - Obs_pert(ind_obs(1:N_selected_obs),:), & - Obs_cov, & - State_incr(1:N_state,:), & - State_lon( 1:N_state ), & - State_lat( 1:N_state ), & - xcompact, ycompact, & - fcsterr_inflation_fac ) - - deallocate(Obs_cov) - - ! assemble cat_progn increments - - if ( N_state==2 ) then - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - - elseif ( N_state==3 ) then - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(kk,:)%catdef = State_incr(3,:)*scale_catdef ! catdef in State - - elseif ( N_state==6 ) then - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - - cat_progn_incr(kk,:)%tc1 = State_incr(4,:)*scale_temp - cat_progn_incr(kk,:)%tc2 = State_incr(5,:)*scale_temp - cat_progn_incr(kk,:)%tc4 = State_incr(6,:)*scale_temp - cat_progn_incr(kk,:)%ght(1) = State_incr(7,:)*scale_ght1 - - else - - cat_progn_incr(kk,:)%srfexc = State_incr(1,:)*scale_srfexc - cat_progn_incr(kk,:)%rzexc = State_incr(2,:)*scale_rzexc - cat_progn_incr(kk,:)%catdef = State_incr(3,:)*scale_catdef ! catdef in State - - cat_progn_incr(kk,:)%tc1 = State_incr(3,:)*scale_temp - cat_progn_incr(kk,:)%tc2 = State_incr(4,:)*scale_temp - cat_progn_incr(kk,:)%tc4 = State_incr(5,:)*scale_temp - cat_progn_incr(kk,:)%ght(1) = State_incr(6,:)*scale_ght1 - - end if - - end if - - end if ! thresholds - - end do - - ! ---------------------------------- - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown update_type') - - end select select_update_type - - ! clean up - - if (allocated( State_incr )) deallocate( State_incr ) - if (allocated( State_lon )) deallocate( State_lon ) - if (allocated( State_lat )) deallocate( State_lat ) - if (allocated( select_tilenum )) deallocate( select_tilenum ) - - if (allocated( Obs_cov )) deallocate( Obs_cov ) - - if (associated(N_tile_in_cell_ij )) deallocate( N_tile_in_cell_ij ) - if (associated(tile_num_in_cell_ij)) deallocate( tile_num_in_cell_ij ) - - ! NO checks of prognostics after update, this is now done after - ! increments have been applied. - ! - reichle, 18 Oct 2005 - - end subroutine cat_enkf_increments - - ! ********************************************************************** - - subroutine get_select_species( & - N_select_varnames, select_varnames, N_obs_param, obs_param, & - N_select_species, select_species ) - - ! find out obs species ID numbers ("obs_param%species") that correspond - ! to a set of obs species variables names ("obs_param%varname") - ! - reichle, 16 Oct 2014 - - implicit none - - integer, intent(in) :: N_select_varnames - integer, intent(in) :: N_obs_param - - character(len=*), dimension(N_select_varnames), intent(in) :: select_varnames - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - integer, intent(out) :: N_select_species - integer, dimension(N_obs_param), intent(out) :: select_species - - ! local variables - - integer :: ii, kk - - ! ----------------------------------------------------------------- - - ! initialize - - select_species = -7777 - - kk = 0 - - if (N_select_varnames > 0) then - - do ii=1,N_obs_param - - if (any(trim(obs_param(ii)%varname)==select_varnames)) then - - kk = kk+1 - - select_species(kk) = obs_param(ii)%species - - end if - - end do - - end if - - N_select_species = kk - - end subroutine get_select_species - - - ! ********************************************************************** - - subroutine get_ind_obs( & - N_obs, Observations, & - N_select_tilenum, select_tilenum, & - N_select_species, select_species, & - N_selected_obs, ind_obs ) - - ! find the (index vector for) observations matching a given selection - ! of catchments or observation types - ! - ! the vector select_tilenum of length N_select_tilenum contains the - ! catchment numbers to be selected. - ! if N_select_tilenum is zero, all catchments are selected - ! - ! the vector select_species of length N_select_species contains the - ! species IDs to be selected. - ! if N_select_species is zero, all species are selected - ! - ! the indices (relative to "Observations") of matching observations - ! are returned in the first "N_selected_obs" components of the - ! vector "ind_obs" (which must be allocated to (maximum) length "N_obs" - ! by the calling routine) - ! - ! simplified using "any()" - reichle, 16 Oct 2014 - - implicit none - - integer, intent(in) :: N_obs, N_select_tilenum, N_select_species - - type(obs_type), intent(in), dimension(N_obs) :: Observations - - integer, intent(in), dimension(N_select_tilenum) :: select_tilenum - integer, intent(in), dimension(N_select_species) :: select_species - - integer, intent(out) :: N_selected_obs - - integer, intent(out), dimension(N_obs) :: ind_obs - - ! --------------------------- - - ! locals - - integer :: i, k - - - - ! -------------------------------------------------------------- - - if (N_select_species==0 .and. N_select_tilenum==0) then - - ! all observations are selected - - do i=1,N_obs - ind_obs(i) = i - end do - - N_selected_obs = N_obs - - else if (N_select_species==0) then ! select given catchments - - k = 0 ! counter for selected obs - - do i=1,N_obs - - if (any(Observations(i)%tilenum == select_tilenum)) then - - k = k+1 - ind_obs(k) = i - - end if - - end do - - N_selected_obs = k - - else if (N_select_tilenum==0) then ! select given species - - k = 0 ! counter for selected obs - - do i=1,N_obs - - if (any(Observations(i)%species == select_species)) then - - k = k+1 - ind_obs(k) = i - - end if - - end do - - N_selected_obs = k - - else ! select given species and catchments - - k = 0 ! counter for selected obs - - do i=1,N_obs - - if ( any(Observations(i)%tilenum == select_tilenum) .and. & - any(Observations(i)%species == select_species) ) then - - k = k+1 - ind_obs(k) = i - - end if - - end do - - N_selected_obs = k - - end if - - end subroutine get_ind_obs - - - ! ********************************************************************** - - subroutine get_ind_obs_assim( N_obs, assim_flag, N_obs_assim, ind_obs_assim ) - - ! loop through Observations%assim and construct an index vector that maps to - ! those obs that are meant to be assimilated (%assim==true) - ! - ! reichle, 27 March 2014 - - implicit none - - integer, intent(in) :: N_obs - - logical, intent(in), dimension(N_obs) :: assim_flag ! typically "Observations%assim" - - integer, intent(out) :: N_obs_assim - integer, intent(out), dimension(N_obs) :: ind_obs_assim - - ! --------------------------- - - ! locals - - integer :: ii, jj - - ! -------------------------------------------------------------- - - ind_obs_assim = -9999 - - jj=0 - - do ii=1,N_obs - - if (assim_flag(ii)) then - - jj=jj+1 - - ind_obs_assim(jj) = ii - - end if - - end do - - N_obs_assim = jj - - end subroutine get_ind_obs_assim - - - ! ******************************************************************** - - function get_halo_around_tile(tile, xcompact, ycompact, skin) result(halo) - - ! determine halo around a tile for the purpose of the EnKF analysis - ! - pchakrab, 25 March 2014 - - ! input/output - - type(tile_coord_type), intent(in) :: tile - real, intent(in) :: xcompact, ycompact - real, intent(in), optional :: skin - type(halo_type) :: halo ! output - - ! local - real :: this_lon, this_lat, tmp_skin - - tmp_skin = 1.0 - if (present(skin)) tmp_skin = skin - - this_lon = tile%com_lon - this_lat = tile%com_lat - - ! simple approach to dateline issue - - ! cut halo back to at most -180:180, -90:90 - halo%minlon = max(this_lon-tmp_skin*xcompact,-180.) - halo%maxlon = min(this_lon+tmp_skin*xcompact, 180.) - halo%minlat = max(this_lat-tmp_skin*ycompact, -90.) - halo%maxlat = min(this_lat+tmp_skin*ycompact, 90.) - - end function get_halo_around_tile - - ! ********************************************************************** - - function TileNnzObs(Observations, halo, select_species) result (nnz) - - ! determine whether or not any Observations (possibly restricted - ! to a select list of species) fall within a given halo - ! - ! - pchakrab, 25 March 2014 - - ! "nnz" = non-zero - - implicit none - - ! input/output - type(obs_type), intent(in), dimension(:) :: Observations - type(halo_type), intent(in) :: halo - integer, intent(in), dimension(:) :: select_species - logical :: nnz ! output - - ! locals - integer :: N_obs, N_select_species - integer :: iObs, jSpecies - real :: lon_obs, lat_obs - - N_obs = size(Observations) - N_select_species = size(select_species) ! size=0 for un-allocated array - - nnz = .false. - - if (N_select_species==0) then ! use all species - do iObs=1,N_obs - ! center-of-mass coordinates for the given observation - lon_obs = Observations(iObs)%lon - lat_obs = Observations(iObs)%lat - if ( halo%minlon<=lon_obs .and. lon_obs<=halo%maxlon .and. & - halo%minlat<=lat_obs .and. lat_obs<=halo%maxlat ) then - nnz = .true. - exit ! out of iObs loop - end if - end do ! end loop over observations - else ! pick out selected species - ! - ! pchakrab: THIS SECTION NEEDS TO BE TESTED - ! - do iObs=1,N_obs - lon_obs = Observations(iObs)%lon - lat_obs = Observations(iObs)%lat - do jSpecies=1,N_select_species - if ( halo%minlon<=lon_obs .and. lon_obs<=halo%maxlon .and. & - halo%minlat<=lat_obs .and. lat_obs<=halo%maxlat .and. & - (Observations(iObs)%species == select_species(jSpecies)) ) then - nnz = .true. - exit ! exit to next observation (next iObs) - end if - end do ! end loop over select_species - if (nnz) exit ! out of iObs loop - end do - end if - - end function TileNnzObs - - - ! ********************************************************************** - - subroutine get_ind_obs_lat_lon_box( & - N_obs, Observations, & - min_lon, max_lon, min_lat, max_lat, & - N_select_species, select_species, & - N_selected_obs, ind_obs ) - - ! find the (index vector for) observations within a given lat/lon box - ! and for given observation types - ! - ! min_lon, max_lon, min_lat, max_lat describe the extent of the lat/lon box - ! - ! the vector select_species of length N_select_species contains the - ! species IDs to be selected. - ! if N_select_species is zero, all species are selected - ! - ! the indices (relative to "Observations") of matching observations - ! are returned in the first "N_selected_obs" components of the - ! vector "ind_obs" (which must be allocated to (maximum) length "N_obs" - ! by the calling routine) - ! - ! NOTE: 1.) definitions: - ! update region = geographic region for which the state - ! vector is updated - ! lat-lon-box = geographic region of observations that - ! influence the states of the udpate region - ! (encloses update region, bigger than - ! update region by xcompact/ycompact) - ! 2.) update regions must NOT cross the date line - ! 3.) observations that fall into the lat-lon-box but are - ! on the opposite side of the date line from the - ! update region are NOT used (of course they will be used - ! to update their "native" update region) - ! - ! uses nr_indexx.f - ! - ! reichle, 26 Jul 2002 - ! reichle, 1 Aug 2005 - use Observations%lat/lon instead of tile_coord - ! reichle, 21 Jun 2013 - added sort to avoid lay-out dependency for parallel runs - ! pchakrab, 25 Mar 2014 - sort is not needed following fix in read_obs.F90 - ! reichle, 16 Oct 2014 - simplified using "any()" - - implicit none - - integer, intent(in) :: N_obs, N_select_species - - type(obs_type), intent(in), dimension(N_obs) :: Observations - - real :: min_lon, max_lon, min_lat, max_lat - - integer, intent(in), dimension(N_select_species) :: select_species - - integer, intent(out) :: N_selected_obs - - integer, intent(out), dimension(N_obs) :: ind_obs - - ! --------------------------- - - ! locals - - integer :: i, k - - real :: lon_obs, lat_obs - - ! -------------------------------------------------------------- - - k = 0 ! counter for selected obs - - if (N_select_species==0) then ! use all species - - do i=1,N_obs - - ! determine center-of-mass coordinates for the given observation - - lon_obs = Observations(i)%lon - lat_obs = Observations(i)%lat - - if ( min_lon <= lon_obs .and. & - lon_obs <= max_lon .and. & - min_lat <= lat_obs .and. & - lat_obs <= max_lat ) then - - k = k+1 - ind_obs(k) = i - - end if - - end do ! end loop through observations - - N_selected_obs = k - - else ! pick out selected species - - do i=1,N_obs - - ! determine center-of-mass coordinates for the given observation - - lon_obs = Observations(i)%lon - lat_obs = Observations(i)%lat - - if ( any(Observations(i)%species == select_species) .and. & - min_lon <= lon_obs .and. & - lon_obs <= max_lon .and. & - min_lat <= lat_obs .and. & - lat_obs <= max_lat ) then - - k = k+1 - ind_obs(k) = i - - end if - - end do - - N_selected_obs = k - - end if - - end subroutine get_ind_obs_lat_lon_box - - ! ********************************************************************* - - subroutine check_compact_support( & - update_type, & - N_catf, tile_coord_f, & - N_progn_pert, progn_pert_param, & - N_force_pert, force_pert_param, & - N_obs_param, obs_param, & - xcompact, ycompact ) - - ! check whether any of the correlation scales exceeds or is comparable to - ! the compact support length scale - ! also check whether the compact support length scale may be - ! too large for the given correlation scales - - implicit none - - integer, intent(in) :: update_type - - integer, intent(in) :: N_catf, N_progn_pert, N_force_pert, N_obs_param - - type(tile_coord_type), dimension(N_catf), intent(in) :: tile_coord_f - - type(pert_param_type), dimension(N_progn_pert), intent(in) :: progn_pert_param - type(pert_param_type), dimension(N_force_pert), intent(in) :: force_pert_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - real, intent(inout) :: xcompact, ycompact - - ! --------------------------------- - - ! locals - - integer :: ii - - character(40) :: error_type - - real :: max_dist_x, max_dist_y, r_y - - real, dimension(1) :: r_x, tmp_lat - - character(len=*), parameter :: Iam = 'check_compact_support' - - ! ------------------------------------------------------------- - - select case (update_type) - - case (1,3,4,5,6,9,11) ! "1d" updates - - ! Make xcompact and ycompact just large enough so that - ! the EnKF analysis correctly identifies the tiles - ! that should be included in the 1d analysis. - ! - ! In the obs readers, each obs is assigned to a single tile - ! based on subroutine get_tile_num_from_latlon(). The assignment - ! is such that the the obs lat/lon and the tile center-of-mass lat/lon - ! must always be within the same grid cell of the tile_grid [or pert_grid??]. - ! Furthermore, the obs lat/lon - ! - must be within the min/max lat/lon boundaries of the tile - ! OR - ! - must be within max_dist (defined by obs_param%FOV) - - ! Based on the above, compute the maximum distance between the lat/lon - ! associated with an obs and the center-of-mass lat/lon for the tile - ! to which the obs is assigned - - max_dist_x = maxval( tile_coord_f%max_lon - tile_coord_f%min_lon ) - max_dist_y = maxval( tile_coord_f%max_lat - tile_coord_f%min_lat ) - - do ii=1,N_obs_param - - if (obs_param(ii)%assim) then - - if ( trim(obs_param(ii)%FOV_units)=='deg' ) then - - r_x(1) = obs_param(ii)%FOV - r_y = obs_param(ii)%FOV - - elseif ( trim(obs_param(ii)%FOV_units)=='km' ) then - - ! convert from [km] (FOV) to [deg] (max_dist_*) - - ! largest FOV in [deg] will be at largest abs(lat) - - tmp_lat(1) = maxval(abs(tile_coord_f%com_lat)) - - call dist_km2deg( obs_param(ii)%FOV, 1, tmp_lat, r_x, r_y ) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown FOV_units') - - end if - - max_dist_x = max( max_dist_x, r_x(1) ) - max_dist_y = max( max_dist_y, r_y ) - - end if - - end do - - ! reset xcompact and ycompact accordingly - - xcompact = max( xcompact, max_dist_x ) - ycompact = max( ycompact, max_dist_y ) - - if (logit) write (logunit,*) - if (logit) write (logunit,'(A,ES10.3)') & - Iam // '(): reset for 1d update_type: xcompact = ', xcompact - if (logit) write (logunit,'(A,ES10.3)') & - Iam // '(): reset for 1d update_type: ycompact = ', ycompact - if (logit) write (logunit,*) - - case (2,7,8,10,13) ! "3d" updates, check consistency of xcompact, ycompact - - ! check xcompact/ycompact against corr scales of model error - - do ii=1,N_progn_pert - - error_type = progn_pert_param(ii)%descr - - call check_compact( xcompact, ycompact, & - progn_pert_param(ii)%xcorr, progn_pert_param(ii)%ycorr, & - error_type ) - - end do - - ! check xcompact/ycompact against corr scales of forcing perturbations - - do ii=1,N_force_pert - - error_type = force_pert_param(ii)%descr - - call check_compact( xcompact, ycompact, & - force_pert_param(ii)%xcorr, force_pert_param(ii)%ycorr, & - error_type ) - - end do - - ! check xcompact/ycompact against corr scales of observation errors - ! (only if obs are assimilated) - - do ii=1,N_obs_param - - if (obs_param(ii)%assim) then - - error_type = obs_param(ii)%descr - - call check_compact( xcompact, ycompact, & - obs_param(ii)%xcorr, obs_param(ii)%ycorr, & - error_type ) - - end if - - end do - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown update_type') - - end select - - end subroutine check_compact_support - - ! ****************************************************************** - - subroutine check_compact( xcompact, ycompact, xcorr, ycorr, error_type ) - - ! Helper routine for check_compact_support() - ! - ! If xcompact/ycompact are less than the largest correlation length times - ! a multiple, the execution of the program is halted. - ! - ! If xcompact/ycompact exceed the smallest correlation length times - ! a multiple, a warning statement is printed. - - implicit none - - real, intent(in) :: xcompact, ycompact - real, intent(in) :: xcorr, ycorr - - character(*), intent(in) :: error_type - - real, parameter :: min_compact_div_corr = 2. - real, parameter :: max_compact_div_corr = 5. - - character(len=*), parameter :: Iam = 'check_compact' - character(len=400) :: err_msg - - ! ------------------------------------------------------- - - ! check whether compact support length scale might be too large - - if ( (xcompact > xcorr*max_compact_div_corr) .or. & - (ycompact > ycorr*max_compact_div_corr) ) then - - if (logit) then - write (logunit,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write (logunit,*) - write (logunit,*) 'WARNING: xcompact/ycompact may be too large for' - write (logunit,*) ' error corr scale of ', trim(error_type) - write (logunit,*) - write (logunit,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write (logunit,*) - end if - - end if - - ! check whether compact support length scale is too small - - if ( (xcompact < xcorr*min_compact_div_corr) .or. & - (ycompact < ycorr*min_compact_div_corr) ) then - err_msg = 'xcompact/ycompact too small for ' // & - 'error corr scale of ' // trim(error_type) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end subroutine check_compact - - ! ****************************************************************** - - subroutine dist_km2deg( dist_km, N_lat, lat, dist_x_deg, dist_y_deg ) - - ! Convert (horizontal) distance from units of [km] to units of [deg] - ! - ! Output meridional distance in units of [deg] depends on latitude - - implicit none - - real, intent(in) :: dist_km ! [km] - - integer, intent(in) :: N_lat - - real, dimension(N_lat), intent(in) :: lat ! [deg] (-90:90) - - real, dimension(N_lat), intent(out) :: dist_x_deg ! [deg] vector (depends on latitude) - real, intent(out) :: dist_y_deg ! [deg] scalar - - ! local variables - - character(len=*), parameter :: Iam = 'dist_km2deg' - - ! ------------------------------------------------------- - - ! NOTE: MAPL_radius (Earth radius) is in [m] and dist_km is in [km] - - dist_y_deg = dist_km * (180./MAPL_PI) / (MAPL_RADIUS/1000.) - - ! NOTE: cos() needs argument in [rad], lat is in [deg] (-90:90) - - dist_x_deg = dist_y_deg / cos( MAPL_PI/180. * lat ) - - if (any(dist_x_deg<0.) .or. dist_y_deg<0.) & - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'encountered negative distance' ) - - end subroutine dist_km2deg - - ! ****************************************************************** - -! abandoned during changes for obs halo -! to reinstate, need to MPI_Gather "cat_param_f" -! -! reichle, 30 Sep 2011 - -! subroutine check_obs_pert( N_ens, N_catd, N_obs, & -! cat_param, Observations, Obs_pert ) -! -! ! check synthetic observation error for physical constraints, re-set obs -! ! error if constraints are violated -! ! -! ! reichle, 26 Feb 2002 -! ! reichle, 2 Aug 2005 -! ! reichle, 10 Jan 2011 - added checks for AMSR-E/LPRM soil moisture retrievals -! ! -! ! ------------------------------------------------------------------- -! -! implicit none -! -! integer, intent(in) :: N_ens, N_obs, N_catd -! -! type(cat_param_type), dimension(N_catd), intent(in) :: cat_param -! -! type(obs_type), dimension(N_obs), intent(in) :: Observations -! -! real, dimension(N_obs,N_ens), intent(inout) :: Obs_pert -! -! ! ---------------------------------------------------------------- -! -! ! local variables -! -! integer :: i, n -! -! real :: min_pert, max_pert -! -! ! --------------------------------------------------------------- -! -! do i=1,N_obs -! -! select case (Observations(i)%species) -! -! case (1,2,4,7,8,9,10,11,12) -! -! ! ae_l2_sm_a, ae_l2_sm_d, RedArkOSSE_sm, RedArkOSSE_CLSMsynthSM, -! ! VivianaOK_CLSMsynthSM, ae_sm_LPRM_a_C, ae_sm_LPRM_d_C, -! ! ae_sm_LPRM_a_X, ae_sm_LPRM_d_X -! -! min_pert = -Observations(i)%obs -! max_pert = cat_param(Observations(i)%tilenum)%poros - & -! Observations(i)%obs -! -! do n=1,N_ens -! -! Obs_pert(i,n) = max( Obs_pert(i,n), min_pert ) -! Obs_pert(i,n) = min( Obs_pert(i,n), max_pert ) -! -! end do -! -! case (3) ! isccp_tskin_gswp2_v1 -! -! ! no constraints -! -! case default -! -! call stop_it('check_obs_pert(): unkown obs species.') -! -! !write (logunit,*) 'check_obs_pert(): unkown obs species. STOPPING.' -! !stop -! -! end select -! -! end do -! -! end subroutine check_obs_pert - - ! ********************************************************************** - ! ********************************************************************** - ! ********************************************************************** - -end module clsm_ensupd_upd_routines - - -! **** EOF ****************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/enkf_general.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/enkf_general.F90 deleted file mode 100644 index c678a378..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/enkf_general.F90 +++ /dev/null @@ -1,487 +0,0 @@ - -! this file contains a collection of general Ensemble Kalman filter -! subroutines and compact support subroutines -! -! reichle, 20 Apr 2001 -! reichle, 18 Mar 2004 - optional arguments -! reichle, 27 Jan 2005 - eliminated use of module select_kinds -! reichle, 19 Jul 2005 - merged compact_support.f90 and enkf_general.f90 -! reichle, 1 Aug 2005 - eliminated tile_coord -! reichle, 18 Oct 2005 - return increments instead of updated State -! reichle+qliu, 29 Apr 2020 - added forecast error covariance inflation - -! use intel mkl lapack when available -#ifdef MKL_AVAILABLE -#include "lapack.f90" -#endif - -module enkf_general - -#ifdef MKL_AVAILABLE - use lapack95, only: getrf, getrs -#endif - - use enkf_types, ONLY: & - obs_type - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - private - - public :: enkf_increments - -contains - - ! *** new version for 3D EnKF *** - - subroutine enkf_increments( & - N_state, N_obs, N_ens, & - Observations, Obs_pred, Obs_err, Obs_cov, & - State_incr, & - State_lon, State_lat, xcompact, ycompact, fcsterr_inflation_fac ) - - ! perform EnKF update - ! - ! IMPORTANT: - ! on input, State_incr must contain State_minus(1:N_state,1:N_ens) - ! on output, State_incr contains the increments - ! - ! if optional inputs State_lon, State_lat, xcompact, and ycompact - ! are present, Hadamard product is applied to HPHt and PHt - ! - ! if optional input fcsterr_inflation_fac is present, this subroutine inflates - ! the forecast error covariance and returns increments that must be applied to - ! the state vector *before* inflation - ! (i.e., do not inflate the state vector outside of this subroutine) - - implicit none - - integer, intent(in) :: N_state, N_obs, N_ens - - type(obs_type), intent(in), dimension(N_obs) :: Observations - - real, intent(in), dimension(N_obs,N_ens) :: Obs_pred - real, intent(in), dimension(N_obs,N_ens) :: Obs_err - real, intent(in), dimension(N_obs,N_obs) :: Obs_cov - - real, intent(inout), dimension(N_state,N_ens) :: State_incr - - ! optional inputs - - real, dimension(N_state), intent(in), optional :: State_lon, State_lat - - real, intent(in), optional :: xcompact ! [deg] longitude - real, intent(in), optional :: ycompact ! [deg] latitude - real, intent(in), optional :: fcsterr_inflation_fac ! forecast error covariance inflation - - ! ----------------------------- - - ! locals - - character(len=*), parameter :: Iam = 'enkf_increments' - - integer :: n_e, i, ii, jj, kk, lapack_info - - real :: PHt_ij, dx, dy - - real :: inflation_factor - - real, dimension(N_state,N_ens) :: State_prime - real, dimension(N_state) :: State_bar - real, dimension(N_state) :: State_incr_tmp - - real, dimension(N_obs,N_ens) :: Obs_pred_prime - real, dimension(N_obs) :: Obs_pred_bar - real, dimension(N_obs) :: rhs - - real, dimension(N_ens) :: weights - - real, dimension(N_obs,N_obs) :: Repr_matrix - - integer, dimension(N_obs) :: indx - - logical :: apply_hadamard - - ! ------------------------------------------------------------------ - - ! deal with optional argument - - if (present(fcsterr_inflation_fac)) then - - inflation_factor = fcsterr_inflation_fac - - else - - inflation_factor = -9999. - - end if - - ! find out whether Hadamard product should be applied - - apply_hadamard = ( & - present(State_lon) .and. & - present(State_lat) .and. & - present(xcompact) .and. & - present(ycompact) ) - - ! ---------------------- - - ! IMPORTANT: on input, State_incr contains State_minus(1:N_state,1:N_ens) - - ! compute ensemble mean Ybar at current update time - - State_bar = sum( State_incr, 2) / real(N_ens) - - ! finalize matrix Y_prime = Y - Ybar - - do n_e=1,N_ens - - State_prime(:,n_e) = State_incr(:,n_e) - State_bar - - end do - - if (inflation_factor > 0.) State_prime = inflation_factor * State_prime - - ! -------------------- - - ! compute ensemble mean H*Ybar - - Obs_pred_bar = sum( Obs_pred, 2) / real(N_ens) - - ! finalize matrix Q_prime = H*Y - H*ybar - - do n_e=1,N_ens - - Obs_pred_prime(:,n_e) = Obs_pred(:,n_e) - Obs_pred_bar - - end do - - if (inflation_factor > 0.) Obs_pred_prime = inflation_factor * Obs_pred_prime - - ! -------------------- - - ! form repr matrix HPHt = Q_prime*(Q_prime)t/(N_e-1) - - Repr_matrix = & - (matmul(Obs_pred_prime,transpose(Obs_pred_prime))) & - /real(N_ens-1) - - ! reichle, 18 Mar 2004: - ! maybe Hadamard product should be applied *after* adding Obs_cov - ! to representer matrix? only matters if Obs_cov is not diagonal... - - if (apply_hadamard) & - call hadamard_for_repr_matrix( N_obs, Observations, & - xcompact, ycompact, Repr_Matrix ) - - ! form matrix W = HPHt+ R - - Repr_matrix = Repr_matrix + Obs_cov - - ! maybe later: save representer matrix into file - - ! decompose W once (look into LAPACKs sgelss/dgelss, ask Christian) - -#ifdef MKL_AVAILABLE - call getrf(Repr_Matrix, indx, info=lapack_info) - - if (lapack_info .ne. 0) & - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'singular matrix after getrf') - -#else - call ludcmp( Repr_Matrix, N_obs, indx ) -#endif - - ! -------------------------------------- - - ! update each ensemble member - - do n_e=1,N_ens - - ! use random measurement error field, get Zpert = Z + v, - ! compute right hand side rhs = Zpert - H*y^f for system equation, - - do i=1,N_obs - - rhs(i) = Observations(i)%obs + Obs_err(i,n_e) - Obs_pred(i,n_e) - - ! in case of inflation, correct for the fact that "Obs_pred" was not inflated above - ! because it is intent(in) - - if (inflation_factor > 0.) rhs(i) = rhs(i) - (1.-inflation_factor)*Obs_pred_prime(i,n_e) - - end do - - ! solve W*b = Zpert - H*y^f - ! after back subst, rhs contains (HPHt+R)^(-1)*delta_y(n_e) -#ifdef MKL_AVAILABLE - call getrs(Repr_matrix, indx, rhs, trans='N', info=lapack_info) - - if (lapack_info .ne. 0) pause 'something went wrong after getrs' -#else - call lubksb( Repr_matrix, N_obs, indx, rhs ) -#endif - - if (.not. apply_hadamard) then - - ! update *without* Hadamard product - - ! compute w = (Q_prime)t b - - weights = matmul( transpose(Obs_pred_prime), rhs) - - ! compute new initial cond y^a = y^f + (Y-ybar)*w/(N_e-1) - - ! start with (Y-ybar)*w, write into Y_Vector - - State_incr_tmp = matmul( State_prime, weights) - - State_incr(:,n_e) = State_incr_tmp - - else - - ! update *with* Hadamard product - - State_incr(:,n_e) = 0. ! State_incr = analysis - forecast - - do ii=1,N_state - - do jj=1,N_obs - - ! compute [PHt]_ij (normalize later) - - PHt_ij = 0. - - do kk=1,N_ens - - PHt_ij = PHt_ij + State_prime(ii,kk)*Obs_pred_prime(jj,kk) - - end do - - ! apply Hadamard factor - - dx=State_lon(ii)-Observations(jj)%lon - dy=State_lat(ii)-Observations(jj)%lat - - ! multiply [PHt]_ij with Hadamard factor - - PHt_ij = & - PHt_ij * get_gaspari_cohn( dx, dy, xcompact, ycompact ) - - State_incr(ii,n_e) = State_incr(ii,n_e) + PHt_ij*rhs(jj) - - end do - - end do - - end if - - - ! finish computation of increment for ensemble member n_e - ! (normalization is NOT ensemble average, see Eq above) - - State_incr(:,n_e) = State_incr(:,n_e)/real(N_ens-1) - - ! correct for the fact that the increment will be applied to - ! the un-inflated state vector outside of this subroutine - ! (note also that State_prime here has been inflated!) - - if (inflation_factor > 0.) & - State_incr(:,n_e) = State_incr(:,n_e) + (1.-1./inflation_factor)*State_prime(:,n_e) - - end do - - end subroutine enkf_increments - - - ! ********************************************************************* - - subroutine hadamard_for_repr_matrix( N_obs, Observations, & - xcompact, ycompact, & - Repr_Matrix ) - - implicit none - - integer, intent(in) :: N_obs - - type(obs_type), intent(in), dimension(N_obs) :: Observations - - real, intent(in) :: xcompact ! [deg] longitude - real, intent(in) :: ycompact ! [deg] latitude - - real, dimension(N_obs,N_obs), intent(inout) :: Repr_matrix - - ! locals - - integer :: i, j - - real :: tmpreal, dx, dy - - ! ---------------------------------- - - do i=1,N_obs - do j=i+1,N_obs - - dx = Observations(i)%lon - Observations(j)%lon - dy = Observations(i)%lat - Observations(j)%lat - - tmpreal = get_gaspari_cohn( dx, dy, xcompact, ycompact ) - - Repr_matrix(i,j) = tmpreal * Repr_matrix(i,j) - Repr_matrix(j,i) = tmpreal * Repr_matrix(j,i) - - end do - end do - - end subroutine hadamard_for_repr_matrix - - ! ********************************************************************* - - !DEC$ ATTRIBUTES FORCEINLINE :: get_gaspari_cohn - ! - function get_gaspari_cohn(dx, dy, xcompact, ycompact) result(rslt) - - ! evaluate 5th-order polynomial from Gaspari & Cohn, 1999, Eq (4.10) - ! - ! get_gaspari_cohn() uses a generalized *an*isotropic Gaspari & Cohn - ! approach (essentially coordinate stretching, see handwritten - ! notes for details) - ! - ! d = separation distance relative to the distance at which all - ! correlations vanish. In the isotropic case, Gaspari & Cohn, 1999, - ! Eq. (4.10) - ! - ! d = sqrt(dx**2 + dy**2) / (2*c) = |z| / (2*c) - ! - ! or in the anisotropic case - ! - ! d = sqrt( (dx/xcompact)**2 + (dy/ycompact)**2 ) - ! - ! *** Use |z|/c = 2*d. All correlations vanish for d > 1. *** - ! - ! for a given lat/lon distance (dx and dy, resp.), compute the - ! anisotropic compact support (Gaspari & Cohn) weights - ! - ! input distances must be in degrees latitude/longitude - ! - ! dx = longitude separation of two points [deg] - ! dy = latitude separation of two points [deg] - ! - ! xcompact = longitude scale of compact support [deg] - ! ycompact = latitude scale of compact support [deg] - ! - ! All correlations vanish outside of an ellipse with semi-axes - ! xcompact and ycompact, ie Gaspari & Cohn weights vanish - ! for d > 1 (note the factor 2!) - ! - ! When the anisotropic case is reduced back to the isotropic case, - ! (ie if xcompact==ycompact) then c = xcompact/2 = ycompact/2. - ! - ! pchakrab, rreichle: revised, 17 Sep 2013 - ! - ! ------------------------------------------------------------------ - - implicit none - - real, intent(in) :: dx, dy, xcompact, ycompact - - real :: rslt ! returned value - - ! local variables - - real :: d, dsq - - real, parameter :: tol = 1e-3 - - ! --------------------------------------------------------- - - if ( (abs(dx)>xcompact) .or. (abs(dy)>ycompact) ) then - - rslt = 0. ! nothing to do - - else - - ! compute (anisotropic) distance relative to compact support - ! - ! d = sqrt( (dx/xcompact)**2 + (dy/ycompact)**2 ) - ! - ! NOTE: multiply d by 2 to return to Gaspari & Cohn, 1999, notation - - dsq = 4.0*((dx*dx)/(xcompact*xcompact) + (dy*dy)/(ycompact*ycompact)) - - d = sqrt(dsq) - - if (d >= 2.) then - - rslt = 0. - - else if (d <= tol) then - - rslt = 1. - - else if (d <= 1.) then - - ! y = -.25*d**5 + .5*d**4 + .625*d**3 - 5./3.*d**2 + 1. - - ! rslt = d*d *( d*( d*( -.25*d + .5) + .625) -5./3.) + 1. - - rslt = dsq*(dsq*(-0.25*d + 0.5) + 0.625*d - 5.0/3.0) + 1.0 - - else - - ! y = d**5/12. - .5*d**4 + .625*d**3 + 5./3.*d**2 - 5.*d + 4. - 2./3./d - - rslt = d*( d*( d*( d*( d/12. - .5) + .625) + 5./3.) -5.) + 4. - 2./3./d - - end if - - end if - - end function get_gaspari_cohn - - ! ************************************************************ - -end module enkf_general - -! ******************************************************************* - -#if 0 - -program test_gaspari_cohn - - ! reichle, 17 Sep 2013: updated (only works if module stuff is removed) - - implicit none - - real :: x, y, get_gaspari_cohn - - real :: xcompact = 5. - real :: ycompact = 4. - - integer :: i,j,N - - N = 40 - - do i=-N,N - - x = 7.*float(i)/float(N) - - do j=-N,N - - y = 7.*float(j)/float(N) - - write (999,*) x, y, get_gaspari_cohn(x,y,xcompact,ycompact) - - end do - end do - -end program test_gaspari_cohn - -#endif - - -! ********** EOF ********************************************************* diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/io_hdf5.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/io_hdf5.F90 deleted file mode 100644 index fb339d0b..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/io_hdf5.F90 +++ /dev/null @@ -1,463 +0,0 @@ -! io_hdf5.F90 - -! pchakrab, 16 Jan 2014 - -!--------------------------- -! STEPS to read 1D real data -! (For more details, please see the example at the end of this file) -! -! use io_hdf5 -! type(hdf5read) :: h5r -! real, allocatable, dimension(:) :: data1D -! -! call h5r%openFile(file) -! for each dset in file -! call h5r%queryDataset(dsetName, dsetRank, dsetSize) -! allocate(data1D(dsetSize(1))) -! call h5r%readDataset(data1D) [READ THE DATASET JUST QUERIED] -! end for -! call h5r%closeFile -! deallocate(data1D) -!--------------------------- - -module io_hdf5 - - use hdf5 - use iso_fortran_env - - implicit none - - private - - integer, parameter :: UNINIT_INT = -99999 - character(len=*), parameter :: UNINIT_STR = "" - - type, public :: hdf5read - private - character(len=256) :: file_name = UNINIT_STR - integer(hid_t) :: file_id = UNINIT_INT - character(len=256) :: dset_name = UNINIT_STR - integer(hid_t) :: dset_id = UNINIT_INT, dspace_id = UNINIT_INT, dtype_id = UNINIT_INT - integer :: dset_rank = UNINIT_INT - ! 7 is the max dimension of a fortran array - integer(hsize_t) :: dset_size(7) = UNINIT_INT, dset_max_size(7) = UNINIT_INT - contains - ! public - procedure, public :: openFile - procedure, public :: closeFile - procedure, public :: queryDataset - generic, public :: readDataset => readDataset1DReal, readDataset1DReal8, readDataset1DInt, readDataset1DChar24, readDataset2DReal - ! private - procedure, private :: readDataset1DReal - procedure, private :: readDataset1DReal8 - procedure, private :: readDataset1DInt - procedure, private :: readDataset1DChar24 - procedure, private :: readDataset2DReal - procedure, private :: uninitDataset - end type hdf5read - -contains - - ! open file - subroutine openFile(this, filename) - - ! input/output variables - ! NEED class(hdf5read) instead of type(hdf5read) - class (hdf5read), intent(inout) :: this - character(len=*), intent(in) :: filename - - ! local variable - integer :: hdf5err - - ! set obj param val - this%file_name = filename - - ! initialize fortran interface - call h5open_f(hdf5err) - call checkErrCode_('h5open_f', hdf5err) - - ! open existing file - call h5fopen_f(this%file_name, H5F_ACC_RDONLY_F, this%file_id, hdf5err) - call checkErrCode_('h5fopen_f', hdf5err) - - end subroutine openFile - - ! close already opened file - subroutine closeFile(this) - - ! input/output variables - class (hdf5read), intent(inout) :: this - - ! local variable - integer :: hdf5err - - ! ensure that dataset has been closed - if (this%dset_name/=UNINIT_STR) stop "ERROR: Open dataset needs to be closed first. Stopping!" - - ! close file - call h5fclose_f(this%file_id, hdf5err) - call checkErrCode_('h5fclose_f', hdf5err) - this%file_name = UNINIT_STR - this%file_id = UNINIT_INT - - ! close fortran interface - call h5close_f(hdf5err) - call checkErrCode_('h5close_f', hdf5err) - - end subroutine closeFile - - ! query dataset for number of dims and its shape - subroutine queryDataset(this, dsetName, dsetRank, dsetSize) - - ! input/output variables - class (hdf5read), intent(inout) :: this - character(len=*), intent(in) :: dsetName - integer, intent(out) :: dsetRank - integer, intent(out) :: dsetSize(7) - - ! local variable - integer :: hdf5err - - ! ensure that file_name is set i.e. openFile - ! must have been called prior to this routine - if (this%file_name==UNINIT_STR) stop "ERROR: No open file available. Stopping!" - - ! set obj param val - this%dset_name = dsetname - - ! open datset from already opened file - call h5dopen_f(this%file_id, this%dset_name, this%dset_id, hdf5err) - call checkErrCode_('h5dopen_f', hdf5err) - - ! get dataspace id - call h5dget_space_f(this%dset_id, this%dspace_id, hdf5err) - call checkErrCode_('h5dget_space_f', hdf5err) - - ! get num of dimensions - call h5sget_simple_extent_ndims_f(this%dspace_id, this%dset_rank, hdf5err) - call checkErrCode_('h5sget_simple_extent_ndims_f', hdf5err) - dsetRank = this%dset_rank - - ! get size of array - call h5sget_simple_extent_dims_f(this%dspace_id, this%dset_size, this%dset_max_size, hdf5err) - call checkErrCode_('h5sget_simple_extent_dims_f', hdf5err) - dsetSize = this%dset_size - - end subroutine queryDataset - - - ! uninitalize dataset - subroutine uninitDataset(this) - - ! input/output variables - class (hdf5read), intent(inout) :: this - - ! un-initialize everything related to - ! the dataset queried/read - this%dset_name = UNINIT_STR - this%dset_id = UNINIT_INT - this%dspace_id = UNINIT_INT - this%dset_rank = UNINIT_INT - this%dset_size = UNINIT_INT - this%dset_max_size = UNINIT_INT - this%dtype_id = UNINIT_INT - - end subroutine uninitDataset - - - ! read the dataset that was queried earlier - subroutine readDataset1DChar24(this, dataChar) - - ! input/output variables - class (hdf5read), intent(inout) :: this - character(len=24), intent(out) :: dataChar(:) - - ! local variable - integer :: hdf5err - - ! ensure that dset_name is set i.e. openDataset - ! must have been called prior to this routine - if (this%dset_name==UNINIT_STR) stop "ERROR: No open dataset available. Stopping!" - - if (this%dset_size(1)==0) then - print *, 'Datset ', trim(this%dset_name), ' in file ', trim(this%file_name), ' is empty' - else - ! get data type - call h5dget_type_f(this%dset_id, this%dtype_id, hdf5err) - - ! read data - call h5dread_f(this%dset_id, this%dtype_id, dataChar, this%dset_size, hdf5err) - call checkErrCode_('h5dread_f', hdf5err) - end if - - ! close dataset - call h5dclose_f(this%dset_id, hdf5err) - call checkErrCode_('h5dclose_f', hdf5err) - - ! un-initialize dataset just queried/read - call this%uninitDataset - - end subroutine readDataset1DChar24 - - - ! read the dataset that was queried earlier - subroutine readDataset1DReal(this, data1D) - - ! input/output variables - class (hdf5read), intent(inout) :: this - real, intent(out) :: data1D(:) - - ! local variable - integer :: hdf5err - - ! ensure that dset_name is set i.e. openDataset - ! must have been called prior to this routine - if (this%dset_name==UNINIT_STR) stop "ERROR: No open dataset available. Stopping!" - - if (this%dset_size(1)==0) then - print *, 'Datset ', trim(this%dset_name), ' in file ', trim(this%file_name), ' is empty' - else - ! get data type - call h5dget_type_f(this%dset_id, this%dtype_id, hdf5err) - - ! read data - call h5dread_f(this%dset_id, this%dtype_id, data1D, this%dset_size, hdf5err) - call checkErrCode_('h5dread_f', hdf5err) - end if - - ! close dataset - call h5dclose_f(this%dset_id, hdf5err) - call checkErrCode_('h5dclose_f', hdf5err) - - ! un-initialize dataset just queried/read - call this%uninitDataset - - end subroutine readDataset1DReal - - - ! read the dataset that was queried earlier - subroutine readDataset1DReal8(this, data1D) - - ! input/output variables - class (hdf5read), intent(inout) :: this - real(REAL64), intent(out) :: data1D(:) - - ! local variable - integer :: hdf5err - - ! ensure that dset_name is set i.e. openDataset - ! must have been called prior to this routine - if (this%dset_name==UNINIT_STR) stop "ERROR: No open dataset available. Stopping!" - - if (this%dset_size(1)==0) then - print *, 'Datset ', trim(this%dset_name), ' in file ', trim(this%file_name), ' is empty' - else - ! get data type - call h5dget_type_f(this%dset_id, this%dtype_id, hdf5err) - - ! read data - call h5dread_f(this%dset_id, this%dtype_id, data1D, this%dset_size, hdf5err) - call checkErrCode_('h5dread_f', hdf5err) - end if - - ! close dataset - call h5dclose_f(this%dset_id, hdf5err) - call checkErrCode_('h5dclose_f', hdf5err) - - ! un-initialize dataset just queried/read - call this%uninitDataset - - end subroutine readDataset1DReal8 - - - subroutine readDataset1DInt(this, data1D) - - ! input/output variables - class (hdf5read), intent(inout) :: this - integer, intent(out) :: data1D(:) - - ! local variable - integer :: hdf5err - - ! ensure that dset_name is set i.e. openDataset - ! must have been called prior to this routine - if (this%dset_name==UNINIT_STR) stop "ERROR: No open dataset available. Stopping!" - - if (this%dset_size(1)==0) then - print *, 'Datset ', trim(this%dset_name), ' in file ', trim(this%file_name), ' is empty' - else - ! get data type - call h5dget_type_f(this%dset_id, this%dtype_id, hdf5err) - - ! read data - !call h5dread_f(this%dset_id, this%dtype_id, data1D, this%dset_size, hdf5err) - call h5dread_f(this%dset_id, H5T_NATIVE_INTEGER, data1D, this%dset_size, hdf5err) - call checkErrCode_('h5dread_f', hdf5err) - end if - - ! close dataset - call h5dclose_f(this%dset_id, hdf5err) - call checkErrCode_('h5dclose_f', hdf5err) - - ! un-initialize dataset just queried/read - call this%uninitDataset - - end subroutine readDataset1DInt - - - subroutine readDataset2DReal(this, data2D) - - ! input/output variables - class (hdf5read), intent(inout) :: this - real, intent(out) :: data2D(:,:) - - ! local variable - integer :: hdf5err - - ! ensure that dset_name is set i.e. openDataset - ! must have been called prior to this routine - if (this%dset_name==UNINIT_STR) stop "ERROR: No open dataset available. Stopping!" - - if (this%dset_size(1)==0) then - print *, 'Datset ', trim(this%dset_name), ' in file ', trim(this%file_name), ' is empty' - else - ! get data type - call h5dget_type_f(this%dset_id, this%dtype_id, hdf5err) - - ! read data - call h5dread_f(this%dset_id, this%dtype_id, data2D, this%dset_size, hdf5err) - call checkErrCode_('h5dread_f', hdf5err) - end if - - ! close dataset - call h5dclose_f(this%dset_id, hdf5err) - call checkErrCode_('h5dclose_f', hdf5err) - - ! un-initialize dataset just queried/read - call this%uninitDataset - - end subroutine readDataset2DReal - - ! check return code - ! (not part of class hdf5read) - subroutine checkErrCode_(routineName, hdf5errCode) - - ! input/output variables - character(len=*), intent(in) :: routineName - integer, intent(in) :: hdf5errCode - - if (hdf5errCode<0) then - write(*,*) 'ERROR: ', routineName, ' returned NEGATIVE err code. Stopping!' - stop - end if - - end subroutine checkErrCode_ - -end module io_hdf5 - - -! ***************************************************************** - -#ifdef TEST_IOHDF5 - -program test_read - - use io_hdf5 - - implicit none - - character(len=*), parameter :: file_name = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB/Y2001/M07/D20/SMAP_L1C_TB_02915_D_20010720T002132_D04003_000.h5' - character(len=300) :: dsetName - - type(hdf5read) :: h5r - integer :: dsetRank, dsetSize(7), i - - type myDataType - real, pointer, dimension(:) :: tb_h_aft => null() ! aft - real, pointer, dimension(:) :: lon => null() - integer, pointer, dimension(:) :: row => null() - integer, pointer, dimension(:) :: flag => null() - real(REAL64), pointer, dimension(:) :: tb_time => null() - character(len=24), pointer, dimension(:) :: tb_time_utc_aft => null() - end type MyDataType - type(MyDataType), dimension(1) :: data - - print *, 'HDF5 file: ', trim(file_name) - print *, '' - - ! open file - call h5r%openFile(file_name) - - - ! query dataset + allocate space + read data - dsetName = '/Global_Projection/cell_tb_h_aft' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%tb_h_aft(dsetSize(1))) - call h5r%readDataset(data(1)%tb_h_aft) - print *, trim(dsetname),'(1:10)' - print *, data(1)%tb_h_aft(1:10) - print *, '' - - ! query dataset + allocate space + read data - dsetName = '/Global_Projection/cell_lon' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%lon(dsetSize(1))) - call h5r%readDataset(data(1)%lon) - print *, trim(dsetname),'(1:10)' - print *, data(1)%lon(1:10) - print *, '' - - ! query dataset + allocate space + read data - dsetName = '/Global_Projection/cell_row' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%row(dsetSize(1))) - call h5r%readDataset(data(1)%row) - print *, trim(dsetname),'(201:210)' - print *, data(1)%row(201:210) - print *, '' - - ! query dataset + allocate space + read data - dsetName = '/Global_Projection/cell_tb_time_seconds_aft' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%tb_time(dsetSize(1))) - call h5r%readDataset(data(1)%tb_time) - print *, trim(dsetname),'(1:10)' - print *, data(1)%tb_time(1:10) - print *, '' - - dsetName = '/Global_Projection/cell_tb_time_utc_aft' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%tb_time_utc_aft(dsetSize(1))) - call h5r%readDataset(data(1)%tb_time_utc_aft) - print *, trim(dsetname),'(241:250)' - do i=241,250 - print *, data(1)%tb_time_utc_aft(i) - end do - - dsetName = '/Global_Projection/cell_tb_qual_flag_h_aft' - call h5r%queryDataset(dsetName, dsetRank, dsetSize) - allocate(data(1)%flag(dsetSize(1))) - call h5r%readDataset(data(1)%flag) - print *, trim(dsetname),'(241:250)' - do i=241,250 - print *, data(1)%flag(i) - end do - - - ! close file - call h5r%closeFile - - - ! deallocate memory - if (associated(data(1)%tb_h_aft)) deallocate(data(1)%tb_h_aft) - if (associated(data(1)%lon)) deallocate(data(1)%lon) - if (associated(data(1)%row)) deallocate(data(1)%row) - if (associated(data(1)%flag)) deallocate(data(1)%flag) - if (associated(data(1)%tb_time)) deallocate(data(1)%tb_time) - if (associated(data(1)%tb_time_utc_aft)) deallocate(data(1)%tb_time_utc_aft) - -end program test_read - -#endif - -! =================== EOF ========================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 deleted file mode 100644 index 45decf32..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_routines.F90 +++ /dev/null @@ -1,1067 +0,0 @@ - -module mwRTM_routines - - ! subroutines for microwave radiative transfer model - ! - ! Select a specific configuration of the RTM via the field - ! "RTM_ID" in the "obs_param" type. - ! - ! %RTM_ID = ID of radiative transfer model to use for Tb forward modeling - ! (subroutine get_obs_pred()) - ! 0 = none - ! 1 = L-band tau-omega model as in De Lannoy et al. 2013 (doi:10.1175/JHM-D-12-092.1) (SMOS) - ! 2 = same as 1 but without Pellarin atm corr (SMAP) - ! 3 = same as 1 but with Mironov and SMAP L2_SM pol mixing (SMOS) - ! 4 = same as 3 but without Pellarin atm corr (targeted for SMAP L4_SM Version 8) - ! - ! reichle, 16 May 2011 - ! reichle, 31 Mar 2015 - added RTM_ID - ! - ! -------------------------------------------------------------------------- - - use MAPL_ConstantsMod, ONLY: & - MAPL_PI, & - MAPL_TICE - - use mwRTM_types, ONLY: & - mwRTM_param_type, & - mwRTM_param_nodata_check, & - assignment (=) - - use LDAS_ensdrv_globals, ONLY: & - logit, & - logunit, & - nodata_generic, & - nodata_tol_generic, & - LDAS_is_nodata - - use LDAS_exceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - ! everything is private by default unless made public - - private - - public :: mwRTM_get_Tb, catch2mwRTM_vars - - ! --------------------------------------------------------- - - real, parameter :: Tb_sky = 2.7 ! cosmic mw background temp [K] - - complex, parameter :: diel_ice = (3.2, 0.1) ! dielec. const. of ice - complex, parameter :: diel_air = (1.0, 0.0) ! dielec. const. of air - complex, parameter :: diel_rock = (5.5, 0.2) ! dielec. const. of rock - - real, parameter :: diel_watinf = 4.9 ! dielec. const. of water @ high freq. - ! (Stogryn 1971) - - real, parameter :: eps_0 = 8.854e-12 ! vacuum permittivity [Farads/meter] - ! (Klein and Swift 1977) - - real, parameter :: rho_soil = 2.66 ! soil specific density [g/cm3] - -contains - - ! ********************************************************************** - - ! Subroutine mwRTM_get_param() reads binary mwRTM files and is no longer used. - ! - ! The subroutine has been replaced by: - ! - Components/GEOSldas_GridComp/GEOSldas_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 - ! - get_mwrtm_param() in GEOS_LandAssimGridComp.F90 converts the internal state - ! variables of the Land Assim GridComp into the mwRTM structure. - ! - ! reichle, 4 Aug 2020 - -! subroutine mwRTM_get_param( N_catg, N_tile, d2g, tile_id, mwRTM_param_path, & -! need_mwRTM_param, mwp) -! -! ! Read microwave RTM parameters from file. -! ! -! ! reichle, 17 May 2011 -! ! reichle, 21 Oct 2011 - added input of mwRTM_param from file -! ! reichle, 23 Oct 2012 - removed look-up table option (too complicated with -! ! "new" (200+) soil classes) -! ! - added tile_id check when reading mwRTM params from file -! -! implicit none -! -! integer, intent(in) :: N_catg, N_tile -! -! integer, dimension(N_tile), intent(in) :: d2g, tile_id -! -! character(200), intent(in) :: mwRTM_param_path -! -! logical, intent(in) :: need_mwRTM_param -! -! type(mwRTM_param_type), dimension(N_tile), intent(out) :: mwp ! mwRTM parameters -! -! ! local variables -! -! integer, parameter :: N_search_dir_max = 5 -! -! integer :: n, N_search_dir, istat -! -! character( 80) :: fname -! -! character(100), dimension(N_search_dir_max) :: search_dir -! -! logical :: all_nodata, mwp_nodata -! -! character(len=*), parameter :: Iam = 'mwRTM_get_param' -! character(len=400) :: err_msg -! -! ! ---------------------------------------------------------------------- -! ! -! ! initialize -! -! do n=1,N_tile -! mwp(n) = nodata_generic -! end do -! -! ! read mwRTM parameters from file -! -! if (logit) write (logunit,*) 'Reading microwave RTM parameters from file' -! -! fname = '/mwRTM_param.bin' -! -! N_search_dir = 2 ! specify sub-dirs of mwRTM_param_path to search for file "fname" -! -! search_dir(1) = 'mwRTM' -! search_dir(2) = '.' -! -! ! when called with optional argument "istat" subroutine "open_land_param_file()" -! ! will *NOT* stop upon failure to open the file -! -! istat = open_land_param_file( 10, .false., .true., N_search_dir, fname, & -! mwRTM_param_path, search_dir, ignore_stop=.true.) -! -! if (istat==0) then -! -! call io_mwRTM_param_type( 'r', 10, N_tile, mwp, N_catg, tile_id, d2g ) -! -! close (10,status='keep') -! -! if (logit) write (logunit,*) 'done reading' -! if (logit) write (logunit,*) -! -! else -! -! if (logit) write (logunit,*) 'WARNING: Could not open file!' -! if (logit) write (logunit,*) -! -! end if -! -! ! check for no-data-values in parameters -! ! if any field is a nodata value, set all fields to nodata value -! -! all_nodata = .true. -! -! do n=1,N_tile -! -! call mwRTM_param_nodata_check( mwp(n), mwp_nodata ) -! -! if (.not. mwp_nodata) all_nodata = .false. -! -! end do -! -! ! stop if mwRTM parameters needed but not available (ie, all are no-data) -! -! if (all_nodata .and. need_mwRTM_param) then -! err_msg = 'mwRTM params needed but all are no-data!' -! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! end if -! -! ! warn if mwRTM parameters are all no-data (may not be needed) -! -! if (all_nodata .and. logit) then -! -! write (logunit,*) '#########################################################' -! write (logunit,*) -! write (logunit,*) ' WARNING: *All* parameters for the microwave radiative ' -! write (logunit,*) ' transfer model (mwRTM) are no-data values!!! ' -! write (logunit,*) -! write (logunit,*) '#########################################################' -! write (logunit,*) -! -! end if -! -! end subroutine mwRTM_get_param - - ! **************************************************************** - - subroutine catch2mwRTM_vars( N_tile, vegcls_catch, poros_catch, poros_mwRTM, & - sfmc_catch, tsurf_catch, tp1_catch, sfmc_mwRTM, tsoil_mwRTM, tp1_in_Kelvin ) - - ! convert soil moisture, surface temperature, and soil temperature from the Catchment - ! model into soil moisture and soil temperature inputs for the microwave radiative - ! transfer model (mwRTM) - ! - ! reichle, 11 Dec 2013 - ! - ! added optional switch to allow tp1_catch input in Kelvin - ! - reichle & borescan, 6 Nov 2020 - - implicit none - - integer, intent(in) :: N_tile - - integer, dimension(N_tile), intent(in) :: vegcls_catch - - real, dimension(N_tile), intent(in) :: poros_catch, poros_mwRTM - real, dimension(N_tile), intent(in) :: sfmc_catch, tsurf_catch, tp1_catch - - real, dimension(N_tile), intent(out) :: sfmc_mwRTM, tsoil_mwRTM - - logical, intent(in), optional :: tp1_in_Kelvin - - ! local variables - - logical :: tp1_in_K - - real, dimension(N_tile) :: tp1 - - ! ----------------------------------------------------------------------- - ! - ! reichle, 22 Oct 2012: scaling factor added because it is necessary for - ! proper functioning of mwRTM calibration to SMOS obs - - sfmc_mwRTM = sfmc_catch * poros_mwRTM / poros_catch - - ! diagnose soil temperature to be used with mwRTM - ! (change prompted by revision of Catchment model parameter CSOIL_2) - ! - reichle, 23 Dec 2015 - - ! NOTE: By default, "tp" is assumed to be in deg Celsius - - tp1_in_K = .false. - - if (present(tp1_in_Kelvin)) tp1_in_K = tp1_in_Kelvin - - tp1 = tp1_catch - - if (.not. tp1_in_K) tp1 = tp1 + MAPL_TICE ! convert units if not already in Kelvin - - tsoil_mwRTM = tp1 - - end subroutine catch2mwRTM_vars - - ! **************************************************************** - - subroutine mwRTM_get_Tb( N_tile, freq, inc_angle, mwp, elev, & - LAI, soilmoist, soiltemp, SWE, Tair, RTM_ID, Tb_h, Tb_v ) - - !--------------------------------------------------- - !RTM adapted from Steven Chan - !23 Nov 2010: - adapted to include the atmospheric correction - ! GDL, code based on CMEMv3.0 - ! - !Instead of passing on the whole diagnostic structure, - !only pass rtmv, T5, Tc !GDL, 22Oct10 - ! - !N_cat could be either all tiles or only a part of them! - ! - !== rtmv: Soil moisture in in g/cm3 (volumetric) - !FYI: - !SM vol/vol ~ g/cm3 - !gravim SM (g/g) * bulk densit (g/cm3) = volum SM (vol/vol) ~ g/cm3 - ! - !== VWC: Vegetation water content in kg/m2 (=mm) - !== T5: Soil temperature [K] - !== Tc: Vegetation canopy temperature [K] - ! - !21 Mar 2011: - temperature treatment changed - !==> instead of passing on T5 and Tc (= tsurf) - !we now pass on tsurf and tp1 and diagnose T10cm (~T5) from it HERE - !==> tsurf and tp1 are now input variables - !==> T5 and Tc are local variables - ! - ! Mar 2011: - replaced realdobson by Wang for diel cst - ! 02 May 2011: - put in *COS(inc*d2r)**Nrh/v for rsh/v - ! - changed Q=0 to Q=expression in CMEM - ! - option to scale model SM before entering RTM - ! - ! 16 May 2011: - reichle: - included in LDASsa, major revisions - ! 21 Oct 2011: - reichle: input "poros" now via "mwp" - ! 23 Nov 2011: - reichle: changed tsoil_threshold b/c QC now done for individual - ! ensemble members - ! 22 Oct 2012: - reichle: removed interception water ("capac") contribution - ! - !--------------------------------------------------- - - implicit none - - integer, intent(in) :: N_tile ! number of tiles - - real, intent(in) :: freq ! [Hz] - real, intent(in) :: inc_angle ! [deg] - - type(mwRTM_param_type), dimension(N_tile), intent(in) :: mwp - - real, dimension(N_tile), intent(in) :: elev ! [m] - - real, dimension(N_tile), intent(in) :: LAI ! [dim-less] - real, dimension(N_tile), intent(in) :: soilmoist ! [m3/m3] - real, dimension(N_tile), intent(in) :: soiltemp ! [K] - real, dimension(N_tile), intent(in) :: SWE ! [kg/m2] "mm" - real, dimension(N_tile), intent(in) :: Tair ! [K] - - integer, intent(in) :: RTM_ID - - real, dimension(N_tile), intent(out) :: Tb_h, Tb_v ! [K] - - ! -------------------- - - ! local variables - - real, parameter :: tsoil_threshold = MAPL_TICE+0.2 ! avoid "frozen" soil [K] - - real, parameter :: SWE_threshold = 1.e-4 ! avoid snow [kg/m2] - - integer :: n - - real :: inc, sin_inc, cos_inc - - complex :: c_er, tmpc1, tmpc2 - - real :: roh, rov, rsh, rsv - - real :: h_mc, Q, slope - - real :: vwc, Ah, Av, exptauh, exptauv, exptauh2, exptauv2, tmpreal - - real :: exptau_atm, tau_atm, Tb_ad, Tb_au - - real :: soiltemp_in_C, Tc - - !real :: er_r ! for realdobson - - logical :: veg_params_nodata - - character(len=*), parameter :: Iam = 'mwRTM_get_Tb' - character(len=400) :: err_msg - - !--------------------------------------------------- - - !if (logit) write(logunit,*) 'entering mwRTM_get_Tb...' - - ! check first element of elevation against no-data-value - ! (elevation is only needed for RTMs with Pellarin atm corr) - - select case (RTM_ID) - - case(1,3) - - if ( abs(elev(1)-nodata_generic)tsoil_threshold) .and. & - (.not. LDAS_is_nodata(mwp(n)%sand)) .and. & - (.not. veg_params_nodata) & - ) then - - ! soil dielectric constant - - soiltemp_in_C = soiltemp(n) - MAPL_TICE - - select case (RTM_ID) - - case(1,2) - - CALL DIELWANG (freq, soilmoist(n), soiltemp_in_C, & - mwp(n)%wang_wt, mwp(n)%wang_wp, mwp(n)%poros, & - mwp(n)%sand, mwp(n)%clay, c_er ) - - case(3,4) - - CALL MIRONOV( freq, soilmoist(n), mwp(n)%clay, c_er ) - - case default - - err_msg = 'unknown RTM_ID (during soil dielectric model)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - ! soil reflectivity for smooth surface based on dielect const. (Fresnel) - - tmpc1 = SQRT(c_er - sin_inc**2) - - tmpc2 = c_er * cos_inc - - roh = ABS( (cos_inc - tmpc1) / (cos_inc + tmpc1) )**2 - rov = ABS( (tmpc2 - tmpc1) / (tmpc2 + tmpc1) )**2 - - ! ------------------------------------------------------- - ! - ! roughness corrections: - ! - ! soil reflectivity for rough surface, based on h-Q model - ! note that in Choudhury et al., 79, there is a factor exp(-h cos^2 inc) - ! GDL, 14Feb11, replaced h by SM-dependent h - ! GDL, 02May11, added cos^N factor - ! - ! 1) roughness parameter h depends on soil moisture - - if (soilmoist(n)<=mwp(n)%rgh_wmin) then - - h_mc = mwp(n)%rgh_hmax - - elseif (soilmoist(n)>=mwp(n)%rgh_wmax) then - - h_mc = mwp(n)%rgh_hmin - - else - - slope = & - (mwp(n)%rgh_hmin - mwp(n)%rgh_hmax)/ & - (mwp(n)%rgh_wmax - mwp(n)%rgh_wmin) - - h_mc = mwp(n)%rgh_hmax + slope * (soilmoist(n) - mwp(n)%rgh_wmin) - - endif - - ! 2) polarization mixing, Q as defined in CMEM: - - if (freq < 2.e9) then - - select case (RTM_ID) - - case(1,2) - - Q = 0. ! Q is assumed zero at low frequency - - case(3,4) - - Q = 0.1771 * h_mc - - case default - - err_msg = 'unknown RTM_ID (during pol mixing)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - else - - Q = 0.35 * (1.0 - exp(-0.6 * (mwp(n)%rgh_polmix**2) * (freq/1.e9) )) - - end if - - ! rough surface reflectivity - - select case (RTM_ID) - - case(1,2) - - rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**mwp(n)%rgh_nrh) - rsv = ( (1-Q) * rov + Q * roh) * EXP(-h_mc*cos_inc**mwp(n)%rgh_nrv) - - case(3,4) - - rsh = ( (1-Q) * roh + Q * rov) * EXP(-h_mc*cos_inc**2) - rsv = ( (1-Q) * rov + Q * roh) * EXP(-h_mc*cos_inc**2) - - case default - - err_msg = 'unknown RTM_ID (during rough reflectivity)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - ! ------------------------------------------------------------- - ! - ! Tb at top of vegetation (excl atmos contribution) (tau-omega model) - - ! vegetation attenuation parameters can come from either of two sources: - ! - static look-up table or calibrated parameters (bh, bv, lewt), to be combined - ! with time-varying LAI - ! - vegetation opacity (from file); varies with time - - ! the if statement above, in conjunction with mwRTM_param_nodata_check() called earlier, - ! ensures that we have "good" values for either (vegopacity) or (bh,bv,lewt) - - if ( LDAS_is_nodata( mwp(n)%vegopacity ) ) then - - ! == vwc: Vegetation water content in kg/m2 (=mm) - ! needs to be the total columnar vegetation water content, - ! depends on greenness/NDVI/LAI... - ! VWC=LEWT*LAI, lewt is actually a time-varying parameter! - ! For now LEWT is guessed based on literature, and kept cst. - - vwc = mwp(n)%lewt * lai(n) - - ! removed contribution of interception water ("capac") - ! - !! ! add bit of intercepted water as well - !! - !! vwc = vwc + capac(n) - - ! Vegetation optical thickness tau=b*VWC (eq. (2) in Crow et al. 2005) - - tmpreal = vwc/cos_inc - - exptauh = EXP( -mwp(n)%bh * tmpreal ) - exptauv = EXP( -mwp(n)%bv * tmpreal ) - - else - - exptauh = EXP( -mwp(n)%vegopacity) - exptauv = EXP( -mwp(n)%vegopacity) - - end if - - Tc = soiltemp(n) ! canopy temp = soil temp - - tmpreal = Tc * (1. - mwp(n)%omega) - - Ah = tmpreal * (1. - exptauh) - Av = tmpreal * (1. - exptauv) - - ! Eq.(1) in Crow et al. 2005: - ! - ! Tb_tov = Tb_soil.e_p.exp(-tau/cos theta) + Tb_veg.(1 + r_r.exp(-tau/cos theta)) - - Tb_h(n) = soiltemp(n) * (1. - rsh) * exptauh + Ah * (1. + rsh * exptauh) - Tb_v(n) = soiltemp(n) * (1. - rsv) * exptauv + Av * (1. + rsv * exptauv) - - - ! ------------------------------------------------------------- - ! - ! Atmospheric correction - ! - ! GDL 23nov10 - - select case (RTM_ID) - - case(1,3) - - exptauh2 = exptauh * exptauh - exptauv2 = exptauv * exptauv - - if (freq<2.e9) then - - call ATMPELLARIN( elev(n)/1000., Tair(n), cos_inc, tau_atm, Tb_ad, Tb_au ) - - else - - err_msg = 'cannot compute atm corr for given freq' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - exptau_atm = EXP( - tau_atm/cos_inc ) - - Tb_h(n) = Tb_h(n) + Tb_ad*rsh*exptauh2 ! top-of-veg Tb_h (incl atm. contrib.) - Tb_v(n) = Tb_v(n) + Tb_ad*rsv*exptauv2 ! top-of-veg Tb_v (incl atm. contrib.) - - Tb_h(n) = Tb_h(n) * exptau_atm + Tb_au ! top-of-atmosphere Tb_h - Tb_v(n) = Tb_v(n) * exptau_atm + Tb_au ! top-of-atmosphere Tb_v - - - case(2,4) - - ! do nothing - - case default - - err_msg = 'unknown RTM_ID (during Pellarin atm corr)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - else ! snow present, soil frozen, or mwRTM params not available - - Tb_h(n) = nodata_generic - Tb_v(n) = nodata_generic - - endif - - end do - - !if (logit) write(logunit,*) 'exiting mwRTM_get_Tb.' - - end subroutine mwRTM_get_Tb - - - ! ********************************************************************** - - subroutine atmpellarin( Z, tair, costheta, tau_atm, tb_ad, tb_au) - - ! opacity and brightness temperature of atmosphere for low-freq microwave - ! (up to and incl. L-band) - ! - ! GDL, 23nov10 - ! Code based on CMEMv3.0 - ! - ! reichle, 16 May 2011: included in LDASsa - ! - ! --------------------------------------------------------- - - implicit none - - ! arguments - - real, intent(in) :: costheta ! cosine of incidence angle [dim-less] - real, intent(in) :: Z ! elevation above sea-level [km] - real, intent(in) :: tair ! surface air temperature [K] - - real, intent(out) :: tau_atm ! atmospheric opacity [dim-less] - real, intent(out) :: tb_ad ! downwelling atm Tb [K] - real, intent(out) :: tb_au ! upwelling atm Tb [K] - - ! local variables - - real :: GOSSAT, TAEQ - - !--------------------------------------------------------------------- - ! - ! 1. Zenith atmospheric opacity - - tau_atm = exp( -3.926 - 0.2211 * Z - 0.00369 *tair) - - - ! 2. Calculate up- and downward atmospheric radiation - - GOSSAT = exp(-tau_atm/ costheta) - - TAEQ = exp( 4.927 + 0.002195 * tair) - - tb_ad = TAEQ*(1. - GOSSAT) + Tb_sky * GOSSAT - - tb_au = TAEQ*(1. - GOSSAT) - - end subroutine atmpellarin - - - ! ************************************************************ - - subroutine dielwang( FREQ, WC, TS, wt, wp, poros, sand, clay, eps) - - ! GDL, 28Mar11 - ! Code adapted from CMEMv3.0 - ! - ! reichle, 16 May 2011: included in LDASsa - ! - ! - ! Purpose : - ! Calculate the dielectric constant of a wet soil - ! Developed and validated for 1.4 and 5 GHz. - ! - ! Reference: - ! Wang and Schmugge, 1980: An empirical model for the - ! complex dielectric permittivity of soils as a function of water - ! content. IEEE Trans. Geosci. Rem. Sens., GE-18, No. 4, 288-295. - ! - !--------------------------------------------------------------------------- - - implicit none - - real, intent(in) :: FREQ ! microwave frequency [Hz] - real, intent(in) :: TS ! soil temperature [deg C] - - real, intent(in) :: WC ! volumetric soil water content [m3/m3] - - real, intent(in) :: wt ! transition soil moisture [m3/m3] - real, intent(in) :: wp ! wilting point [m3/m3] - real, intent(in) :: poros ! porosity - real, intent(in) :: sand ! sand fraction [0-1] - real, intent(in) :: clay ! clay fraction [0-1] - - complex, intent(out) :: eps ! dielectric constant of soil-water mixture [dim-less] - - ! ------------------------------------- - ! - ! local variables - - complex, parameter :: j = (0. , 1. ) - - real :: gamma ! fitting parameter - real :: ecl ! conductivity loss - complex :: ew ! dielectric constant of water - complex :: ex ! dielectric constant of the initially absorbed water - - real :: alpha - - !--------------------------------------------------------------------------- - ! - ! 0. Compute dielectric constant of free water - ! - ! assume soil salinity = 0 - - call DIEL_WAT( 2, 2, TS, 0., FREQ, clay, sand, poros, wc, ew) - - !--------------------------------------------------------------------------- - ! - ! 1. Calculate dielectric constant of soil-water mixture - - gamma = -0.57 * wp + 0.481 - - ! wt = 0.49 * wp + 0.165 transition SM parameter from Wang and Schmugge 1980; - ! note typo in De Lannoy et al 2013 (0.48 instead of 0.49) - - - IF (wc <= wt) THEN - - ex = diel_ice + (ew-diel_ice)*(wc/wt)*gamma - - eps = wc*ex + (poros-wc)*diel_air + (1.-poros)*diel_rock - - ELSE - - ex = diel_ice + (ew-diel_ice)*gamma - - eps = wt*ex + (wc-wt)*ew + (poros-wc)*diel_air + (1.-poros)*diel_rock - - ENDIF - - !--------------------------------------------------------------------------- - ! - ! 2. add conductivity loss (Wang dielectric model) - - if (FREQ > 2.5e9) then - - alpha = 0. - - else - - alpha = min( 100.*wp, 26.) - - end if - - ecl = alpha * wc**2. - - eps = eps + j * ecl - - end subroutine dielwang - - - ! ************************************************************ - - SUBROUTINE DIEL_WAT( medium, isal, T, sal, freq, clay, sand, poros, wc, ew) - - ! adapted from CMEM3.0, GDL - 23May11 - ! - ! included in LDASsa, reichle - 2 Jun 2011 - - ! Purpose : - ! Calculate dielectric constant of water in three different media : - ! pure water, sea water, soil water - - ! Reference: - ! Dielectric constant of pure water - ! Ulaby p 2020 - ! Dielectric constant of saline water - ! 1) Stogryn, A. (1971): Equations for calculating the dielectric constant of - ! saline water, IEEE Transactions on Microwave Theory and Techniques, - ! Vol. MTT-19, 733-736. - ! 2) Klein, L. A. and C. T. Swift (1977): An improved model - ! for the dielectric constant of sea water at microwave - ! frequencies, IEEE Transactions on Antennas and Propagation, - ! Vol. AP-25, No. 1, 104-111. - ! Dielectric constant of soil water - ! 1) Dobson '85. Modified Debye expression - ! Stern_Gouy double layer theory - ! 2) Ulaby p 2024 - - ! Interface : - ! medium = pure water(0) sea water(1) soil water(2) - ! isal = Stogryn (1) Klein and Swift (2) - - ! local variables : - ! N : normality from salinity (Stogryn, modified by Klein and Swift 1977) - ! T : temperature of water (C) - ! ew : dielectric constant of water - ! sal : water salinity (psu = ppt(weight) ) - ! eps_w0 : static dielectric constant of pure water (Klein and Swift 1977) - ! eps_sw0 : Static dielectric constant of soil water - ! tau_w : relaxation time of pure water (stogryn, 1970) - ! tau_sw : relaxation time of saline water - ! sigma : ionic conductivity - ! sigma_eff : effective conductivity of water (S/m) - !--------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER, intent(in) :: medium ! 0=pure water, 1=sea water, 2=soil water - INTEGER, intent(in) :: isal ! 1=Stogryn, 2=Klein and Swift - REAL, intent(in) :: T ! temperature of water [C] - REAL, intent(in) :: sal ! salinity of water [PSU] - REAL, intent(in) :: freq ! microwave frequency [Hz] - REAL, intent(in) :: poros ! porosity [m3/m3] - real, intent(in) :: sand ! sand fraction [0-1] - real, intent(in) :: clay ! clay fraction [0-1] - real, intent(in) :: wc ! soil moisture [m3/m3] - - COMPLEX, intent(out) :: ew ! dielec. const. of water at given freq, T, sal, etc. - - ! local variables - - complex, parameter :: j = (0. , 1. ) - - real :: rho_b - - REAL :: N, omega, wc_c - REAL :: sigma_eff - REAL :: tau_w, tau_sw - REAL :: eps_w0, eps_sw0, a, bb - - character(len=*), parameter :: Iam = 'DIEL_WAT' - character(len=400) :: err_msg - - !--------------------------------------------------------------------------- - - tau_w = 1.768e-11 + T*(-6.068e-13 + T*(1.104e-14 - T*8.111e-17 )) - - ! tau_w = 1.768e-11 - 6.068e-13 * T + 1.104e-14 * T**2 - 8.111e-17 * T**3 - ! - ! same as: - ! - ! tau_w = 1./(2.*pi) * (1.1109e-10 - 3.824e-12 * T + 6.938e-14 * T**2 & - ! - 5.096e-16 * T**3) - - omega = 2.0 * MAPL_PI * freq - - rho_b = (1.-poros)*rho_soil ! soil bulk density [g/cm3] - - - SELECT CASE (isal) - - CASE ( 1 ) ! Stogryn (1971) - - N = 0.9141 * sal * (1.707e-2 + sal*(1.205e-5 + sal*4.058e-9)) - - eps_sw0 = 87.74 + T*(-0.4008 + T*(9.398e-4 + T*1.410e-6)) - - a = 1. + N*(-0.2551 + N*(5.151e-2 - N*6.889e-3)) - - eps_sw0 = eps_sw0 * a - - bb = 1. + N*(-0.04896 + 0.1463e-2*T + N*(-0.02967 + N*5.644e-3)) - - tau_sw = tau_w * bb - - CASE ( 2 ) ! Klein and Swift (1977) - - eps_sw0 = 87.134 + T*(-1.949e-1 + T*(-1.276e-2 + T*2.491e-4)) - - a = 1. + sal*( 1.613e-5*T -3.656e-3 + sal*(3.210e-5 - sal*4.232e-7)) - - eps_sw0 = eps_sw0 * a - - bb = 1. + sal*(2.282e-5*T - 7.638e-4 + sal*(-7.760e-6 + sal*1.105e-8)) - - tau_sw = tau_w * bb - - END SELECT - - - SELECT CASE (medium) - - CASE ( 0 ) ! pure water - - eps_w0 = 88.045 + T*(-0.4147 + T*(6.295e-4 + T*1.075e-5)) - - ew = diel_watinf + (eps_w0 - diel_watinf) / (1. - j * omega * tau_w) - - CASE ( 1 ) ! sea water - - err_msg = 'medium=1 (sea water) not implemented' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - CASE ( 2 ) ! soil water - - ! changed units of sand, clay to [0-1], reichle, 2 Jun 2011 - - ! Avoid negative sigma_eff for very sandy soils with low bulk densities. - - sigma_eff = max( 0., -1.645 + 1.939*rho_b - 2.256*sand + 1.594*clay) - - ! Modified Debye expression, Dobson '85 - - wc_c = MAX(0.001, wc) ! to avoid dividing by zero - - ew = diel_watinf + (eps_sw0 - diel_watinf) / (1. - j * omega * tau_sw) & - + j * sigma_eff / (omega * eps_0) * (rho_soil - rho_b) / (rho_soil * wc_c) - - END SELECT - - END SUBROUTINE DIEL_WAT - - ! ********************************************************************** - - SUBROUTINE MIRONOV( freq, mv, clayfrac, er_r ) - - ! Soil dielectric mixing model by Mironov et al IEEE TGRS 2009, doi:10.1109/TGRS.2008.2011631 - ! - ! 8 May 2023: Implementation taken from SMAP L2_SM_P retrieval model by qliu; clean-up by reichle - - IMPLICIT NONE - - REAL, INTENT(IN) :: freq ! microwave frequency [Hz] - REAL, INTENT(IN) :: mv ! volumetric soil water content [m3/m3] - REAL, INTENT(IN) :: clayfrac ! clay fraction [0-1] - - COMPLEX, INTENT(OUT) :: er_r ! complex dielectric constant of moist soil - - ! ------------------------------ - - REAL :: f, C, mvt - REAL :: nd, nb, nu, nm - REAL :: kd, kb, ku, km - REAL :: eps0b, taub, sigb, epsb_real, epsb_imag - REAL :: eps0u, tauu, sigu, epsu_real, epsu_imag - REAL :: er_r_real, er_r_imag - - REAL :: tmp2PIf, tmpeps0 - - REAL :: tmptaub, tmptaub2plus1, tmpdiffepsb - REAL :: tmptauu, tmptauu2plus1, tmpdiffepsu - - REAL :: tmpreal, tmprealb, tmprealu - - ! -------------------------------------------------------------------------------------- - - f = freq ! Section IV - C = clayfrac*100 ! Section VI - - !! Mironov's regression expressions based on Curtis, Dobson, and Hallikainen datasets - !! - !! mvt : max bound water fraction - !! - !! eps(*) : dielectric constant (real part) and loss factor (imaginary part) - !! n(*) : refractive index - !! k(*) : normalized attenuation coefficient - !! tau(*) : relaxation constant - !! sig(*) : conductivity - !! - !! m: moist soil - !! d: dry soil - !! b: bound soil water (BSW) - !! u: unbound (free) soil water (FSW) - - nd = 1.634 - 0.539e-2 * C + 0.2748e-4 * C**2 ! Eqn 17 - kd = 0.03952 - 0.04038e-2 * C ! Eqn 18 - mvt = 0.02863 + 0.30673e-2 * C ! Eqn 19 - eps0b = 79.8 - 85.4e-2 * C + 32.7e-4 * C**2 ! Eqn 20 - taub = 1.062e-11 + 3.450e-12 * 1e-2 * C ! Eqn 21 - sigb = 0.3112 + 0.467e-2 * C ! Eqn 22 - sigu = 0.3631 + 1.217e-2 * C ! Eqn 23 - eps0u = 100. ! Eqn 24 - tauu = 8.5e-12 ! Eqn 25 - - !! Debye relaxation equations for water as a function of frequency ! Eqn 16 - - tmp2PIf = 2.*MAPL_PI*f - - tmpeps0 = tmp2PIf*eps_0 - - tmptaub = tmp2PIf*taub - tmptauu = tmp2PIf*tauu - - tmptaub2plus1 = 1. + tmptaub**2 - tmptauu2plus1 = 1. + tmptauu**2 - - tmpdiffepsb = eps0b - diel_watinf - tmpdiffepsu = eps0u - diel_watinf - - epsb_real = diel_watinf + tmpdiffepsb/tmptaub2plus1 - epsb_imag = tmpdiffepsb/tmptaub2plus1 * tmptaub + sigb/tmpeps0 - epsu_real = diel_watinf + tmpdiffepsu/tmptauu2plus1 - epsu_imag = tmpdiffepsu/tmptauu2plus1 * tmptauu + sigu/tmpeps0 - - !! Refractive indices and normalized attenuation coefficients - - tmpreal = 1/sqrt(2.0) - - tmprealb = sqrt( epsb_real**2 + epsb_imag**2 ) - tmprealu = sqrt( epsu_real**2 + epsu_imag**2 ) - - nb = tmpreal * sqrt( tmprealb + epsb_real ) ! Eqn 14 - kb = tmpreal * sqrt( tmprealb - epsb_real ) ! Eqn 15 - nu = tmpreal * sqrt( tmprealu + epsu_real ) ! Eqn 14 - ku = tmpreal * sqrt( tmprealu - epsu_real ) ! Eqn 15 - - IF (mv <= mvt) THEN - - nm = nd + (nb - 1.) * mv ! Eqn 12 - km = kd + kb * mv ! Eqn 13 - - ELSE - - nm = nd + (nb - 1.) * mvt + (nu - 1.) * (mv - mvt) ! Eqn 12 - km = kd + kb * mvt + ku * (mv - mvt) ! Eqn 13 - - ENDIF - - ! complex dielectric constant of moist soil - - er_r_real = nm**2 - km**2 ! Eqn 11 - er_r_imag = 2. * nm * km ! Eqn 11 - - er_r = CMPLX(er_r_real,er_r_imag) - - END SUBROUTINE mironov - - ! ********************************************************************** - -end module mwRTM_routines - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -#if 0 - -! driver routines for testing - -program test_mwRTM_types - - use mwRTM_routines - - implicit none - - type(mwRTM_param_type) :: mwRTM_param - - mwRTM_param = -9999. - - write (*,*) mwRTM_param - -end program test_mwRTM_types - -#endif - -! ========================== EOF ================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 b/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 deleted file mode 100644 index 5080c291..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandassim_GridComp/mwRTM_types.F90 +++ /dev/null @@ -1,471 +0,0 @@ - -module mwRTM_types - - ! definition of types and associated operators for microwave radiative transfer model - ! - ! IMPORTANT: - ! When adding a field to any of the derived types, must also update - ! the associated assignment and operator definitions. - ! THERE IS NO WARNING/ERROR IF OPERATOR IS NOT DEFINED FOR ALL FIELDS! - ! - ! reichle, 16 May 2011 - ! reichle, 21 Oct 2011 - added field "poros" to "mwRTM_param_type" - ! - ! -------------------------------------------------------------------------- - - use LDAS_ensdrv_globals, ONLY: & - nodata_generic, & - nodata_tol_generic, & - LDAS_is_nodata - - use ldas_exceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - ! everything is private by default unless made public - - private - - public :: mwRTM_param_type - public :: mwRTM_param_nodata_check - - public :: assignment (=) - - ! --------------------------------------------------------- - - ! model parameters - - type :: mwRTM_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer :: vegcls ! land cover/veg class (can differ from cat_param%vegcls ! ) - integer :: soilcls ! soil class (can differ from cat_param%soilcls30! ) - - real :: sand ! sand fraction [0-1] - real :: clay ! clay fraction [0-1] - - real :: poros ! porosity (can differ from cat_param%poros!) [m3/m3] - - ! parameters relating to soil mixing model - - real :: wang_wt ! Wang dielectric model: transition s.m. [m3/m3] - real :: wang_wp ! Wang dielectric model: wilting point s.m. [m3/m3] - - ! parameters relating to emissivity of rough surface - - real :: rgh_hmin ! min roughness [dim-less] - real :: rgh_hmax ! max roughness [dim-less] - real :: rgh_wmin ! soil moisture for transition to hmax [m3/m3] - real :: rgh_wmax ! soil moisture for transition to hmin [m3/m3] - real :: rgh_Nrh ! h-pol exponent for inc angle parameterization [dim-less] - real :: rgh_Nrv ! v-pol exponent for inc angle parameterization [dim-less] - real :: rgh_polmix ! polarization mixing parameter [dim-less] - - real :: omega ! single scattering albedo [dim-less] - - ! parameters relating to vegetation opacity - - real :: bh ! veg b parameter (h-pol) (tau = b*VWC) [dim-less] - real :: bv ! veg b parameter (v-pol) (tau = b*VWC) [dim-less] - real :: lewt ! VWC = lewt*LAI [kg/m2] - real :: vegopacity ! veg opacity = tau/cos(inc_angle) [dim-less] - - end type mwRTM_param_type - - ! --------------------------------------------------------- - - interface assignment (=) - module procedure scalar2mwRTM_param - end interface - -contains - - ! ********************************************************************** - - ! Subroutine io_mwRTM_param_type() reads and writes binary mwRTM files and is no longer used. - ! - ! The subroutine has been replaced by: - ! - Components/GEOSldas_GridComp/GEOSldas_App/[..]/mwrtm_bin2nc4.F90 converts mwRTM files from binary to nc4 - ! - get_mwrtm_param() in GEOS_LandAssimGridComp.F90 converts the internal state - ! variables of the Land Assim GridComp into the mwRTM structure. - ! - ! reichle, 4 Aug 2020 - -! subroutine io_mwRTM_param_type( action, unitnum, N_tile, mwp, N_catg, tile_id, d2g ) -! -! ! read/write mwRTM_param for domain from/to file -! ! -! ! write: write mwRTM params for N_tile tiles in domain -! ! -! ! read: read mwRTM params for -! -! ! -! ! reichle, 1 Jun 2011 -! ! reichle, 21 Oct 2011 -- added "read" for mwRTM params -! ! reichle, 22 Oct 2012 -- added check for tile_id to mwRTM param input -! ! -! ! ------------------------------------------------------------------- -! -! implicit none -! -! character, intent(in) :: action -! -! integer, intent(in) :: unitnum -! -! integer, intent(in) :: N_tile ! =N_catd -! -! type(mwRTM_param_type), dimension(N_tile), intent(inout) :: mwp -! -! integer, optional, intent(in) :: N_catg -! -! integer, optional, dimension(N_tile), intent(in) :: tile_id, d2g -! -! ! local variables -! -! integer :: n, N_tmp -! -! integer, dimension(:), allocatable :: tmpint -! real, dimension(:), allocatable :: tmpreal -! -! character(len=*), parameter :: Iam = 'io_mwRTM_param_type' -! character(len=400) :: err_msg -! -! ! ------------------------------------------------------------------ -! -! select case (action) -! -! case ('w','W') ! write mwp for all tiles in domain -! -! write (unitnum) N_tile -! -! write (unitnum) (mwp(n)%vegcls , n=1,N_tile) ! integer -! write (unitnum) (mwp(n)%soilcls , n=1,N_tile) ! integer -! -! write (unitnum) (mwp(n)%sand , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%clay , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%poros , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%wang_wt , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%wang_wp , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%rgh_hmin , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_hmax , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_wmin , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_wmax , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_Nrh , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_Nrv , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%rgh_polmix, n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%omega , n=1,N_tile) ! real -! -! write (unitnum) (mwp(n)%bh , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%bv , n=1,N_tile) ! real -! write (unitnum) (mwp(n)%lewt , n=1,N_tile) ! real -! -! case ('r','R') -! -! ! read the parameters for all global tiles (similar to read_land_parameters()) -! -! ! optional inputs N_catg and d2g must be present -! -! if ( (.not. present(N_catg )) .or. & -! (.not. present(tile_id)) .or. & -! (.not. present(d2g )) ) then -! err_msg = 'missing optional inputs N_catg, tile_id, d2g' -! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! end if -! -! ! read how many tiles are in file and double-check against N_catg -! -! read (unitnum) N_tmp -! -! if (N_tmp .ne. N_catg) then -! err_msg = 'number of tiles in file .ne. N_catg' -! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! end if -! -! ! allocate tmp vectors -! -! allocate(tmpint( N_catg)) -! allocate(tmpreal(N_catg)) -! -! ! read tile IDs (first record) -! -! read (unitnum) tmpint; -! -! ! make sure tile IDs match (works only for "SiB2_V2" and newer versions) -! -! if (any(tile_id/=tmpint(d2g(1:N_tile)))) then -! err_msg = 'mismatch of tile IDs for mwRTM_parameters' -! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! end if -! -! ! read and subset from global tile space to domain -! -! read (unitnum) tmpint; mwp(1:N_tile)%vegcls = tmpint( d2g(1:N_tile)) -! read (unitnum) tmpint; mwp(1:N_tile)%soilcls = tmpint( d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%sand = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%clay = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%poros = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%wang_wt = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%wang_wp = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_hmin = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_hmax = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_wmin = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_wmax = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_Nrh = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_Nrv = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%rgh_polmix = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%omega = tmpreal(d2g(1:N_tile)) -! -! read (unitnum) tmpreal; mwp(1:N_tile)%bh = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%bv = tmpreal(d2g(1:N_tile)) -! read (unitnum) tmpreal; mwp(1:N_tile)%lewt = tmpreal(d2g(1:N_tile)) -! -! ! clean up -! -! deallocate(tmpreal) -! deallocate(tmpint) -! -! case default -! -! err_msg = 'unknown action ' // action -! call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) -! -! end select -! -! end subroutine io_mwRTM_param_type - - ! ************************************************************ - - subroutine scalar2mwRTM_param( mwRTM_param, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(mwRTM_param_type), intent(out) :: mwRTM_param - - ! --------------------- - - mwRTM_param%vegcls = nint(scalar) - mwRTM_param%soilcls = nint(scalar) - - mwRTM_param%sand = scalar - mwRTM_param%clay = scalar - mwRTM_param%poros = scalar - mwRTM_param%wang_wt = scalar - mwRTM_param%wang_wp = scalar - mwRTM_param%rgh_hmin = scalar - mwRTM_param%rgh_hmax = scalar - mwRTM_param%rgh_wmin = scalar - mwRTM_param%rgh_wmax = scalar - mwRTM_param%rgh_Nrh = scalar - mwRTM_param%rgh_Nrv = scalar - mwRTM_param%rgh_polmix = scalar - mwRTM_param%omega = scalar - mwRTM_param%bh = scalar - mwRTM_param%bv = scalar - mwRTM_param%lewt = scalar - mwRTM_param%vegopacity = scalar - - end subroutine scalar2mwRTM_param - - ! ************************************************************ - - subroutine mwRTM_param_nodata_check( mwp, mwp_nodata ) - - ! check microwave radiative transfer model parameters for no-data values - ! - ! if there is a no-data value in any required field, set "all" fields - ! within the corresponding group of parameters to no-data - ! - ! vegetation attenuation parameters can come from either of two sources: - ! - static look-up table or calibrated parameters (bh, bv, lewt), to be combined - ! with time-varying LAI - ! - vegetation opacity (from file); varies with time - ! - ! preprocessing of the mwRTM restart and vegopacity files must ensure that - ! either (bh,bv,lewt) or (vegopacity) is no-data - ! - ! - reichle, 13 July 2021 (revised for using vegopacity from file) - - implicit none - - type(mwRTM_param_type), intent(inout) :: mwp - - logical, intent( out), optional :: mwp_nodata - - ! local variables - - logical :: veg_atten_static_params_nodata, veg_params_nodata, other_params_nodata - - real :: realvegcls, realsoilcls - - character(len=*), parameter :: Iam = 'mwRTM_param_nodata_check' - character(len=400) :: err_msg - - ! ----------------------------------------------------------------------------- - - ! Group 1: Parameters related to vegetation attenuation - ! - ! need either (bh, bv, lewt) or (vegopacity) - ! - ! check if static look-up table or calibrated parameters are available - - veg_atten_static_params_nodata = & - ( & - LDAS_is_nodata( mwp%bh ) .or. & - LDAS_is_nodata( mwp%bv ) .or. & - LDAS_is_nodata( mwp%lewt ) & - ) - - if ( (.not. veg_atten_static_params_nodata) .and. (.not. LDAS_is_nodata( mwp%vegopacity )) ) then - - ! inconsistent mwRTM restart and vegopacity files: - ! for a given tile, (bh, bv, lewt) from mwRTM restart and (vegopacity) from file must - ! not both have good values - - err_msg = 'inconsistent mwRTM restart and vegopacity files: found good values for (bh,bv,lewt) *and* (vegopacity)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - ! return if *only* interested in checking no-data consistency for veg attenuation params - - if (.not. present(mwp_nodata)) return - - ! - - - - - - - - - - - - - - - - - - - - - - - ! - ! rest of subroutine only needs to run once - - if ( veg_atten_static_params_nodata ) then - - ! make sure all related fields in this group are no-data if at least one is nodata - - mwp%bh = nodata_generic - mwp%bv = nodata_generic - mwp%lewt = nodata_generic - - end if - - ! veg_params_nodata = .true. if missing vegetation attenuation info altogether - - veg_params_nodata = & - ( & - veg_atten_static_params_nodata & - .and. & - LDAS_is_nodata( mwp%vegopacity ) & - ) - - ! ----------------------------------------------------------------------------- - - ! Group 2: Parameters for the rest of the tau-omega equations - - realvegcls = real(mwp%vegcls) - realsoilcls = real(mwp%soilcls) - - other_params_nodata = & - ( & - LDAS_is_nodata( realvegcls ) .or. & - LDAS_is_nodata( realsoilcls ) .or. & - LDAS_is_nodata( mwp%sand ) .or. & - LDAS_is_nodata( mwp%clay ) .or. & - LDAS_is_nodata( mwp%poros ) .or. & - LDAS_is_nodata( mwp%wang_wt ) .or. & - LDAS_is_nodata( mwp%wang_wp ) .or. & - LDAS_is_nodata( mwp%rgh_hmin ) .or. & - LDAS_is_nodata( mwp%rgh_hmax ) .or. & - LDAS_is_nodata( mwp%rgh_wmin ) .or. & - LDAS_is_nodata( mwp%rgh_wmax ) .or. & - LDAS_is_nodata( mwp%rgh_Nrh ) .or. & - LDAS_is_nodata( mwp%rgh_Nrv ) .or. & - LDAS_is_nodata( mwp%rgh_polmix ) .or. & - LDAS_is_nodata( mwp%omega ) & - ) - - if ( other_params_nodata ) then - - ! make sure all related fields in this group are no-data if at least one is nodata - - mwp%vegcls = nint(nodata_generic) - mwp%soilcls = nint(nodata_generic) - mwp%sand = nodata_generic - mwp%clay = nodata_generic - mwp%poros = nodata_generic - mwp%wang_wt = nodata_generic - mwp%wang_wp = nodata_generic - mwp%rgh_hmin = nodata_generic - mwp%rgh_hmax = nodata_generic - mwp%rgh_wmin = nodata_generic - mwp%rgh_wmax = nodata_generic - mwp%rgh_Nrh = nodata_generic - mwp%rgh_Nrv = nodata_generic - mwp%rgh_polmix = nodata_generic - mwp%omega = nodata_generic - - end if - - ! ----------------------------------------------------------------------------- - - ! need both groups for full tau-omega calculations: - - if ( veg_params_nodata .or. other_params_nodata ) then - - mwp_nodata = .true. - - else - - mwp_nodata = .false. - - end if - - end subroutine mwRTM_param_nodata_check - -end module mwRTM_types - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -#if 0 - -! driver routines for testing - -program test_mwRTM_types - - use mwRTM_types - - implicit none - - type(mwRTM_param_type) :: mwRTM_param - - mwRTM_param = -9999. - - write (*,*) mwRTM_param - - mwRTM_param%lewt = 0.5 - - write (*,*) mwRTM_param - - call mwRTM_param_nodata_check(mwRTM_param) - - write (*,*) mwRTM_param - -end program test_mwRTM_types - -#endif - -! ========================== EOF ================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/CMakeLists.txt deleted file mode 100644 index 9930cab5..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/CMakeLists.txt +++ /dev/null @@ -1,16 +0,0 @@ -esma_set_this () - -set (SRCS - nr_ran2_gasdev.F90 nr_jacobi.F90 nr_fft.F90 - random_fields.F90 land_pert.F90 force_and_cat_progn_pert_types.F90 LDAS_PertRoutines.F90 - GEOS_LandPertGridComp.F90 - ) - -esma_add_library (${this} - SRCS ${SRCS} - DEPENDENCIES GEOS_LdasShared GEOSens_GridComp GEOSland_GridComp MAPL ${MKL_LIBRARIES} - INCLUDES ${INC_ESMF} ${MKL_INCLUDE_DIRS}) - -if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") - target_compile_definitions(${this} PRIVATE MKL_AVAILABLE) -endif () diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/GEOS_LandPertGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/GEOS_LandPertGridComp.F90 deleted file mode 100644 index 205ec695..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/GEOS_LandPertGridComp.F90 +++ /dev/null @@ -1,2933 +0,0 @@ -#include "MAPL_Generic.h" -!BOP -! !MODULE: GEOS_LandPertGridCompMod - Module to compute perturbations -module GEOS_LandPertGridCompMod - - ! !USES - - use ESMF - use ESMF_CFIOMod, only: ESMF_CFIOStrTemplate - use MAPL_Mod - use, intrinsic :: iso_c_binding, only: c_loc, c_f_pointer, c_ptr - use LDAS_PertTypes, only: pert_param_type - use LDAS_PertTypes, only: allocate_pert_param - use LDAS_PertTypes, only: T_LANDPERT_STATE - use LDAS_PertTypes, only: LANDPERT_WRAP - - use nr_ran2_gasdev, only: NRANDSEED, init_randseed - use LDAS_ConvertMod, only: esmf2ldas - use LDAS_ensdrv_Globals, only: nodata_generic, nodata_tol_generic, get_ensid_string - use LDAS_DriverTypes, only: met_force_type - use LDAS_DateTimeMod, only: date_time_type, date_time_print - use RepairForcingMod, only: repair_forcing - use LDAS_TileCoordType, only: grid_def_type - use LDAS_TileCoordType, only: tile_coord_type - use LDAS_TileCoordType, only: T_TILECOORD_STATE - use LDAS_TileCoordType, only: TILECOORD_WRAP - use land_pert_routines, only: get_pert, propagate_pert, clear_rf - use land_pert_routines, only: get_init_pert_rseed - use LDAS_PertRoutinesMod, only: apply_pert - use LDAS_PertRoutinesMod, only: get_force_pert_param - use LDAS_PertRoutinesMod, only: get_progn_pert_param - use LDAS_PertRoutinesMod, only: read_ens_prop_inputs - use LDAS_PertRoutinesMod, only: echo_pert_param - use LDAS_PertRoutinesMod, only: interpolate_pert_to_timestep - use LDAS_PertRoutinesMod, only: check_pert_dtstep - use LDAS_PertRoutinesMod, only: GEOSldas_FORCE_PERT_DTSTEP - use LDAS_PertRoutinesMod, only: GEOSldas_PROGN_PERT_DTSTEP - use LDAS_PertRoutinesMod, only: GEOSldas_NUM_ENSEMBLE - use LDAS_PertRoutinesMod, only: GEOSldas_FIRST_ENS_ID - use LDAS_TileCoordRoutines, only: grid2tile, tile2grid_simple, tile_mask_grid - use force_and_cat_progn_pert_types, only: N_FORCE_PERT_MAX - use force_and_cat_progn_pert_types, only: N_PROGN_PERT_MAX - - implicit none - - private - - ! !PUBLIC MEMBER FUNCTIONS: - - public :: SetServices - - ! !DESCRIPTION: - !EOP - - integer, parameter :: NUM_SUBTILES = 4 - ! the two global varaibles store the mean of pert. They are shared across ensemble - real,allocatable :: fpert_enavg(:,:,:) - real,allocatable :: ppert_enavg(:,:,:) - logical :: phase2_initialized - - integer, public :: N_force_pert, N_progn_pert - type(pert_param_type),dimension(:), pointer,public :: progn_pert_param =>null() - type(pert_param_type),dimension(:), pointer,public :: force_pert_param =>null() - - integer,dimension(:,:),pointer,public :: pert_iseed=>null() - integer :: lat1, lat2, lon1, lon2 - integer :: FIRST_ENS_ID - logical :: COLDSTART -contains - - !BOP - - ! !IROTUINE: SetServices -- Set ESMF services for this component - - ! !INTERFACE: - - subroutine SetServices(gc, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, optional :: rc ! return code - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: GridName - type(MAPL_MetaComp), pointer :: MAPL=>null() - ! Local variables - type(T_LANDPERT_STATE), pointer :: internal - type(LANDPERT_WRAP) :: wrap - integer :: ens_id - - ! Get my name and setup traceback handle - Iam = 'SetServices' - call ESMF_GridCompGet(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::" // Iam - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - VERIFY_(status) - ! -phase-1 : phase2_initilization - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Phase2_Initialize, & - rc=status & - ) - VERIFY_(status) - ! -phase-2 :generate ntrmdt without adjusting - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - GenerateRaw_ntrmdt, & - rc=status & - ) - VERIFY_(status) - ! -phase-3 : force-pert- - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - ApplyForcePert, & - rc=status & - ) - VERIFY_(status) - ! -phase-4 : progn-pert- - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - ApplyPrognPert, & - rc=status & - ) - VERIFY_(status) - ! -phase-5 : update rseed from assim - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Update_pert_rseed, & - rc=status & - ) - VERIFY_(status) - - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - VERIFY_(status) - - ! Allocate an instance of the internal state and put it in wrapper - ! Then, save the pointer to the wrapper internal state in the GridComp - allocate(internal, stat=status) - VERIFY_(status) - wrap%ptr => internal - internal%isCubedSphere = .false. - - call ESMF_UserCompSetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - call MAPL_GetResource ( MAPL, internal%NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - GEOSldas_NUM_ENSEMBLE = internal%NUM_ENSEMBLE - - call MAPL_GetResource ( MAPL, GridName, Label="GEOSldas.GRIDNAME:", DEFAULT="EASE", RC=STATUS) - VERIFY_(STATUS) - if (index(GridName,"-CF") /=0) internal%isCubedSphere = .true. - - call MAPL_GetResource(MAPL, GEOSldas_FIRST_ENS_ID, 'FIRST_ENS_ID:',DEFAULT=0, rc=status) - VERIFY_(status) - - FIRST_ENS_ID = GEOSldas_FIRST_ENS_ID - ens_id = FIRST_ENS_ID - if ( internal%NUM_ENSEMBLE > 1) then - !landpert_eXXXX - read(comp_name(11:),*) ens_id - endif - internal%ens_id= ens_id - - ! Set the state variable specs - !IMPORT STATE: - ! ForcePert - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Tair", & - LONG_NAME = "air_temperature_at_RefH", & - UNITS = "K", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Qair", & - LONG_NAME = "specific_humidity_at_RefH", & - UNITS = "kg kg-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Psurf", & - LONG_NAME = "surface_pressure", & - UNITS = "Pa", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Rainf_C", & - LONG_NAME = "convective_rainfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Rainf", & - LONG_NAME = "liquid_water_large_scale_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Snowf", & - LONG_NAME = "total_snowfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "LWdown", & - LONG_NAME = "downward_longwave_radiation", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "SWdown", & - LONG_NAME = "downward_shortwave_radiation", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "PARdrct", & - LONG_NAME = "photosynth_active_radiation_direct", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "PARdffs", & - LONG_NAME = "photosynth_active_radiation_diffuse", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "Wind", & - LONG_NAME = "wind_speed_at_RefH", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = "RefH", & - LONG_NAME = "reference_height_for_Tair_Qair_Wind", & - UNITS = "m", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - ! PrognPert, the connected to land's exports which are catchment's Internal - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'TCPert', & - LONG_NAME = 'canopy_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsTileTile, & - NUM_SUBTILES = NUM_SUBTILES, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'CATDEFPert', & - LONG_NAME = 'catchment_deficit', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'RZEXCPert', & - LONG_NAME = 'root_zone_excess', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'SRFEXCPert', & - LONG_NAME = 'surface_excess', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT1Pert', & - LONG_NAME = 'soil_heat_content_layer_1', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT2Pert', & - LONG_NAME = 'soil_heat_content_layer_2', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT3Pert', & - LONG_NAME = 'soil_heat_content_layer_3', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT4Pert', & - LONG_NAME = 'soil_heat_content_layer_4', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT5Pert', & - LONG_NAME = 'soil_heat_content_layer_5', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'GHTCNT6Pert', & - LONG_NAME = 'soil_heat_content_layer_6', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'WESNN1Pert', & - LONG_NAME = 'snow_mass_layer_1', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'WESNN2Pert', & - LONG_NAME = 'snow_mass_layer_2', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'WESNN3Pert', & - LONG_NAME = 'snow_mass_layer_3', & - UNITS = 'kg m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'HTSNNN1Pert', & - LONG_NAME = 'heat_content_snow_layer_1', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'HTSNNN2Pert', & - LONG_NAME = 'heat_content_snow_layer_2', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'HTSNNN3Pert', & - LONG_NAME = 'heat_content_snow_layer_3', & - UNITS = 'J m-2', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'SNDZN1Pert', & - LONG_NAME = 'snow_delth_layer_1', & - UNITS = 'm', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'SNDZN2Pert', & - LONG_NAME = 'snow_delth_layer_2', & - UNITS = 'm', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( & - gc, & - SHORT_NAME = 'SNDZN3Pert', & - LONG_NAME = 'snow_delth_layer_3', & - UNITS = 'm', & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VLocationNone, & - rc = status & - ) - VERIFY_(STATUS) - - ! !EXPORT STATE: - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "TApert", & - LONG_NAME = "perturbed_surface_air_temperature", & - UNITS = "K", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "QApert", & - LONG_NAME = "perturbed_surface_air_specific_humidity", & - UNITS = "kg kg-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PSpert", & - LONG_NAME = "Perturbed_surface_pressure", & - UNITS = "Pa", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "UUpert", & - LONG_NAME = "perturbed_surface_wind_speed", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "UWINDLMTILEpert", & - LONG_NAME = "perturbed_levellm_uwind", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "VWINDLMTILEpert", & - LONG_NAME = "perturbed_levellm_vwind", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PCUpert", & - LONG_NAME = "perturbed_liquid_water_convective_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PLSpert", & - LONG_NAME = "perturbed_liquid_water_large_scale_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "SNOpert", & - LONG_NAME = "perturbed_snowfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRPARpert", & - LONG_NAME = "surface_downwelling_par_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFPARpert", & - LONG_NAME = "surface_downwelling_par_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRNIRpert", & - LONG_NAME = "surface_downwelling_nir_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFNIRpert", & - LONG_NAME = "surface_downwelling_nir_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DRUVRpert", & - LONG_NAME = "surface_downwelling_uvr_beam_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DFUVRpert", & - LONG_NAME = "surface_downwelling_uvr_diffuse_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "LWDNSRFpert", & - LONG_NAME = "perturbed_surface_downwelling_longwave_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "DZpert", & - LONG_NAME = "reference_height_for_Tair_Qair_Wind", & - UNITS = "m", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - ! !INTERNAL STATE: - if ( .not. internal%isCubedSphere ) then - - call MAPL_AddInternalSpec( & - gc, & - SHORT_NAME = "pert_rseed", & - LONG_NAME = "Perturbations_rseed", & - UNITS = "1", & - PRECISION = ESMF_KIND_R8, & - FRIENDLYTO = trim(COMP_NAME), & - DIMS = MAPL_DimsNone, & - UNGRIDDED_DIMS = (/NRANDSEED/), & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddInternalSpec( & - gc, & - SHORT_NAME = "fpert_ntrmdt", & - LONG_NAME = "force_pert_intermediate", & - UNITS = "1", & - DIMS = MAPL_DimsHorzOnly, & - UNGRIDDED_DIMS = (/N_FORCE_PERT_MAX/), & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddInternalSpec( & - gc, & - SHORT_NAME = "ppert_ntrmdt", & - LONG_NAME = "progn_pert_intermediate", & - UNITS = "1", & - DIMS = MAPL_DimsHorzOnly, & - UNGRIDDED_DIMS = (/N_PROGN_PERT_MAX/), & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - endif - - !EOS - - ! Set profiling timers - call MAPL_TimerAdd(gc, name="Initialize", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="phase2_Initialize", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="GenerateRaw", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Run_ApplyForcePert", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="-GetPert", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="-ApplyPert", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="-MetForcing2Catch", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="-LocStreamTransform", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Run_ApplyPrognPert", rc=status) - VERIFY_(status) - - ! Call SetServices for children - call MAPL_GenericSetServices(gc, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - - !BOP - - ! !IROUTINE: Initialize -- initialize method for LDAS GC - - ! !INTERFACE: - - subroutine Initialize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: rst_fname, rst_fname_tmp - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_TimeInterval) :: ModelTimeStep - type(ESMF_Time) :: CurrentTime, StopTime - type(ESMF_Alarm) :: ForcePertAlarm, PrognPertAlarm - type(ESMF_TimeInterval) :: ForcePert_DT, PrognPert_DT - type(ESMF_State) :: MINTERNAL - - ! LDAS variables - type(date_time_type) :: stop_time, current_time - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - character(len=300) :: out_path - character(len=ESMF_MAXSTR) :: exp_id - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - type(tile_coord_type), pointer :: tile_coord(:)=>null() - - ! MAPL internal pointers - real, pointer :: pert_ptr(:)=>null() - real, pointer :: fpert_ntrmdt(:,:,:)=>null() - real, pointer :: ppert_ntrmdt(:,:,:)=>null() - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! Misc variables - integer :: model_dtstep - integer :: land_nt_local, m, n, i1, in, j1, jn - logical :: IAmRoot, f_exist - integer :: n_lon, n_lat, n_lon_g, n_lat_g - integer, allocatable :: pert_rseed(:) - type(ESMF_Grid) :: Grid - character(len=ESMF_MAXSTR) :: id_string - integer :: ens_id_width - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Initialize" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - call MAPL_TimerOn(MAPL, "TOTAL") - - call MAPL_TimerOn(MAPL, "Initialize") - - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! Get pointer to the private internal state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - tile_coord => tcinternal%tile_coord - - ! Are we perturbing variables? - call MAPL_GetResource(MAPL, internal%PERTURBATIONS, 'PERTURBATIONS:', default=0, rc=status) - VERIFY_(status) - - if (internal%PERTURBATIONS == 0) then ! no perturbations - allocate(progn_pert_param(0)) - allocate(force_pert_param(0)) - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - RETURN_(ESMF_SUCCESS) - end if - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - - - call MAPL_GetResource ( MAPL, out_path, Label="OUT_PATH:", DEFAULT="./", RC=STATUS) - call MAPL_GetResource ( MAPL, exp_id, Label="EXP_ID:", DEFAULT="NO_ID", RC=STATUS) - - call MAPL_GetResource(MAPL, internal%ForcePert%dtstep, 'FORCE_PERT_DTSTEP:',DEFAULT=10800, rc=status) - VERIFY_(status) - call ESMF_TimeIntervalSet(ForcePert_DT, s=internal%ForcePert%dtstep, rc=status) - VERIFY_(status) - ! -PrognPert- - call MAPL_GetResource(MAPL, internal%PrognPert%dtstep, 'PROGN_PERT_DTSTEP:',DEFAULT=10800, rc=status) - VERIFY_(status) - call ESMF_TimeIntervalSet(PrognPert_DT, s=internal%PrognPert%dtstep, rc=status) - VERIFY_(status) - - - - GEOSldas_FORCE_PERT_DTSTEP = internal%ForcePert%dtstep - GEOSldas_PROGN_PERT_DTSTEP = internal%PrognPert%dtstep - - n_lon = tcinternal%pgrid_l%n_lon - n_lat = tcinternal%pgrid_l%n_lat - - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=4, RC=STATUS) - VERIFY_(status) - - ! Pointers to mapl internals - if ( internal%isCubedSphere ) then - n_lon_g = tcinternal%pgrid_g%n_lon - n_lat_g = tcinternal%pgrid_g%n_lat - allocate(internal%fpert_ntrmdt(n_lon_g, n_lat_g, N_FORCE_PERT_MAX), source=0.0) - allocate(internal%ppert_ntrmdt(n_lon_g, n_lat_g, N_PROGN_PERT_MAX), source=0.0) - allocate(internal%pert_rseed_r8(NRANDSEED), source=0.0d0) - - fpert_ntrmdt => internal%fpert_ntrmdt - ppert_ntrmdt => internal%ppert_ntrmdt - pert_rseed_r8 => internal%pert_rseed_r8 - - call MAPL_GetResource(MAPL, rst_fname_tmp, 'LANDPERT_INTERNAL_RESTART_FILE:',DEFAULT='NONE', rc=status) - VERIFY_(status) - - call get_ensid_string(id_string,internal%ens_id, ens_id_width, internal%NUM_ENSEMBLE) - - call ESMF_CFIOStrTemplate(rst_fname, trim(adjustl(rst_fname_tmp)),'GRADS', xid = trim(id_string), stat=status) - - if (index(rst_fname, 'NONE') == 0 ) then - f_exist = .false. - if ( IAmRoot) then - inquire(file=rst_fname, exist=f_exist) - if (f_exist) call read_pert_rst(trim(rst_fname), fpert_ntrmdt, ppert_ntrmdt, pert_rseed_r8) - endif - call MAPL_CommsBcast(vm, data=f_exist, N=1, ROOT=0,rc=status) - if (f_exist) then - n = n_lat_g*n_lon_g*N_FORCE_PERT_MAX - - block - type(c_ptr) :: cptr - cptr = c_loc(fpert_ntrmdt(1,1,1)) - call c_f_pointer(cptr, pert_ptr, [n]) - end block - - call MAPL_CommsBcast(vm, data=pert_ptr, N=n, ROOT=0,rc=status) - VERIFY_(status) - pert_ptr=>null() - - n = n_lat_g*n_lon_g*N_PROGN_PERT_MAX - block - type(c_ptr) :: cptr - cptr = c_loc(ppert_ntrmdt(1,1,1)) - call c_f_pointer(cptr, pert_ptr, [n]) - end block - call MAPL_CommsBcast(vm, data=pert_ptr, N=n, ROOT=0,rc=status) - VERIFY_(status) - pert_ptr=>null() - - call MAPL_CommsBcast(vm, data=pert_rseed_r8, N=NRANDSEED, ROOT=0,rc=status) - VERIFY_(status) - endif - endif - lon1 = tcinternal%pgrid_l%i_offg + 1 - lon2 = tcinternal%pgrid_l%i_offg + n_lon - lat1 = tcinternal%pgrid_l%j_offg + 1 - lat2 = tcinternal%pgrid_l%j_offg + n_lat - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, fpert_ntrmdt, 'fpert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, ppert_ntrmdt, 'ppert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - ! Get grid info from the gridcomp - call ESMF_GridCompGet(gc, grid=Grid, rc=status) - VERIFY_(status) - call ESMF_GRID_INTERIOR (GRID, I1,IN,J1,JN) - - lon1 = tcinternal%pgrid_l%i_offg + 1 ! global index, starting from 1 - lon1 = lon1 - i1 + 1 ! relative to local - lon2 = lon1 + n_lon - 1 - lat1 = tcinternal%pgrid_l%j_offg + 1 ! global index, starting from 1 - lat1 = lat1 - j1 +1 ! relative to local - lat2 = lat1 + n_lat - 1 - endif - - ! Convert pert_rseed_r8 to integer - allocate(pert_rseed(size(pert_rseed_r8)), source=0, stat=status) - VERIFY_(status) - pert_rseed = nint(pert_rseed_r8) - if( .not. associated(pert_iseed)) then - allocate(pert_iseed(size(pert_rseed_r8),internal%NUM_ENSEMBLE), source=0, stat=status) - endif - VERIFY_(status) - ! Check if we need to coldstart - - ! If the MAPL internal state variables are zero, a restart file was - ! not available to read - in that case we cold-start - COLDSTART = .false. - if (all(pert_rseed==0)) COLDSTART = .true. - - ! Get number of land tiles - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - - allocate(internal%i_indgs(land_nt_local),stat=status) - VERIFY_(status) - allocate(internal%j_indgs(land_nt_local),stat=status) - VERIFY_(status) - internal%i_indgs(:)=tile_coord(:)%pert_i_indg - internal%j_indgs(:)=tile_coord(:)%pert_j_indg - - ! Get pert options from *default* namelist files - ! WARNING: get_force/progn_pert_param() calls allocate memory - - call get_force_pert_param(tcinternal%pgrid_l, internal%ForcePert%npert, internal%ForcePert%param) - _ASSERT(internal%ForcePert%npert==size(internal%ForcePert%param), "ForcePert: param size does not match npert") - - internal%ForcePert%fft_npert = internal%ForcePert%npert - call MAPL_CommsBcast(vm, data=internal%ForcePert%fft_npert, N=1, ROOT=0,rc=status) - if (size(internal%ForcePert%param) == 0 .and. internal%ForcePert%fft_npert >0 ) then - allocate(internal%ForcePert%param(internal%ForcePert%fft_npert)) - endif - do n = 1, internal%ForcePert%fft_npert - call MAPL_CommsBcast(vm, data=internal%ForcePert%param(n)%xcorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%ForcePert%param(n)%ycorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%ForcePert%param(n)%tcorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%ForcePert%param(n)%coarsen, N=1, ROOT=0,rc=status) - enddo - - call get_progn_pert_param(tcinternal%pgrid_l, internal%PrognPert%npert, internal%PrognPert%param) - _ASSERT(internal%PrognPert%npert==size(internal%PrognPert%param), "PrognPert: param size does not match npert") - - internal%PrognPert%fft_npert = internal%PrognPert%npert - call MAPL_CommsBcast(vm, data=internal%PrognPert%fft_npert, N=1, ROOT=0,rc=status) - if (size(internal%PrognPert%param) == 0 .and. internal%PrognPert%fft_npert > 0) then - allocate(internal%PrognPert%param(internal%PrognPert%fft_npert)) - endif - - do n = 1, internal%PrognPert%fft_npert - call MAPL_CommsBcast(vm, data=internal%PrognPert%param(n)%xcorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%PrognPert%param(n)%ycorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%PrognPert%param(n)%tcorr, N=1, ROOT=0,rc=status) - call MAPL_CommsBcast(vm, data=internal%PrognPert%param(n)%coarsen, N=1, ROOT=0,rc=status) - enddo - - N_force_pert = internal%ForcePert%npert - N_progn_pert = internal%PrognPert%npert - - ! params are the same across ensemble - if (.not. associated (progn_pert_param)) then - progn_pert_param=>internal%PrognPert%param - endif - - if (.not. associated (force_pert_param)) then - force_pert_param=>internal%ForcePert%param - endif - - !allocate(internal%fpert_ntrmdt(n_lon,n_lat,internal%ForcePert%npert), source=0., stat=status) - !VERIFY_(status) - !allocate(internal%ppert_ntrmdt(n_lon,n_lat,internal%PrognPert%npert), source=0., stat=status) - !VERIFY_(status) - - !fpert_ntrmdt=>internal%fpert_ntrmdt - !ppert_ntrmdt=>internal%ppert_ntrmdt - - ! allocate the global vaiable - if( .not. allocated(fpert_enavg) ) then - allocate(fpert_enavg(n_lon,n_lat,internal%ForcePert%npert), source=0., stat=status) - VERIFY_(status) - endif - if( .not. allocated(ppert_enavg) ) then - allocate(ppert_enavg(n_lon,n_lat,internal%PrognPert%npert), source=0., stat=status) - VERIFY_(status) - endif - - if (IAmRoot .and. internal%ens_id == FIRST_ENS_ID) then - call echo_pert_param( internal%ForcePert%npert, internal%ForcePert%param, 1, 1 ) - call echo_pert_param( internal%PrognPert%npert, internal%PrognPert%param, 1, 1 ) - endif - - ! Allocate and initialize memory for pvt internal state variables - allocate(internal%ForcePert%DataPrv(land_nt_local, internal%ForcePert%npert), stat=status) - VERIFY_(status) - allocate(internal%ForcePert%DataNxt(land_nt_local, internal%ForcePert%npert), stat=status) - VERIFY_(status) - allocate(internal%PrognPert%DataPrv(land_nt_local, internal%PrognPert%npert), stat=status) - VERIFY_(status) - allocate(internal%PrognPert%DataNxt(land_nt_local, internal%PrognPert%npert), stat=status) - VERIFY_(status) - internal%ForcePert%DataPrv = MAPL_UNDEF - internal%ForcePert%DataNxt = MAPL_UNDEF - internal%PrognPert%DataPrv = MAPL_UNDEF - internal%PrognPert%DataNxt = MAPL_UNDEF - - ! Coldstart - if (COLDSTART) then - if (IAmRoot) print *, trim(Iam)//'::WARNING: Cold-starting '// trim(COMP_NAME) // ' GridComp' - ! -pert_rseed- - call get_init_pert_rseed(internal%ens_id, pert_rseed(1)) - call init_randseed(pert_rseed) - ! -ForcePert- - call propagate_pert( & - internal%ForcePert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - ! arbitrary dtstep - -1.0, & - pert_rseed, & - internal%ForcePert%param, & - fpert_ntrmdt(lon1:lon2,lat1:lat2, & - 1:internal%ForcePert%npert), & - ! initialize - .true. & - ) - - ! -prognostics- - call propagate_pert( & - internal%PrognPert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - ! arbitrary dtstep - -1.0, & - pert_rseed, & - internal%PrognPert%param, & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert), & - ! initialize - .true. & - ) - - - end if - - if(internal%ens_id == FIRST_ENS_ID ) fpert_enavg(:,:,:)=0. - - do m = 1,internal%ForcePert%npert - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), fpert_ntrmdt(lon1:lon2,lat1:lat2,m)) - if(internal%ForcePert%param(m)%zeromean .and. internal%NUM_ENSEMBLE >2) then - fpert_enavg(:,:,m)=fpert_enavg(:,:,m)+fpert_ntrmdt(lon1:lon2,lat1:lat2,m) - if( internal%ens_id-FIRST_ENS_ID == internal%NUM_ENSEMBLE-1) then - fpert_enavg(:,:,m) = -fpert_enavg(:,:,m)/real(internal%NUM_ENSEMBLE) - endif - endif - enddo - - if(internal%ens_id == FIRST_ENS_ID) ppert_enavg(:,:,:)=0. - - do m = 1,internal%PrognPert%npert - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_ntrmdt(lon1:lon2,lat1:lat2,m)) - if(internal%PrognPert%param(m)%zeromean .and. internal%NUM_ENSEMBLE >2) then - ppert_enavg(:,:,m)=ppert_enavg(:,:,m)+ppert_ntrmdt(lon1:lon2,lat1:lat2,m) - if( internal%ens_id - FIRST_ENS_ID == internal%NUM_ENSEMBLE-1) then - ppert_enavg(:,:,m) = -ppert_enavg(:,:,m)/real(internal%NUM_ENSEMBLE) - endif - endif - enddo - - ! Check force/progn pert dtsteps against model dtstep - ! -Get-model-times- - call ESMF_ClockGet( & - clock, & - currTime=CurrentTime, & - timeStep=ModelTimeStep, & - stopTime=StopTime & - ) - VERIFY_(status) - ! -model-dtstep-in-seconds- - call ESMF_TimeIntervalGet(ModelTimeStep, s=model_dtstep) - VERIFY_(status) - ! -model-times-in-LDAS-datetime-format- - call esmf2ldas(StopTime, stop_time, rc=status) - VERIFY_(status) - call esmf2ldas(CurrentTime, current_time, rc=status) - VERIFY_(status) - - if( internal%ens_id == FIRST_ENS_ID .and. IAmRoot) then - ! write out the input file - call read_ens_prop_inputs(write_nml = .true. , work_path = trim(out_path), & - exp_id = trim(exp_id), date_time = current_time) - endif - - - ! -Now-check-pert-dtstep- - call check_pert_dtstep( & - model_dtstep, & - current_time, stop_time, & - internal%PrognPert%npert, internal%ForcePert%npert, & - internal%PrognPert%dtstep, internal%ForcePert%dtstep & - ) - - ! Create (non-sticky) alarms for force and progn perturbations - ! -ForcePert- - ForcePertAlarm = ESMF_AlarmCreate( & - clock, & - name='ForcePert', & - ringTime=CurrentTime, & - ringInterval=ForcePert_DT, & - ringTimeStepCount=1, & - sticky=.false., & - rc=status & - ) - VERIFY_(status) - ! -PrognPert- - PrognPertAlarm = ESMF_AlarmCreate( & - clock, & - name='PrognPert', & - ringTime=CurrentTime, & - ringInterval=PrognPert_DT, & - ringTimeStepCount=1, & - sticky=.false., & - rc=status & - ) - VERIFY_(status) - - ! Perturbation times - ! -force- - internal%ForcePert%TimePrv = CurrentTime - internal%ForcePert%TimeNxt = CurrentTime - ! -progn- - internal%PrognPert%TimePrv = CurrentTime - internal%PrognPert%TimeNxt = CurrentTime - - ! Update the r4 version of pert_rseed - pert_rseed_r8 = real(pert_rseed,kind=ESMF_KIND_R8) - pert_iseed(:,internal%ens_id + 1 - FIRST_ENS_ID ) = pert_rseed - ! Clean up - - if (allocated(pert_rseed)) then ! integer version of MINTERNAL state - deallocate(pert_rseed, stat=status) - VERIFY_(status) - end if - - Phase2_initialized = .false. - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Initialize - - - subroutine Phase2_Initialize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_State) :: MINTERNAL - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - type(tile_coord_type), pointer :: tile_coord(:)=>null() - - ! MAPL internal pointers - real, pointer :: fpert_ntrmdt(:,:,:)=>null() - real, pointer :: ppert_ntrmdt(:,:,:)=>null() - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! Misc variables - real, allocatable :: fpert_grid(:,:,:), ppert_grid(:,:,:) - integer,allocatable :: pert_rseed(:) - - integer :: land_nt_local,ipert,n_lon,n_lat - logical :: IAmRoot - - ! Begin... - ! phase2_initialized is a global variables shared by all ensemble member - if( phase2_initialized) then - RETURN_(ESMF_SUCCESS) - endif - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::phase2_Initialize" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - call MAPL_TimerOn(MAPL, "TOTAL") - - call MAPL_TimerOn(MAPL, "phase2_Initialize") - - ! Get pointer to the private internal state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - tile_coord => tcinternal%tile_coord - n_lon = tcinternal%pgrid_l%n_lon - n_lat = tcinternal%pgrid_l%n_lat - - if (internal%PERTURBATIONS == 0) then ! no perturbations - call MAPL_TimerOff(MAPL, "phase2_Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - RETURN_(ESMF_SUCCESS) - end if - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - - !if (IAmRoot) print *, trim(Iam)//':: run' - - ! Get number of land tiles - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - ! Pointers to mapl internals - if( internal%isCubedSphere) then - fpert_ntrmdt => internal%fpert_ntrmdt - ppert_ntrmdt => internal%ppert_ntrmdt - pert_rseed_r8 => internal%pert_rseed_r8 - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, fpert_ntrmdt, 'fpert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, ppert_ntrmdt, 'ppert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - endif - - - ! Convert pert_rseed_r8 to integer - allocate(pert_rseed(size(pert_rseed_r8)), source=0, stat=status) - VERIFY_(status) - pert_rseed = nint(pert_rseed_r8) - - ! Allocate perturbation arrays on grid - allocate(fpert_grid(n_lon,n_lat, internal%ForcePert%npert), source=MAPL_UNDEF, stat=status) - VERIFY_(status) - allocate(ppert_grid(n_lon,n_lat, internal%PrognPert%npert), source=MAPL_UNDEF, stat=status) - VERIFY_(status) - - ! Get pertubations on the underlying grid and convert grid data to tile data - ! - ! -ForcePert- - ! - ! adjust mean after cold start (if fpert_ntrmdt is from restart file, - ! mean was adjusted in ApplyForcePert before restart was written) - if (COLDSTART) & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert) = & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert) + & - fpert_enavg(:,:,:) - - call get_pert( & - internal%ForcePert%npert, & - internal%ForcePert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%ForcePert%dtstep), & - internal%ForcePert%param, & - pert_rseed, & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert), & - fpert_grid, & - initialize_rseed=.false., & - initialize_ntrmdt=.false., & - ! propagate_pert is NOT called - diagnose_pert_only=.true. & - ) - - do ipert=1,internal%ForcePert%npert - call grid2tile( tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), & - fpert_grid(:,:,ipert), internal%ForcePert%DataPrv(:,ipert)) - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), fpert_ntrmdt(lon1:lon2,lat1:lat2,ipert)) - end do - internal%ForcePert%DataNxt = internal%ForcePert%DataPrv - - ! -PrognPert- - ! - ! adjust mean after cold start (if ppert_ntrmdt is from restart file, - ! mean was adjusted in ApplyPrognPert before restart was written) - if (COLDSTART) & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert) = & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert) + & - ppert_enavg(:,:,:) - - call get_pert( & - internal%PrognPert%npert, & - internal%PrognPert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%PrognPert%dtstep), & - internal%PrognPert%param, & - pert_rseed, & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert), & - ppert_grid, & - initialize_rseed=.false., & - initialize_ntrmdt=.false., & - ! propagate_pert is NOT called - diagnose_pert_only=.true. & - ) - - do ipert=1,internal%PrognPert%npert - call grid2tile( tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_grid(:,:,ipert), & - internal%PrognPert%DataPrv(:,ipert)) - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_ntrmdt(lon1:lon2,lat1:lat2,ipert)) - end do - internal%PrognPert%DataNxt = internal%PrognPert%DataPrv - - ! Update the r8 version of pert_rseed - pert_rseed_r8 = real(pert_rseed,kind=ESMF_kind_r8) - pert_iseed(:,internal%ens_id+1-FIRST_ENS_ID) = pert_rseed - - ! Clean up - if (allocated(fpert_grid)) then - deallocate(fpert_grid, stat=status) - VERIFY_(status) - end if - if (allocated(ppert_grid)) then - deallocate(ppert_grid, stat=status) - VERIFY_(status) - end if - if (allocated(pert_rseed)) then ! integer version of MINTERNAL state - deallocate(pert_rseed, stat=status) - VERIFY_(status) - end if - - ! Turn timers off - call MAPL_TimerOff(MAPL, "phase2_Initialize") - call MAPL_TimerOff(MAPL, "TOTAL") - - if(internal%ens_id - FIRST_ENS_ID == internal%NUM_ENSEMBLE -1) phase2_initialized = .true. - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Phase2_Initialize - - subroutine GenerateRaw_ntrmdt(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: chk_fname - character(len=ESMF_MAXSTR) :: id_string - character(len=14) :: datestamp - - ! ESMF variables - type(ESMF_Alarm) :: ForcePertAlarm, PrognPertAlarm - type(ESMF_State) :: MINTERNAL - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - type(MAPL_LocStream) :: locstream - - ! MAPL internal pointers - real, pointer :: fpert_ntrmdt(:,:,:)=>null() - real, pointer :: ppert_ntrmdt(:,:,:)=>null() - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! Misc variables - type(ESMF_VM) :: vm - logical :: IAmRoot - integer, allocatable :: pert_rseed(:) - integer :: m,n_lon,n_lat, land_nt_local, ens_id_width - - integer :: nfpert, nppert, n_tile - type(tile_coord_type), pointer :: tile_coord_f(:)=>null() - type (ESMF_Grid) :: tilegrid - integer, pointer :: mask(:) - real, allocatable, dimension(:,:) :: tile_data_f, tile_data_p, tile_data_f_all, tile_data_p_all - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // ":: GenerateRaw_ntrmdt" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - call MAPL_TimerOn(MAPL, "GenerateRaw") - ! Get pointer to the private internal state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - if (internal%PERTURBATIONS == 0) then ! no perturbations - call MAPL_TimerOff(MAPL, "GenerateRaw") - RETURN_(ESMF_SUCCESS) - end if - - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - - n_lon=tcinternal%pgrid_l%n_lon - n_lat=tcinternal%pgrid_l%n_lat - - ! Get locstream - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - - ! Get number of land tiles - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - ! Get alarm - call ESMF_ClockGetAlarm(clock, 'ForcePert', ForcePertAlarm, rc=status) - VERIFY_(status) - call ESMF_ClockGetAlarm(clock, 'PrognPert', PrognPertAlarm, rc=status) - VERIFY_(status) - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=4, RC=STATUS) - VERIFY_(status) - ! Pointers to mapl internals - - if( internal%isCubedSphere) then - fpert_ntrmdt => internal%fpert_ntrmdt - ppert_ntrmdt => internal%ppert_ntrmdt - pert_rseed_r8 => internal%pert_rseed_r8 - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, fpert_ntrmdt, 'fpert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, ppert_ntrmdt, 'ppert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - endif - ! Convert pert_rseed_r8 to integer - allocate(pert_rseed(size(pert_rseed_r8)), source=0, stat=status) - VERIFY_(status) - pert_rseed = nint(pert_rseed_r8) - - - if (MAPL_RecordAlarmIsRinging(MAPL, rc=status) .and. internal%isCubedSphere) then - - call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) - VERIFY_(STATUS) - call MAPL_TileMaskGet(tilegrid, mask, rc=status) - VERIFY_(STATUS) - - nfpert = internal%ForcePert%npert - nppert = internal%PrognPert%npert - tile_coord_f => tcinternal%tile_coord_f - n_tile = size(tile_coord_f,1) - ! 1) grid2tile - allocate(tile_data_f(land_nt_local,nfpert)) - allocate(tile_data_p(land_nt_local,nppert)) - do m = 1, nfpert - call grid2tile(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), & - fpert_ntrmdt(lon1:lon2,lat1:lat2,m), tile_data_f(:,m)) - enddo - do m = 1, nppert - call grid2tile(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), & - ppert_ntrmdt(lon1:lon2,lat1:lat2,m), tile_data_p(:,m)) - enddo - ! 2) gather tiledata - if (IAmRoot) then - allocate(tile_data_f_all(n_tile,nfpert), stat=status) - VERIFY_(STATUS) - allocate(tile_data_p_all(n_tile,nppert), stat=status) - VERIFY_(STATUS) - else - allocate(tile_data_f_all(0,nfpert), stat=status) - VERIFY_(STATUS) - allocate(tile_data_p_all(0,nppert), stat=status) - VERIFY_(STATUS) - end if - - do m = 1, nfpert - call ArrayGather(tile_data_f(:,m), tile_data_f_all(:,m), tilegrid, mask=mask, rc=status) - VERIFY_(STATUS) - enddo - do m = 1, nppert - call ArrayGather(tile_data_p(:,m), tile_data_p_all(:,m), tilegrid, mask=mask, rc=status) - VERIFY_(STATUS) - enddo - if (IamRoot) then - ! 3) tile2grid. simple reverser of grid2tile without weighted averaging/no-data-handling - do m = 1, nfpert - call tile2grid_simple( N_tile, tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, tcinternal%pgrid_g, tile_data_f_all(:,m), internal%fpert_ntrmdt(:,:,m)) - enddo - do m = 1, nppert - call tile2grid_simple( N_tile, tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, tcinternal%pgrid_g, tile_data_p_all(:,m), internal%ppert_ntrmdt(:,:,m)) - enddo - - ! 4) writing - call MAPL_DateStampGet(clock, datestamp, rc=status) - VERIFY_(STATUS) - - call get_ensid_string(id_string,internal%ens_id, ens_id_width, internal%NUM_ENSEMBLE) - - chk_fname = 'landpert'//trim(id_string)//'_internal_checkpoint.'//datestamp//'.nc4' - - call write_pert_checkpoint(trim(chk_fname),internal%fpert_ntrmdt, internal%ppert_ntrmdt, internal%pert_rseed_r8) - endif - deallocate(tile_data_f, tile_data_p, tile_data_f_all, tile_data_p_all) - endif - - if (ESMF_AlarmIsRinging(ForcePertAlarm)) then - - ! -ForcePert- - call propagate_pert( & - internal%ForcePert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%ForcePert%dtstep), & - pert_rseed, & - internal%ForcePert%param, & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert), & - .false. & - ) - - if(internal%ens_id == FIRST_ENS_ID ) fpert_enavg(:,:,:)=0. - - do m = 1,internal%ForcePert%npert - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), fpert_ntrmdt(lon1:lon2,lat1:lat2,m)) - if(internal%ForcePert%param(m)%zeromean .and. internal%NUM_ENSEMBLE >2) then - fpert_enavg(:,:,m)=fpert_enavg(:,:,m)+fpert_ntrmdt(lon1:lon2,lat1:lat2,m) - if( internal%ens_id - FIRST_ENS_ID == internal%NUM_ENSEMBLE-1) then - fpert_enavg(:,:,m) = -fpert_enavg(:,:,m)/real(internal%NUM_ENSEMBLE) - endif - endif - enddo - - endif - - if (ESMF_AlarmIsRinging(PrognPertAlarm)) then - - ! -prognostics- - call propagate_pert( & - internal%PrognPert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%PrognPert%dtstep), & - pert_rseed, & - internal%PrognPert%param, & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert), & - .false. & - ) - - if(internal%ens_id == FIRST_ENS_ID) ppert_enavg(:,:,:)=0. - - do m = 1,internal%PrognPert%npert - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_ntrmdt(lon1:lon2,lat1:lat2,m)) - if(internal%PrognPert%param(m)%zeromean .and. internal%NUM_ENSEMBLE >2) then - ppert_enavg(:,:,m)=ppert_enavg(:,:,m)+ppert_ntrmdt(lon1:lon2,lat1:lat2,m) - if( internal%ens_id - FIRST_ENS_ID == internal%NUM_ENSEMBLE -1) then - ppert_enavg(:,:,m) = -ppert_enavg(:,:,m)/real(internal%NUM_ENSEMBLE) - endif - endif - enddo - - - endif - ! Update the r4 version of pert_rseed - pert_rseed_r8 = real(pert_rseed,kind=ESMF_KIND_R8) - pert_iseed(:,internal%ens_id+1 - FIRST_ENS_ID) = pert_rseed - - call MAPL_TimerOff(MAPL, "GenerateRaw") - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine GenerateRaw_ntrmdt - - ! IROTUINE: ApplyForcePert -- Compute and apply perts to MetForcing vars - - ! INTERFACE: - - subroutine ApplyForcePert(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Compute and apply perturbations to Prognostic variables - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_Alarm) :: ForcePertAlarm - type(ESMF_State) :: MINTERNAL - type(ESMF_Time) :: ModelTimeCur, ModelTimeNxt, tmpTime - type(ESMF_TimeInterval) :: ModelTimeStep, ntrvl - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - - ! MAPL internal pointers - real, pointer :: fpert_ntrmdt(:,:,:)=>null() - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! LDAS variables - type(date_time_type) :: model_time_nxt - type(date_time_type) :: fpert_time_prv - - ! Pointers to imports - real, pointer :: Tair(:)=>null() - real, pointer :: Qair(:)=>null() - real, pointer :: Psurf(:)=>null() - real, pointer :: Rainf_C(:)=>null() - real, pointer :: Rainf(:)=>null() - real, pointer :: Snowf(:)=>null() - real, pointer :: LWdown(:)=>null() - real, pointer :: SWdown(:)=>null() - real, pointer :: PARdrct(:)=>null() - real, pointer :: PARdffs(:)=>null() - real, pointer :: Wind(:)=>null() - real, pointer :: RefH(:)=>null() - - ! Perturbed variables - type(met_force_type), allocatable :: mfPert(:) - - ! Pointers to exports - real, pointer :: TApert(:)=>null() - real, pointer :: QApert(:)=>null() - real, pointer :: PSpert(:)=>null() - real, pointer :: UUpert(:)=>null() - real, pointer :: UWINDLMTILEpert(:)=>null() - real, pointer :: VWINDLMTILEpert(:)=>null() - real, pointer :: PCUpert(:)=>null() - real, pointer :: PLSpert(:)=>null() - real, pointer :: SNOpert(:)=>null() - real, pointer :: DRPARpert(:)=>null() - real, pointer :: DFPARpert(:)=>null() - real, pointer :: DRNIRpert(:)=>null() - real, pointer :: DFNIRpert(:)=>null() - real, pointer :: DRUVRpert(:)=>null() - real, pointer :: DFUVRpert(:)=>null() - real, pointer :: LWDNSRFpert(:)=>null() - real, pointer :: DZpert(:)=>null() - - ! Misc variables - real, allocatable :: FORCEPERT(:,:) - real, allocatable :: fpert_grid(:,:,:) - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - type(tile_coord_type), pointer :: tile_coord(:)=>null() - - integer :: n_lon,n_lat - integer :: ipert - integer, allocatable :: pert_rseed(:) - logical :: IAmRoot - integer :: land_nt_local - type(pert_param_type), pointer :: PertParam=>null() ! pert param - real, allocatable :: tmpreal(:) - - ! Begin... - - ! Get my name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run_ApplyForcePert" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Run_ApplyForcePert") - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - - ! Get component's internal private state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - n_lon = tcinternal%pgrid_l%n_lon - n_lat = tcinternal%pgrid_l%n_lat - tile_coord => tcinternal%tile_coord - - ! Get locstream - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - - ! Get number of land tiles - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - ! TODO: this is really, really kludgy and needs to be cleaned - if (internal%PERTURBATIONS /=0 ) then - - ! Compute FORCEPERT - - ! Get current time - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - VERIFY_(status) - - ! Compute time stamp of Next model step - convert to LDAS datetime - call ESMF_ClockGet(clock, timeStep=ModelTimeStep, rc=status) - VERIFY_(status) - ModelTimeNxt = ModelTimeCur + ModelTimeStep - call esmf2ldas(ModelTimeNxt, model_time_nxt, rc=status) - VERIFY_(status) - - !if(IamRoot) print *, trim(Iam)//'::model_time_nxt: ', date_time_print(model_time_nxt) - - ! Pointers to mapl internals - if( internal%isCubedSphere) then - fpert_ntrmdt => internal%fpert_ntrmdt - pert_rseed_r8 => internal%pert_rseed_r8 - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, fpert_ntrmdt, 'fpert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - endif - - ! Convert pert_rseed_r8 to integer - allocate(pert_rseed(size(pert_rseed_r8)), source=0, stat=status) - VERIFY_(status) - pert_rseed = nint(pert_rseed_r8) - - ! Get alarm - call ESMF_ClockGetAlarm(clock, 'ForcePert', ForcePertAlarm, rc=status) - VERIFY_(status) - - ! Allocate and initialize perturbation arrays on grid - allocate(fpert_grid(n_lon,n_lat, internal%ForcePert%npert), stat=status) - VERIFY_(status) - fpert_grid = MAPL_UNDEF - - ! Get forcing perturbations on tiles if alarm is ringing - if (ESMF_AlarmIsRinging(ForcePertAlarm)) then - - ! -update-times- - tmpTime = internal%ForcePert%TimeNxt - internal%ForcePert%TimePrv = tmpTime - call ESMF_TimeIntervalSet(ntrvl, s=internal%ForcePert%dtstep, rc=status) - VERIFY_(status) - internal%ForcePert%TimeNxt = tmpTime + ntrvl - - ! -nxt-pert-data-becomes-prv- - internal%ForcePert%DataPrv = internal%ForcePert%DataNxt - - ! -get-nxt-forcing-perturbations-on-grid- - call MAPL_TimerOn(MAPL, '-GetPert') - - ! adjust mean - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert) = & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert)+fpert_enavg(:,:,:) - - call get_pert( & - internal%ForcePert%npert, & - internal%ForcePert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%ForcePert%dtstep), & - internal%ForcePert%param, & - pert_rseed, & - fpert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%ForcePert%npert), & - fpert_grid, & - initialize_rseed=.false., & - initialize_ntrmdt=.false., & - ! Weiyuan notes: propagate_pert is called in GenerateRaw, not here - diagnose_pert_only=.true. & - ) - - call MAPL_TimerOff(MAPL, '-GetPert') - - ! -convert-nxt-gridded-perturbations-to-tile- - call MAPL_TimerOn(MAPL, '-LocStreamTransform') - do ipert=1,internal%ForcePert%npert - call grid2tile( tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), fpert_grid(:,:,ipert), & - internal%ForcePert%DataNxt(:,ipert)) - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), fpert_ntrmdt(lon1:lon2,lat1:lat2,ipert)) - end do - - call MAPL_TimerOff(MAPL, '-LocStreamTransform') - - end if - - ! Allocate and initialize memory - allocate(FORCEPERT(land_nt_local, internal%ForcePert%npert), stat=status) - VERIFY_(status) - FORCEPERT = MAPL_UNDEF - - ! Interpolate perts on tiles to the end of the model integration time step - call esmf2ldas(internal%ForcePert%TimePrv, fpert_time_prv, rc=status) - VERIFY_(status) - - !if(IamRoot) print *, trim(Iam)//'::fpert_time_prv: ', date_time_print(fpert_time_prv) - - call interpolate_pert_to_timestep( & - model_time_nxt, & - fpert_time_prv, & - real(internal%ForcePert%dtstep), & - internal%ForcePert%DataPrv, & - internal%ForcePert%DataNxt, & - FORCEPERT(:,1:internal%ForcePert%npert) & - ) - - end if - - ! Pointers to imports - call MAPL_GetPointer(import, Tair, 'Tair', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Qair, 'Qair', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Psurf, 'Psurf', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Rainf_C, 'Rainf_C', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Rainf, 'Rainf', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Snowf, 'Snowf', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, LWdown, 'LWdown', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, SWdown, 'SWdown', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PARdrct, 'PARdrct', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, PARdffs, 'PARdffs', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, Wind, 'Wind', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, RefH, 'RefH', rc=status) - VERIFY_(status) - - ! Allocate memory for perturbed arrays - allocate(mfPert(land_nt_local), stat=status) - VERIFY_(status) - - call MAPL_TimerOn(MAPL, '-ApplyPert') - - ! Compute exports - mfPert%Tair = Tair - mfPert%Qair = Qair - mfPert%Rainf_C = Rainf_C - mfPert%Rainf = Rainf - mfPert%Snowf = Snowf - mfPert%LWdown = LWdown - mfPert%SWdown = SWdown - mfPert%PARdrct = PARdrct - mfPert%PARdffs = PARdffs - mfPert%Wind = Wind - - if (internal%PERTURBATIONS /=0) then - - ! Apply FORCEPERT to MetForcing variables - - do ipert=1,internal%ForcePert%npert - PertParam => internal%ForcePert%param(ipert) ! shorthand - select case (trim(PertParam%descr)) - case('pcp') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Rainf) - call repair_forcing(land_nt_local, mfPert, fieldname='Rainf') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Rainf_C) - call repair_forcing(land_nt_local, mfPert, fieldname='Rainf_C') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Snowf) - call repair_forcing(land_nt_local, mfPert, fieldname='Snowf') - case('sw') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%SWdown) - call repair_forcing(land_nt_local, mfPert, fieldname='SWdown') - ! reichle, 20 Dec 2011 - add perts to "PARdrct" and "PARdffs" - ! wjiang+reichle, 22 Apr 2021 - "PARdrct" and "PARdffs" now - ! backfilled in get_forcing(), arrive here with only "good" values - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%PARdrct) - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%PARdffs) - ! must repair "PARdrct" and "PARdffs" together - call repair_forcing(land_nt_local, mfPert, fieldname='PAR') - case('lw') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%LWdown) - call repair_forcing(land_nt_local, mfPert, fieldname='LWdown') - case('tair') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Tair) - call repair_forcing(land_nt_local, mfPert, fieldname='Tair') - case('qair') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Qair) - call repair_forcing(land_nt_local, mfPert, fieldname='Qair') - case('wind') - call apply_pert(PertParam, FORCEPERT(:,ipert), mfPert%Wind) - call repair_forcing(land_nt_local, mfPert, fieldname='Wind') - case default - RETURN_(ESMF_FAILURE) - end select - end do - - end if - - call MAPL_TimerOff(MAPL, '-ApplyPert') - - call MAPL_TimerOn(MAPL, '-MetForcing2Catch') - - ! Pointers to exports (allocate memory) - call MAPL_GetPointer(export, TApert, 'TApert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, QApert, 'QApert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PSpert, 'PSpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, UUpert, 'UUpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, UWINDLMTILEpert, 'UWINDLMTILEpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, VWINDLMTILEpert, 'VWINDLMTILEpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PCUpert, 'PCUpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PLSpert, 'PLSpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SNOpert, 'SNOpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRPARpert, 'DRPARpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFPARpert, 'DFPARpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRNIRpert, 'DRNIRpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFNIRpert, 'DFNIRpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DRUVRpert, 'DRUVRpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DFUVRpert, 'DFUVRpert', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWDNSRFpert, 'LWDNSRFpert',alloc=.true.,rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DZpert, 'DZpert',alloc=.true.,rc=status) - VERIFY_(status) - - ! Set exports - TApert = mfPert%Tair - QApert = mfPert%Qair - UUpert = mfPert%Wind - UWINDLMTILEpert = mfPert%Wind - VWINDLMTILEpert = 0. - PCUpert = mfPert%Rainf_C - PLSpert = mfPert%Rainf - mfPert%Rainf_C - SNOpert = mfPert%Snowf - ! no pert for psurf - PSpert = Psurf - DZpert = RefH - ! -par- - ! wjiang+reichle, 22 Apr 2021 - "PARdrct" and "PARdffs" now - ! backfilled in get_forcing(), arrive here with only "good" values - DRPARpert = mfPert%PARdrct - DFPARpert = mfPert%PARdffs - ! -nir-and-uvr- - ! S-V=I+U where S=SWdown, V=DRPAR+DFPAR, I=DRNIR+DFNIR, U=DRUVR+DFUVR - ! => U=0.5*S-V, I=0.5*S - allocate(tmpreal(land_nt_local), stat=status) - VERIFY_(status) - tmpreal = 0.5*mfPert%SWdown ! I = DRNIR+DFNIR - DRNIRpert = 0.5*tmpreal - DFNIRpert = 0.5*tmpreal - ! tmpreal = tmpreal - (DRPARpert + DFPARpert) ! U = DRUVR+DFUVR - DRUVRpert = 0.5*tmpreal-DRPARpert - DFUVRpert = 0.5*tmpreal-DFPARpert - if (allocated(tmpreal)) deallocate(tmpreal) - LWDNSRFpert = mfPert%LWdown - - call MAPL_TimerOff(MAPL, '-MetForcing2Catch') - - ! Update the r8 version of pert_rseed - if (internal%PERTURBATIONS /=0 ) then - pert_rseed_r8 = real(pert_rseed,kind=ESMF_kind_r8) - pert_iseed(:,internal%ens_id+1-FIRST_ENS_ID) = pert_rseed - endif - - ! Clean up - if (allocated(mfPert)) then - deallocate(mfPert, stat=status) - VERIFY_(status) - end if - if (allocated(FORCEPERT)) then - deallocate(FORCEPERT, stat=status) - VERIFY_(status) - end if - if (allocated(fpert_grid)) then - deallocate(fpert_grid, stat=status) - VERIFY_(status) - end if - if (allocated(pert_rseed)) then - deallocate(pert_rseed, stat=status) - VERIFY_(status) - end if - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Run_ApplyForcePert") - call MAPL_TimerOff(MAPL, "TOTAL") - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine ApplyForcePert - - - !BOP - - ! !IROTUINE: ApplyPrognPert -- Compute and apply perts to Prognostic vars - - ! !INTERFACE: - - subroutine ApplyPrognPert(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Apply perturbations to CATCH GridComp's prognostic variables - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - type(MAPL_LocStream) :: locstream - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_Alarm) :: PrognPertAlarm - type(ESMF_State) :: MINTERNAL - type(ESMF_Time) :: ModelTimeCur, ModelTimeNxt, tmpTime - type(ESMF_TimeInterval) :: ModelTimeStep, ntrvl - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - - ! MAPL internal pointers - real, pointer :: ppert_ntrmdt(:,:,:)=>null() - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! LDAS variables - type(date_time_type) :: model_time_nxt - type(date_time_type) :: ppert_time_prv - - ! Pointers to imports - real, pointer :: tcPert(:,:)=>null() - real, pointer :: catdefPert(:)=>null() - real, pointer :: rzexcPert(:)=>null() - real, pointer :: srfexcPert(:)=>null() - real, pointer :: ghtcnt1Pert(:)=>null() - real, pointer :: ghtcnt2Pert(:)=>null() - real, pointer :: ghtcnt3Pert(:)=>null() - real, pointer :: ghtcnt4Pert(:)=>null() - real, pointer :: ghtcnt5Pert(:)=>null() - real, pointer :: ghtcnt6Pert(:)=>null() - real, pointer :: wesnn1Pert(:)=>null() - real, pointer :: wesnn2Pert(:)=>null() - real, pointer :: wesnn3Pert(:)=>null() - real, pointer :: htsnnn1Pert(:)=>null() - real, pointer :: htsnnn2Pert(:)=>null() - real, pointer :: htsnnn3Pert(:)=>null() - real, pointer :: sndzn1Pert(:)=>null() - real, pointer :: sndzn2Pert(:)=>null() - real, pointer :: sndzn3Pert(:)=>null() - - ! Misc variables - real, allocatable :: PROGNPERT(:,:) - real, allocatable :: ppert_grid(:,:,:) - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - type(tile_coord_type), pointer :: tile_coord(:)=>null() - - integer :: n_lon,n_lat - integer :: ipert - integer, allocatable :: pert_rseed(:) - logical :: IAmRoot - integer :: land_nt_local - type(pert_param_type), pointer :: PertParam=>null() ! pert param - integer :: model_dtstep - real :: dtmh - ! Begin... - - ! Get my name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run_ApplyPrognPert" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - - ! MPI - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - - ! Get component's internal private state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - ! if no perturbation, do nothing - if(internal%PERTURBATIONS == 0) then - RETURN_(ESMF_SUCCESS) - endif - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Run_ApplyPrognPert") - - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - n_lon = tcinternal%pgrid_l%n_lon - n_lat = tcinternal%pgrid_l%n_lat - tile_coord => tcinternal%tile_coord - - ! Pointers to imports - call MAPL_GetPointer(import, tcPert, 'TCPert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, catdefPert, 'CATDEFPert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, rzexcPert, 'RZEXCPert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, srfexcPert, 'SRFEXCPert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt1Pert, 'GHTCNT1Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt2Pert, 'GHTCNT2Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt3Pert, 'GHTCNT3Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt4Pert, 'GHTCNT4Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt5Pert, 'GHTCNT5Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, ghtcnt6Pert, 'GHTCNT6Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, wesnn1Pert, 'WESNN1Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, wesnn2Pert, 'WESNN2Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, wesnn3Pert, 'WESNN3Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, htsnnn1Pert, 'HTSNNN1Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, htsnnn2Pert, 'HTSNNN2Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, htsnnn3Pert, 'HTSNNN3Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, sndzn1Pert, 'SNDZN1Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, sndzn2Pert, 'SNDZN2Pert', rc=status) - VERIFY_(status) - call MAPL_GetPointer(import, sndzn3Pert, 'SNDZN3Pert', rc=status) - VERIFY_(status) - - call MAPL_TimerOn(MAPL, '-ApplyPert') - - ! Compute PROGNPERT - - ! Get current time - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - VERIFY_(status) - - ! Compute time stamp of Next model step - convert to LDAS datetime - call ESMF_ClockGet(clock, timeStep=ModelTimeStep, rc=status) - VERIFY_(status) - ModelTimeNxt = ModelTimeCur + ModelTimeStep - call esmf2ldas(ModelTimeNxt, model_time_nxt, rc=status) - VERIFY_(status) - - - ! Pointers to mapl internals - if( internal%isCubedSphere) then - ppert_ntrmdt => internal%ppert_ntrmdt - pert_rseed_r8 => internal%pert_rseed_r8 - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, ppert_ntrmdt, 'ppert_ntrmdt', rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - endif - - ! Convert pert_rseed_r8 to integer - allocate(pert_rseed(size(pert_rseed_r8)), source=0, stat=status) - VERIFY_(status) - pert_rseed = nint(pert_rseed_r8) - - ! Get alarm - call ESMF_ClockGetAlarm(clock, 'PrognPert', PrognPertAlarm, rc=status) - VERIFY_(status) - - ! Get locstream - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - - ! Get number of land tiles - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - - ! Allocate and initialize perturbation arrays on grid - allocate(ppert_grid(n_lon, n_lat, internal%PrognPert%npert), stat=status) - VERIFY_(status) - ppert_grid = MAPL_UNDEF - - ! Get forcing perturbations on tiles if alarm is ringing - if (ESMF_AlarmIsRinging(PrognPertAlarm)) then - - ! -update-times- - tmpTime = internal%PrognPert%TimeNxt - internal%PrognPert%TimePrv = tmpTime - call ESMF_TimeIntervalSet(ntrvl, s=internal%PrognPert%dtstep, rc=status) - VERIFY_(status) - internal%PrognPert%TimeNxt = tmpTime + ntrvl - - ! -nxt-pert-data-becomes-prv- - internal%PrognPert%DataPrv = internal%PrognPert%DataNxt - - ! -get-nxt-forcing-perturbations-on-grid- - call MAPL_TimerOn(MAPL, '-GetPert') - - ! adjust mean - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert) = & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert)+ppert_enavg(:,:,:) - - call get_pert( & - internal%PrognPert%npert, & - internal%PrognPert%fft_npert, & - 1, & - tcinternal%pgrid_l, tcinternal%pgrid_f, & - real(internal%PrognPert%dtstep), & - internal%PrognPert%param, & - pert_rseed, & - ppert_ntrmdt(lon1:lon2,lat1:lat2,1:internal%PrognPert%npert), & - ppert_grid, & - initialize_rseed=.false., & - initialize_ntrmdt=.false., & - ! Weiyuan notes: propagate_pert is called in GenerateRaw, not here - diagnose_pert_only=.true. & - ) - call MAPL_TimerOff(MAPL, '-GetPert') - - ! -convert-nxt-gridded-perturbations-to-tile- - call MAPL_TimerOn(MAPL, '-LocStreamTransform') - do ipert=1,internal%PrognPert%npert - call grid2tile( tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_grid(:,:,ipert), & - internal%PrognPert%DataNxt(:,ipert)) - call tile_mask_grid(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), ppert_ntrmdt(lon1:lon2,lat1:lat2,ipert)) - end do - call MAPL_TimerOff(MAPL, '-LocStreamTransform') - - end if - - ! Allocate and initialize memory - allocate(PROGNPERT(land_nt_local, internal%PrognPert%npert), stat=status) - VERIFY_(status) - PROGNPERT = MAPL_UNDEF - - ! Interpolate perts on tiles to the end of the model integration time step - call esmf2ldas(internal%PrognPert%TimePrv, ppert_time_prv, rc=status) - VERIFY_(status) - - !if(IamRoot) print *, trim(Iam)//'::ppert_time_prv: ', date_time_print(ppert_time_prv) - - call interpolate_pert_to_timestep( & - model_time_nxt, & - ppert_time_prv, & - real(internal%PrognPert%dtstep), & - internal%PrognPert%DataPrv, & - internal%PrognPert%DataNxt, & - PROGNPERT(:,1:internal%PrognPert%npert) & - ) - ! Compute export (perturbed arrays) - - ! -model-dtstep-in-hours- - call ESMF_TimeIntervalGet(ModelTimeStep, s=model_dtstep) - VERIFY_(status) - dtmh = real(model_dtstep)/3600. - - - if (internal%PERTURBATIONS /=0) then - - ! Apply PROGNPERT to Prognostic variables - do ipert=1,internal%PrognPert%npert - PertParam => internal%PrognPert%param(ipert) ! shorthand - select case (trim(PertParam%descr)) - case ('catdef') - call apply_pert(PertParam, PROGNPERT(:,ipert), catdefPert, dtmh) - case ('rzexc') - call apply_pert(PertParam, PROGNPERT(:,ipert), rzexcPert, dtmh) - case ('srfexc') - call apply_pert(PertParam, PROGNPERT(:,ipert), srfexcPert, dtmh) - case ('snow') - _ASSERT(PertParam%typ==1, 'ONLY multiplicative snow perturbations implemented') - call apply_pert(PertParam, PROGNPERT(:,ipert), wesnn1Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), wesnn2Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), wesnn3Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), htsnnn1Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), htsnnn2Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), htsnnn3Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), sndzn1Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), sndzn2Pert, dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), sndzn3Pert, dtmh) - case ('tc') - call apply_pert(PertParam, PROGNPERT(:,ipert), tcPert(:,1), dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), tcPert(:,2), dtmh) - call apply_pert(PertParam, PROGNPERT(:,ipert), tcPert(:,4), dtmh) - case ('ght1') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt1Pert, dtmh) - case ('ght2') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt2Pert, dtmh) - case ('ght3') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt3Pert, dtmh) - case ('ght4') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt4Pert, dtmh) - case ('ght5') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt5Pert, dtmh) - case ('ght6') - call apply_pert(PertParam, PROGNPERT(:,ipert), ghtcnt6Pert, dtmh) - case default - RETURN_(ESMF_FAILURE) - end select - end do - -! Removing call to check_cat_progns (wrapper for check_catch_progn) in prep for SMAP L4_SM Version 5. -! Call was inserted for compatibility of GEOSldas with LDASsa tag used for SMAP L4_SM Version 4 product (Tv4034). -! Earlier testing without the call (Tv4033) did not result in crashes of catchment() and yielded slightly drier -! soil moisture in deserts. -! - reichle, 17 Jan 2020 -! -! call check_cat_progns(land_nt_local, cat_param, tcPert(:,1), tcPert(:,2), tcPert(:,4), & -!! qa1,qa2,qa4, capac & -! catdefPert, & -! rzexcPert, srfexcPert, & -! ghtcnt1Pert,ghtcnt2Pert,ghtcnt3Pert,ghtcnt4Pert,ghtcnt5Pert,ghtcnt6Pert, & -! wesnn1Pert,wesnn2Pert,wesnn3Pert, & -! htsnnn1Pert,htsnnn2Pert,htsnnn3Pert, & -! sndzn1Pert, sndzn2Pert,sndzn3Pert) - end if - - call MAPL_TimerOff(MAPL, '-ApplyPert') - - ! Update the r8 version of pert_rseed - pert_rseed_r8 = real(pert_rseed,kind=ESMF_kind_r8) - pert_iseed(:,internal%ens_id+1-FIRST_ENS_ID) = pert_rseed - - ! Clean up - if (allocated(PROGNPERT)) then - deallocate(PROGNPERT, stat=status) - VERIFY_(status) - end if - if (allocated(ppert_grid)) then - deallocate(ppert_grid, stat=status) - VERIFY_(status) - end if - if (allocated(pert_rseed)) then - deallocate(pert_rseed, stat=status) - VERIFY_(status) - end if - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Run_ApplyPrognPert") - call MAPL_TimerOff(MAPL, "TOTAL") - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine ApplyPrognPert - - subroutine Update_pert_rseed(gc,import,export,clock,rc) - ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - type(ESMF_State) :: MINTERNAL - real(kind=ESMF_KIND_R8), pointer :: pert_rseed_r8(:)=>null() - - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // ":: Update_pert_rseed" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Get component's private internal state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - if( internal%isCubedSphere) then - pert_rseed_r8 => internal%pert_rseed_r8 - else - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=MINTERNAL, rc=status) - VERIFY_(status) - call MAPL_GetPointer(MINTERNAL, pert_rseed_r8, 'pert_rseed', rc=status) - VERIFY_(status) - endif - - pert_rseed_r8(:) = real(pert_iseed(:,internal%ens_id+1-FIRST_ENS_ID),kind=ESMF_KIND_R8) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Update_pert_rseed - - !BOP - - ! !IROTUINE: Finalize -- finalize method for LDAS GC - - ! !INTERFACE: - - subroutine Finalize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Clean up the private internal state - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - character(len=ESMF_MAXSTR) :: chk_fname - character(len=ESMF_MAXSTR) :: id_string - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - - ! Internal private state variables - type(T_LANDPERT_STATE), pointer :: internal=>null() - type(LANDPERT_WRAP) :: wrap - type(MAPL_LocStream) :: locstream - type(TILECOORD_WRAP) :: tcwrap - type(T_TILECOORD_STATE), pointer :: tcinternal - integer :: m, land_nt_local, ens_id_width - - integer :: nfpert, nppert, n_tile - type(tile_coord_type), pointer :: tile_coord_f(:)=>null() - type (ESMF_Grid) :: tilegrid - integer, pointer :: mask(:) - real, allocatable, dimension(:,:) :: tile_data_f, tile_data_p, tile_data_f_all, tile_data_p_all - ! Begin... - - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Finalize" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - call MAPL_GetResource( MAPL, ens_id_width,"ENS_ID_WIDTH:", default=4, RC=STATUS) - VERIFY_(status) - ! Get component's private internal state - call ESMF_UserCompGetInternalState(gc, 'Landpert_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tcinternal => tcwrap%ptr - - if ( internal%isCubedSphere .and. internal%PERTURBATIONS /= 0) then - call MAPL_Get(MAPL, LocStream=locstream,rc=status) - VERIFY_(status) - call MAPL_LocStreamGet(locstream, NT_LOCAL=land_nt_local,rc=status) - VERIFY_(status) - call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) - VERIFY_(STATUS) - call MAPL_TileMaskGet(tilegrid, mask, rc=status) - VERIFY_(STATUS) - nfpert = internal%ForcePert%npert - nppert = internal%PrognPert%npert - tile_coord_f => tcinternal%tile_coord_f - n_tile = size(tile_coord_f,1) - ! 1) grid2tile - allocate(tile_data_f(land_nt_local,nfpert)) - allocate(tile_data_p(land_nt_local,nppert)) - do m = 1, nfpert - call grid2tile(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), & - internal%fpert_ntrmdt(lon1:lon2,lat1:lat2,m), tile_data_f(:,m)) - enddo - do m = 1, nppert - call grid2tile(tcinternal%pgrid_l, land_nt_local, internal%i_indgs(:),internal%j_indgs(:), & - internal%ppert_ntrmdt(lon1:lon2,lat1:lat2,m), tile_data_p(:,m)) - enddo - ! 2) gather tiledata - if (MAPL_am_I_Root()) then - allocate(tile_data_f_all(n_tile,nfpert), stat=status) - VERIFY_(STATUS) - allocate(tile_data_p_all(n_tile,nppert), stat=status) - VERIFY_(STATUS) - else - allocate(tile_data_f_all(0,nfpert), stat=status) - VERIFY_(STATUS) - allocate(tile_data_p_all(0,nppert), stat=status) - VERIFY_(STATUS) - end if - - do m = 1, nfpert - call ArrayGather(tile_data_f(:,m), tile_data_f_all(:,m), tilegrid, mask=mask, rc=status) - VERIFY_(STATUS) - enddo - do m = 1, nppert - call ArrayGather(tile_data_p(:,m), tile_data_p_all(:,m), tilegrid, mask=mask, rc=status) - VERIFY_(STATUS) - enddo - - if (MAPL_am_I_Root()) then - ! 3) tile2grid - ! this step is simply a reverse of grid2tile without any weighted - do m = 1, nfpert - call tile2grid_simple( N_tile, tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, tcinternal%pgrid_g, tile_data_f_all(:,m), internal%fpert_ntrmdt(:,:,m)) - enddo - do m = 1, nppert - call tile2grid_simple( N_tile, tile_coord_f%pert_i_indg, tile_coord_f%pert_j_indg, tcinternal%pgrid_g, tile_data_p_all(:,m), internal%ppert_ntrmdt(:,:,m)) - enddo - - ! 4) writing - - call get_ensid_string(id_string,internal%ens_id, ens_id_width, internal%NUM_ENSEMBLE) - - chk_fname = 'landpert'//trim(id_string)//'_internal_checkpoint' - call write_pert_checkpoint(trim(chk_fname),internal%fpert_ntrmdt, internal%ppert_ntrmdt, internal%pert_rseed_r8) - endif - deallocate(tile_data_f, tile_data_p, tile_data_f_all, tile_data_p_all) - endif - - ! Clean up private internal state - if (associated(internal%ForcePert%param)) then - deallocate(internal%ForcePert%param, stat=status) - VERIFY_(status) - end if - if (associated(internal%PrognPert%param)) then - deallocate(internal%PrognPert%param, stat=status) - VERIFY_(status) - end if - if (allocated(internal%ForcePert%DataPrv)) then - deallocate(internal%ForcePert%DataPrv, stat=status) - VERIFY_(status) - end if - if (allocated(internal%ForcePert%DataNxt)) then - deallocate(internal%ForcePert%DataNxt, stat=status) - VERIFY_(status) - end if - if (allocated(internal%PrognPert%DataPrv)) then - deallocate(internal%PrognPert%DataPrv, stat=status) - VERIFY_(status) - end if - if (allocated(internal%PrognPert%DataNxt)) then - deallocate(internal%PrognPert%DataNxt, stat=status) - VERIFY_(status) - end if - - if (allocated(internal%fpert_ntrmdt)) then - deallocate(internal%fpert_ntrmdt, stat=status) - VERIFY_(status) - end if - - if (allocated(internal%ppert_ntrmdt)) then - deallocate(internal%ppert_ntrmdt, stat=status) - VERIFY_(status) - end if - - if (allocated(internal%pert_rseed_r8)) then - deallocate(internal%pert_rseed_r8, stat=status) - VERIFY_(status) - end if - - if (allocated(fpert_enavg)) then - deallocate(fpert_enavg, stat=status) - VERIFY_(status) - end if - if (allocated(ppert_enavg)) then - deallocate(ppert_enavg, stat=status) - VERIFY_(status) - end if - - call clear_rf() - ! Call Finalize for every child - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - - subroutine read_pert_rst(rst_fname,fpert, ppert,pert_rseed_r8) - use netcdf - character(len=*),intent(in) :: rst_fname - real,intent(inout) :: fpert(:,:,:) - real,intent(inout) :: ppert(:,:,:) - real(kind=ESMF_KIND_R8),intent(inout) :: pert_rseed_r8(:) - integer :: ncid, varid - - call check( nf90_open(rst_fname, NF90_NOWRITE, ncid) ) - - ! Get the varid of the data variable, based on its name. - call check( nf90_inq_varid(ncid, "fpert_ntrmdt", varid) ) - call check( nf90_get_var(ncid, varid, fpert) ) - call check( nf90_inq_varid(ncid, "ppert_ntrmdt", varid) ) - call check( nf90_get_var(ncid, varid, ppert) ) - call check( nf90_inq_varid(ncid, "pert_rseed", varid) ) - call check( nf90_get_var(ncid, varid, pert_rseed_r8) ) - - ! Close the file, freeing all resources. - call check( nf90_close(ncid) ) - - contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop 1 - end if - end subroutine check - end subroutine - - subroutine write_pert_checkpoint(chk_fname, fpert,ppert, pert_rseed_r8) - use netcdf - character(len=*),intent(in) :: chk_fname - real,intent(inout) :: fpert(:,:,:) - real,intent(inout) :: ppert(:,:,:) - real(kind=ESMF_KIND_R8),intent(inout) :: pert_rseed_r8(:) - character(len=*), parameter :: SHORT_NAME = "SHORT_NAME" - character(len=*), parameter :: LONG_NAME = "LONG_NAME" - character(len=*), parameter :: UNITS = "UNITS" - character(len=*), parameter :: f_SHORT = "fpert_ntrmdt" - character(len=*), parameter :: p_SHORT = "pert_ntrmdt" - character(len=*), parameter :: s_SHORT = "pert_rseed" - character(len=*), parameter :: f_long = "force_pert_intermediate" - character(len=*), parameter :: p_long = "progn_pert_intermediate" - character(len=*), parameter :: s_long = "Perturbations_rseed" - character(len=*), parameter :: units_ = "1" - integer :: n_lon, n_lat, nseeds, n_f_max, n_p_max - integer :: ncid, p_varid,f_varid, s_varid - integer :: dimids(3),lat_dimid, lon_dimid, seed_dimid, n_f_dimid, n_p_dimid - - n_lon = size(fpert,1) - n_lat = size(fpert,2) - n_f_max = size(fpert,3) - n_p_max = size(ppert,3) - nseeds = size(pert_rseed_r8) - - ! Create the file. - call check( nf90_create(trim(chk_fname), nf90_clobber + NF90_NETCDF4, ncid) ) - -! Define the dimensions. - call check( nf90_def_dim(ncid, "latitude", n_lat, lat_dimid) ) - call check( nf90_def_dim(ncid, "longtitude", n_lon, lon_dimid) ) - call check( nf90_def_dim(ncid, "N_FORCE_MAX", n_f_max, n_f_dimid) ) - call check( nf90_def_dim(ncid, "N_PROGN_MAX", n_p_max, n_p_dimid) ) - call check( nf90_def_dim(ncid, "NRANDSEED", nseeds, seed_dimid) ) - - dimids = (/ lon_dimid, lat_dimid,n_f_dimid /) - call check( nf90_def_var(ncid, 'fpert_ntrmdt', NF90_REAL, dimids, f_varid) ) - dimids = (/ lon_dimid, lat_dimid,n_p_dimid /) - call check( nf90_def_var(ncid, 'ppert_ntrmdt', NF90_REAL, dimids, p_varid) ) - call check( nf90_def_var(ncid, 'pert_rseed', NF90_DOUBLE, seed_dimid, s_varid) ) - - ! call check( nf90_def_var_deflate(ncid, f_varid, 1, 1, 2)) - ! call check( nf90_def_var_deflate(ncid, p_varid, 1, 1, 2)) - ! Assign attribute - call check( nf90_put_att(ncid, f_varid, UNITS, units_) ) - call check( nf90_put_att(ncid, p_varid, UNITS, units_) ) - call check( nf90_put_att(ncid, s_varid, UNITS, units_) ) - - call check( nf90_put_att(ncid, f_varid, SHORT_NAME, f_short) ) - call check( nf90_put_att(ncid, p_varid, SHORT_NAME, p_short) ) - call check( nf90_put_att(ncid, s_varid, SHORT_NAME, s_short) ) - - call check( nf90_put_att(ncid, f_varid, LONG_NAME, f_long) ) - call check( nf90_put_att(ncid, p_varid, LONG_NAME, p_long) ) - call check( nf90_put_att(ncid, s_varid, LONG_NAME, s_long) ) - - ! End define mode. - call check( nf90_enddef(ncid) ) - - ! write varaible - call check( nf90_put_var(ncid, p_varid, ppert) ) - call check( nf90_put_var(ncid, f_varid, fpert) ) - call check( nf90_put_var(ncid, s_varid, pert_rseed_r8) ) - - ! Close the file. - call check( nf90_close(ncid) ) - - contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop 1 - end if - end subroutine check - end subroutine - -end module GEOS_LandPertGridCompMod diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/LDAS_PertRoutines.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/LDAS_PertRoutines.F90 deleted file mode 100644 index a351dde8..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/LDAS_PertRoutines.F90 +++ /dev/null @@ -1,2239 +0,0 @@ -! -! this file contains a collection of subroutines that are needed to -! run the Ensemble Kalman filter with the catchment model off-line driver -! -! reichle, 10 May 2005 -! reichle, 6 Dec 2013 - introduced "progn_pert_type" -! (no longer use "cat_progn_type" for progn perts) -! reichle, 21 Nov 2014 - re-interpreted progn_pert as perturbation flux forcing -! - added "qair" and "wind" perts in apply_force_pert() -! - renamed force_pert_type fields for consistency w/ met_force_type -! %tmp2m --> %tair (but note lower-case!) -! %dpt2m --> %qair (but note lower-case!) -! %wnd --> %wind (but note lower-case!) -#include "MAPL_Generic.h" - -module LDAS_PertRoutinesMod - - use ESMF - use MAPL_Mod - - use LDAS_ensdrv_Globals, ONLY: & - logunit, & - root_logit, & - nodata_generic, & - nodata_tolfrac_generic, & - nodata_tol_generic - use LDAS_ensdrv_mpi, only: mpicomm,numprocs,myid - use MAPL_ConstantsMod, ONLY: & - Tzero => MAPL_TICE, & - alhe => MAPL_ALHL, & - alhs => MAPL_ALHS - - use LDAS_TileCoordType, ONLY: & - tile_coord_type, & - grid_def_type, & - io_grid_def_type - - use LDAS_TileCoordRoutines, ONLY: & - LDAS_create_grid_g - - use LDAS_PertTypes, ONLY: & - pert_param_type, & - allocate_pert_param - - ! CHANGED: cat_param/progn_types are only used by apply_*_pert - ! and these routine (apply_*_pert) are no longer part of this module - ! use catch_types, ONLY: & - ! cat_param_type, & - ! cat_progn_type - ! - !use LDAS_DriverTypes, ONLY: & - ! met_force_type - - use force_and_cat_progn_pert_types, ONLY: & - N_force_pert_max, & - force_pert_real_type, & - force_pert_logi_type, & - force_pert_char_type, & - force_pert_ccor_type, & - N_progn_pert_max, & - progn_pert_real_type, & - progn_pert_logi_type, & - progn_pert_char_type, & - progn_pert_ccor_type, & - struct2vec_force_pert, & - struct2mat_force_pert_ccor, & - struct2vec_progn_pert, & - struct2mat_progn_pert_ccor, & - assignment (=) - - use LDAS_DateTimeMod, ONLY: & - date_time_type, & - datetime2_minus_datetime1 - - use nr_ran2_gasdev, ONLY: & - NRANDSEED - - use land_pert_routines, ONLY: & - get_pert, & - get_sqrt_corr_matrix, & - get_init_Pert_rseed - - ! CHANGED: We are going to use MAPL_LocStreamXform instead - ! use tile_coord_routines, ONLY: & - ! grid2tile, & - ! get_is_land - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - ! TODO: maybe copy over check_cat_progn to some file here - ! use clsm_ensdrv_drv_routines, ONLY: & - ! check_cat_progn - - use RepairForcingMod, ONLY: & - repair_forcing - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use netcdf - - implicit none - - include 'mpif.h' - - ! everything is private by default unless made public - - private - - public :: read_ens_prop_inputs - public :: interpolate_pert_to_timestep - public :: get_pert_grid - public :: get_progn_pert_param - public :: get_force_pert_param - public :: echo_pert_param - ! WY note :: io_pert_rstrt() was adapted. read from LDASsa and write to a nc4 file as MAPL internal - public :: io_pert_rstrt - public :: check_pert_dtstep - ! ADDED - public :: apply_pert - ! the parameters below will be overwritten by RC file - integer,public :: GEOSldas_NUM_ENSEMBLE = -1 - integer,public :: GEOSldas_FIRST_ENS_ID = -1 - integer,public :: GEOSldas_FORCE_PERT_DTSTEP = -1 - integer,public :: GEOSldas_PROGN_PERT_DTSTEP = -1 - -contains - - ! ******************************************************************* - - subroutine read_ens_prop_inputs( & - write_nml, & - work_path, & - exp_id, & - date_time, & - kw_echo, & - kw_N_ens, & - kw_ens_id, & - kw_progn_pert_dtstep, & - kw_force_pert_dtstep, & - kw_descr_progn_pert, & - kw_typ_progn_pert, & - kw_std_progn_pert, & - kw_stdfromfile_progn_pert, & - kw_stdfilename_progn_pert, & - kw_zeromean_progn_pert, & - kw_coarsen_progn_pert, & - kw_std_normal_max_progn_pert, & - kw_xcorr_progn_pert, & - kw_ycorr_progn_pert, & - kw_tcorr_progn_pert, & - kw_ccorr_progn_pert, & - kw_descr_force_pert, & - kw_typ_force_pert, & - kw_std_force_pert, & - kw_stdfromfile_force_pert, & - kw_stdfilename_force_pert, & - kw_zeromean_force_pert, & - kw_coarsen_force_pert, & - kw_std_normal_max_force_pert, & - kw_xcorr_force_pert, & - kw_ycorr_force_pert, & - kw_tcorr_force_pert, & - kw_ccorr_force_pert & - ) - - ! read ensemble propagation inputs from namelist file - ! - ! runtime options are read in three steps: - ! - ! 1.) read options from default namelist file called - ! ens_prop_inputs.nml in working directory (must be present) - ! - ! pchakrab: Removing the 2nd and 3rd options. Options will be read - ! ONLY from the 'default' namelist file - - ! 2.) overwrite options from special namelist file (if present) - ! specified at the command line using -ens_prop_inputs_path - ! and -ens_prop_inputs_file - ! - ! reichle, 29 Mar 2004 - ! reichle, 31 Aug 2004 - added tskin_isccp - ! reichle, 31 May 2005 - redesign for CLSM ens driver - - implicit none - - logical, intent(in), optional :: write_nml - - character(*), intent(in), optional :: work_path - character(*), intent(in), optional :: exp_id - - type(date_time_type), intent(in), optional :: date_time - - logical, intent(in), optional :: kw_echo - - integer, intent(out), optional :: kw_N_ens - - integer, dimension(:), pointer, optional :: kw_ens_id ! output - - integer, intent(out), optional :: kw_progn_pert_dtstep - integer, intent(out), optional :: kw_force_pert_dtstep - - character(*), intent(out), optional :: kw_stdfilename_progn_pert - character(*), intent(out), optional :: kw_stdfilename_force_pert - - type(progn_pert_char_type), intent(out), optional :: & - kw_descr_progn_pert - - type(progn_pert_logi_type), intent(out), optional :: & - kw_zeromean_progn_pert, & - kw_coarsen_progn_pert, & - kw_stdfromfile_progn_pert - - type(progn_pert_real_type), intent(out), optional :: & - kw_std_normal_max_progn_pert, & - kw_std_progn_pert, & - kw_xcorr_progn_pert, & - kw_ycorr_progn_pert, & - kw_tcorr_progn_pert, & - kw_typ_progn_pert - - type(progn_pert_ccor_type), intent(out), optional :: & - kw_ccorr_progn_pert - - type(force_pert_char_type), intent(out), optional :: & - kw_descr_force_pert - - type(force_pert_logi_type), intent(out), optional :: & - kw_zeromean_force_pert, & - kw_coarsen_force_pert, & - kw_stdfromfile_force_pert - - type(force_pert_real_type), intent(out), optional :: & - kw_std_normal_max_force_pert, & - kw_std_force_pert, & - kw_xcorr_force_pert, & - kw_ycorr_force_pert, & - kw_tcorr_force_pert, & - kw_typ_force_pert - - type(force_pert_ccor_type), intent(out), optional :: & - kw_ccorr_force_pert - - ! ------------------------ - - ! locals - - character(300) :: fname - - character(200) :: ens_prop_inputs_path - character( 40) :: ens_prop_inputs_file, dir_name, file_tag, file_ext - - integer :: i, N_ens, first_ens_id, progn_pert_dtstep, force_pert_dtstep - - character(300) :: stdfilename_progn_pert, stdfilename_force_pert - - type(progn_pert_char_type) :: descr_progn_pert - - type(progn_pert_logi_type) :: zeromean_progn_pert - type(progn_pert_logi_type) :: coarsen_progn_pert - type(progn_pert_logi_type) :: stdfromfile_progn_pert - - type(progn_pert_real_type) :: std_normal_max_progn_pert - type(progn_pert_real_type) :: std_progn_pert - type(progn_pert_real_type) :: xcorr_progn_pert - type(progn_pert_real_type) :: ycorr_progn_pert - type(progn_pert_real_type) :: tcorr_progn_pert - type(progn_pert_real_type) :: typ_progn_pert - - type(progn_pert_ccor_type) :: ccorr_progn_pert - - type(force_pert_char_type) :: descr_force_pert - - type(force_pert_logi_type) :: zeromean_force_pert - type(force_pert_logi_type) :: coarsen_force_pert - type(force_pert_logi_type) :: stdfromfile_force_pert - - type(force_pert_real_type) :: std_normal_max_force_pert - type(force_pert_real_type) :: std_force_pert - type(force_pert_real_type) :: xcorr_force_pert - type(force_pert_real_type) :: ycorr_force_pert - type(force_pert_real_type) :: tcorr_force_pert - type(force_pert_real_type) :: typ_force_pert - - type(force_pert_ccor_type) :: ccorr_force_pert - - ! Errlong variables - character(len=*), parameter :: Iam = 'read_ens_prop_inputs' - - ! MPI variables - logical :: root_proc,f_exist - - ! ----------------------------------------------------------------- - - namelist /ens_prop_inputs/ & - N_ens, & - first_ens_id, & - progn_pert_dtstep, & - force_pert_dtstep, & - descr_progn_pert, & - typ_progn_pert, & - std_progn_pert, & - zeromean_progn_pert, & - coarsen_progn_pert, & - stdfromfile_progn_pert, & - stdfilename_progn_pert, & - std_normal_max_progn_pert, & - xcorr_progn_pert, & - ycorr_progn_pert, & - tcorr_progn_pert, & - ccorr_progn_pert, & - descr_force_pert, & - typ_force_pert, & - std_force_pert, & - zeromean_force_pert, & - coarsen_force_pert, & - stdfromfile_force_pert, & - stdfilename_force_pert, & - std_normal_max_force_pert, & - xcorr_force_pert, & - ycorr_force_pert, & - tcorr_force_pert, & - ccorr_force_pert - - - root_proc = (myid ==0) - - ! --------------------------------------------------------------------- - ! - ! initialize selected name list inputs - ! (useful if not all fields of a structure are set explicitly - ! in namelist file) - - ccorr_progn_pert = nodata_generic - ccorr_force_pert = nodata_generic - - ! ------------------------------------------------------ - ! - ! Set default file name for ens prop inputs namelist file - - ens_prop_inputs_path = './' ! set default - ens_prop_inputs_file = 'LDASsa_DEFAULT_inputs_ensprop.nml' - - ! Read data from default ens_prop_inputs namelist file - - fname = trim(ens_prop_inputs_path) // '/' // trim(ens_prop_inputs_file) - open (10, file=fname, delim='apostrophe', action='read', status='old') - - if (present(kw_echo)) then - if (kw_echo) then - - if(root_logit) then - write (logunit,*) - write (logunit,'(400A)') 'reading *default* ens prop inputs from ' // trim(fname) - write (logunit,*) - endif - end if - end if - - read (10, nml=ens_prop_inputs) - - close(10,status='keep') - - - fname = './LDASsa_SPECIAL_inputs_ensprop.nml' - inquire(file=fname,exist=f_exist) - - if (f_exist) then - open (10, file=fname, delim='apostrophe', action='read', status='old') - if (present(kw_echo)) then - if (kw_echo) then - - if(root_logit) then - write (logunit,*) - write (logunit,'(400A)') 'reading *SPECIAL* ens prop inputs from ' // trim(fname) - write (logunit,*) - endif - end if - end if - read (10, nml=ens_prop_inputs) - close(10,status='keep') - endif - if( GEOSldas_NUM_ENSEMBLE == -1 .or. GEOSldas_FIRST_ENS_ID == -1 & - .or. GEOSldas_FORCE_PERT_DTSTEP == -1 .or. GEOSldas_PROGN_PERT_DTSTEP == -1 ) then - stop " GEOSldas_NUM_ENSEMBLE etc. should be initialized" - endif - N_ens = GEOSldas_NUM_ENSEMBLE - first_ens_id = GEOSldas_FIRST_ENS_ID - force_pert_dtstep = GEOSldas_FORCE_PERT_DTSTEP - progn_pert_dtstep = GEOSldas_PROGN_PERT_DTSTEP - - ! echo variables of ens_prop_inputs - - if (present(kw_echo) .and. root_logit) then - if (kw_echo) then - - write (logunit,*) 'ens_prop inputs are:' - write (logunit,*) - write (logunit, nml=ens_prop_inputs) - write (logunit,*) - - end if - end if - - ! ------------------------------------------------------------- - - if (present(kw_N_ens)) then - - kw_N_ens = N_ens - - if (present(kw_ens_id)) then - - allocate(kw_ens_id(N_ens)) - do i=1,N_ens - kw_ens_id(i) = first_ens_id + i - 1 - end do - if(root_logit) then - write (logunit,*) - write (logunit,*) 'ens_id = ', (kw_ens_id(i), i=1,N_ens) - write (logunit,*) - endif - end if - end if - - - ! perturbations time steps - - if (present(kw_progn_pert_dtstep)) & - kw_progn_pert_dtstep = progn_pert_dtstep - - if (present(kw_force_pert_dtstep)) & - kw_force_pert_dtstep = force_pert_dtstep - - - ! other perturbations parameters - - if (present(kw_descr_progn_pert)) & - kw_descr_progn_pert = descr_progn_pert - - if (present(kw_zeromean_progn_pert)) & - kw_zeromean_progn_pert = zeromean_progn_pert - - if (present(kw_coarsen_progn_pert)) & - kw_coarsen_progn_pert = coarsen_progn_pert - - if (present(kw_stdfromfile_progn_pert)) & - kw_stdfromfile_progn_pert = stdfromfile_progn_pert - - if (present(kw_stdfilename_progn_pert)) & - kw_stdfilename_progn_pert = stdfilename_progn_pert - - if (present(kw_std_normal_max_progn_pert)) & - kw_std_normal_max_progn_pert = std_normal_max_progn_pert - - if (present(kw_std_progn_pert )) kw_std_progn_pert = std_progn_pert - if (present(kw_xcorr_progn_pert)) kw_xcorr_progn_pert = xcorr_progn_pert - if (present(kw_ycorr_progn_pert)) kw_ycorr_progn_pert = ycorr_progn_pert - if (present(kw_tcorr_progn_pert)) kw_tcorr_progn_pert = tcorr_progn_pert - if (present(kw_typ_progn_pert )) kw_typ_progn_pert = typ_progn_pert - - if (present(kw_ccorr_progn_pert)) kw_ccorr_progn_pert = ccorr_progn_pert - - if (present(kw_descr_force_pert)) & - kw_descr_force_pert = descr_force_pert - - if (present(kw_zeromean_force_pert)) & - kw_zeromean_force_pert = zeromean_force_pert - - if (present(kw_coarsen_force_pert)) & - kw_coarsen_force_pert = coarsen_force_pert - - if (present(kw_stdfromfile_force_pert)) & - kw_stdfromfile_force_pert = stdfromfile_force_pert - - if (present(kw_stdfilename_force_pert)) & - kw_stdfilename_force_pert = stdfilename_force_pert - - if (present(kw_std_normal_max_force_pert)) & - kw_std_normal_max_force_pert = std_normal_max_force_pert - - if (present(kw_std_force_pert )) kw_std_force_pert = std_force_pert - if (present(kw_xcorr_force_pert)) kw_xcorr_force_pert = xcorr_force_pert - if (present(kw_ycorr_force_pert)) kw_ycorr_force_pert = ycorr_force_pert - if (present(kw_tcorr_force_pert)) kw_tcorr_force_pert = tcorr_force_pert - if (present(kw_typ_force_pert )) kw_typ_force_pert = typ_force_pert - - if (present(kw_ccorr_force_pert)) kw_ccorr_force_pert = ccorr_force_pert - - ! ------------------------------------------------------------------ - ! - ! save driver inputs into *ens_prop_inputs.nml file - - if (present(write_nml)) then - - if (write_nml) then - - dir_name = 'rc_out' - file_tag = 'ldas_ensprop_inputs' - file_ext = '.nml' - - fname = get_io_filename( work_path, exp_id, file_tag, date_time=date_time, & - dir_name=dir_name, file_ext=file_ext ) - - if(root_logit) write (logunit,'(400A)') 'writing ens prop inputs to ' // trim(fname) - if(root_logit) write (logunit,*) - - open(10, file=fname, status='unknown', action='write', & - delim='apostrophe') - - write(10, nml=ens_prop_inputs) - - close(10, status='keep') - - end if - - end if - - end subroutine read_ens_prop_inputs - - ! ********************************************************************* - - subroutine check_pert_dtstep( model_dtstep, start_time, end_time, & - N_progn_pert, N_force_pert, progn_pert_dtstep, force_pert_dtstep ) - - ! reichle, 28 May 2013 - - ! all time steps are in *seconds* - - implicit none - - integer, intent(in) :: model_dtstep - - type(date_time_type), intent(in) :: start_time, end_time - - integer, intent(in) :: N_progn_pert, N_force_pert - - integer, intent(in) :: progn_pert_dtstep, force_pert_dtstep - - ! local - character(len=*), parameter :: Iam = 'check_pert_dtstep' - character(len=400) :: err_msg - - ! ----------------------------------------------------------------------- - - if (N_progn_pert>0) then - - if (progn_pert_dtstep<=0) then - err_msg = 'progn_pert time step must be greater than 0' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else if (progn_pert_dtstep>86400) then - err_msg = 'progn_pert time step > 1 day not allowed' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (mod(progn_pert_dtstep,model_dtstep)/=0) then - err_msg = 'progn_pert and model time steps incompatible' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else if (mod(86400,progn_pert_dtstep)/=0) then - err_msg = 'day not evenly divided by progn_pert time step' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! The following checks will eliminate some flexibility in restarting - ! runs "inbetween" prognostics perturbations intervals in order to maintain - ! reproducibility of longer runs regardless of the number and times of restarts. - ! The longest time step in the system dictates the minimum restart interval. - ! - ! Example: If progn_pert_dtstep=10800 seconds, ie, 3 hours, then runs - ! can only be restarted (and end) at 0z, 3z, 6z, ... - - if (mod(start_time%hour*3600+start_time%min*60+start_time%sec, & - progn_pert_dtstep)/=0) then - err_msg = 'progn_pert time step clashes with start_time' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - if (mod(end_time%hour*3600 +end_time%min*60 +end_time%sec, & - progn_pert_dtstep)/=0) then - err_msg = 'Error: progn_pert time step clashes with end_time' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - end if - - if (N_force_pert>0) then - - if (force_pert_dtstep<=0) then - err_msg = 'force_pert time step must be greater than 0' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else if (force_pert_dtstep>86400) then - err_msg = 'force_pert time step > 1 day not allowed' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (mod(force_pert_dtstep,model_dtstep)/=0) then - err_msg = 'force_pert and model time steps incompatible' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else if (mod(86400,force_pert_dtstep)/=0) then - err_msg = 'day not evenly divided by force_pert time step' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! The following checks will eliminate some flexibility in restarting - ! runs "inbetween" forcing perturbations intervals in order to maintain - ! reproducibility of longer runs regardless of the number and times of restarts. - ! The longest time step in the system dictates the minimum restart interval. - ! - ! Example: If force_pert_dtstep=10800 seconds, ie, 3 hours, then runs - ! can only be restarted (and end) at 0z, 3z, 6z, ... - - if (mod(start_time%hour*3600+start_time%min*60+start_time%sec, & - force_pert_dtstep)/=0) then - err_msg = 'force_pert time step clashes with start_time' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - if (mod(end_time%hour*3600 +end_time%min*60 +end_time%sec, & - force_pert_dtstep)/=0) then - err_msg = 'force_pert time step clashes with end_time' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - end if - - end subroutine check_pert_dtstep - - ! ********************************************************************* - function get_pert_grid( tile_grid) result (pert_grid) - - ! reichle, 20 May 2010 - ! jiang, 03/10/2017 - implicit none - - type(grid_def_type), intent(in) :: tile_grid - type(grid_def_type) :: pert_grid - character(len=30) :: latlon_gridname - character(len=6) :: lattmp,lontmp - - type(grid_def_type) :: latlon_grid_tmp - - integer :: n_x,i_off,j_off,n_lon,n_lat - - ! in future implement such that a coarser grid could be used - ! - ! NOTE: must then also modify grid2tile that is used to diagnose - ! perturbations in tile space from gridded perturbations fields - ! (see calls to "grid2tile" in clsm_ensdrv_pert_routines.F90, - ! clsm_ensupd_upd_routines.F90, and clsm_adapt_routines.F90) - - if(index(tile_grid%gridtype,"c3") ==0) then - - ! If *not* cube-sphere tile space, then for perturbations use the grid that - ! defines the tile space (a.k.a. "tile_grid"). E.g., if in EASE grid tile space, - ! the pert grid is the EASE grid. - - pert_grid = tile_grid - - else ! cubed-sphere grid - - ! For cubed-sphere tile space, use a global lat_lon pert grid with a resolution - ! similar to that of the grid that defines the tile space. - - N_x=tile_grid%n_lon - - ! NOTE: The pert grid specification is hard-wired here. - ! If perturbation stddev is heterogeneous input from a file, - ! then the input grid must match this hard-wired grid. (sqz 2/2023) - - n_lon=4*N_x - n_lat=3*N_x - write(lattmp,'(I6.6)') n_lat - write(lontmp,'(I6.6)') n_lon - latlon_gridname = "DE"//lontmp//"x"//"PE"//lattmp - - call LDAS_create_grid_g(latlon_gridname,n_lon,n_lat, latlon_grid_tmp,i_off,j_off) - - pert_grid = latlon_grid_tmp - - endif - - end function get_pert_grid - - ! ********************************************************************* - - ! CHANGED: No longer using apply_force/progn_pert() - ! The GridComp directly calls apply_pert() - - ! ********************************************************************* - - subroutine apply_pert( pert_param, Pert, F, dt, rc ) - - implicit none - - ! apply the perturbation Pert to a 1d field F - ! - ! If the optional argument "dt" is present, Pert is interpreted - ! as a perturbation flux forcing on the field F, and the perturbations - ! are computed as follows: - ! - ! F = F + Pert*dt for additive perturbations - ! F = F * Pert**dt for multiplicative perturbations - ! - ! Note that the units of "dt" must be consistent with those of "Pert". - ! - ! If "dt" is not present, perturbations are computed as follows: - ! - ! F = F + Pert for additive perturbations - ! F = F * Pert for multiplicative perturbations - ! - ! Note that pert_param is a scalar of type pert_param_type, so this - ! subroutine typically appears within a nested loop from 1 through N_pert. - ! - ! reichle, 1 Jun 2005 - ! reichle, 21 Nov 2014 - added optional interpretation of Pert as flux - ! - ! ------------------------------------------------------------------- - - type(pert_param_type), intent(in) :: pert_param - - real, dimension(:), intent(in) :: Pert - - real, dimension(:), intent(inout) :: F - - real, intent(in), optional :: dt - - integer, intent(out), optional :: rc - - ! local variables - - character(len=*), parameter :: Iam = 'apply_pert' - - ! ----------------------------------------------------------- - - _ASSERT(size(Pert)==size(F), "sizes of Pert and perturbed field do not match") - - select case (pert_param%typ) - - case (0) - - if (present(dt)) then - - F = F + Pert*dt - - else - - F = F + Pert - - end if - - case (1) - - if (present(dt)) then - - F = F * Pert**dt - - else - - F = F * Pert - - end if - - case default - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown pert_param%typ') - - end select - - end subroutine apply_pert - - ! ****************************************************************** - - subroutine get_progn_pert_param( pert_grid_l, N_progn_pert, & - progn_pert_param ) - - ! get parameters of perturbations to prognostic variables - ! - ! reichle, 27 Nov 2001 - ! reichle, 31 May 2005 - redesign - - implicit none - - ! --------------------------------------------------------------- - - type(grid_def_type), intent(in) :: pert_grid_l - - integer, intent(out) :: N_progn_pert - - type(pert_param_type), dimension(:), pointer :: progn_pert_param ! output - - ! --------------------------------------------------------------- - - ! local variables - - real, dimension(N_progn_pert_max,pert_grid_l%N_lon,pert_grid_l%N_lat) :: & - std_progn_pert - - character(40), dimension(N_progn_pert_max) :: descr_progn_pert - - logical, dimension(N_progn_pert_max ):: zeromean_progn_pert - logical, dimension(N_progn_pert_max ):: coarsen_progn_pert - - real, dimension(N_progn_pert_max) :: std_normal_max_progn_pert - real, dimension(N_progn_pert_max) :: xcorr_progn_pert, ycorr_progn_pert - real, dimension(N_progn_pert_max) :: tcorr_progn_pert, typ_progn_pert - - real, dimension(N_progn_pert_max,N_progn_pert_max) :: ccorr_progn_pert - - integer, dimension(N_progn_pert_max) :: progn_pert_select - - ! --------------------------------------------------------------- - - call get_progn_pert_inputs( pert_grid_l, & - descr_progn_pert, zeromean_progn_pert, coarsen_progn_pert, & - std_normal_max_progn_pert, std_progn_pert, & - xcorr_progn_pert, ycorr_progn_pert, & - tcorr_progn_pert, typ_progn_pert, ccorr_progn_pert ) - - call get_pert_select( N_progn_pert_max, pert_grid_l, std_progn_pert, & - N_progn_pert, progn_pert_select ) - - - if (N_progn_pert>0) then - - call allocate_pert_param(N_progn_pert, & - pert_grid_l%N_lon,pert_grid_l%N_lat, & - progn_pert_param) - - call assemble_pert_param( N_progn_pert_max, N_progn_pert, pert_grid_l, & - descr_progn_pert, zeromean_progn_pert, coarsen_progn_pert, & - std_normal_max_progn_pert, & - std_progn_pert, xcorr_progn_pert, ycorr_progn_pert, & - tcorr_progn_pert, typ_progn_pert, ccorr_progn_pert, & - progn_pert_select, progn_pert_param ) - - end if - - end subroutine get_progn_pert_param - - ! ********************************************************************** - - subroutine get_force_pert_param( pert_grid_l, N_force_pert, force_pert_param ) - - ! get parameters of forcing perturbations - ! - ! reichle, 27 Nov 2001 - ! reichle, 19 Jul 2005 - - implicit none - - ! --------------------------------------------------------------- - - type(grid_def_type), intent(in) :: pert_grid_l - - integer, intent(out) :: N_force_pert - - type(pert_param_type), dimension(:), pointer :: force_pert_param ! output - - ! --------------------------------------------------------------- - - ! local variables - - real, dimension(N_force_pert_max,pert_grid_l%N_lon,pert_grid_l%N_lat) :: & - std_force_pert - - character(40), dimension(N_force_pert_max) :: descr_force_pert - - logical, dimension(N_force_pert_max ):: zeromean_force_pert - logical, dimension(N_force_pert_max ):: coarsen_force_pert - - real, dimension(N_force_pert_max) :: std_normal_max_force_pert - real, dimension(N_force_pert_max) :: xcorr_force_pert, ycorr_force_pert - real, dimension(N_force_pert_max) :: tcorr_force_pert, typ_force_pert - - real, dimension(N_force_pert_max,N_force_pert_max) :: ccorr_force_pert - - integer, dimension(N_force_pert_max) :: force_pert_select - - ! --------------------------------------------------------------- - - call get_force_pert_inputs( pert_grid_l, & - descr_force_pert, zeromean_force_pert, coarsen_force_pert, & - std_normal_max_force_pert, std_force_pert, & - xcorr_force_pert, ycorr_force_pert, & - tcorr_force_pert, typ_force_pert, ccorr_force_pert ) - - call get_pert_select( N_force_pert_max, pert_grid_l, std_force_pert, & - N_force_pert, force_pert_select ) - - if (N_force_pert>0) then - - call allocate_pert_param(N_force_pert, & - pert_grid_l%N_lon,pert_grid_l%N_lat, & - force_pert_param) - - call assemble_pert_param( N_force_pert_max, N_force_pert, pert_grid_l, & - descr_force_pert, zeromean_force_pert, coarsen_force_pert, & - std_normal_max_force_pert, & - std_force_pert, xcorr_force_pert, ycorr_force_pert, & - tcorr_force_pert, typ_force_pert, ccorr_force_pert, & - force_pert_select, force_pert_param ) - - end if - - end subroutine get_force_pert_param - - ! ********************************************************************** - - subroutine get_force_pert_inputs( pert_grid_l, & - descr_force_pert, zeromean_force_pert, coarsen_force_pert, & - std_normal_max_force_pert, std_force_pert, & - xcorr_force_pert, ycorr_force_pert, & - tcorr_force_pert, typ_force_pert, ccorr_force_pert ) - - ! get inputs for forcing perturbations for ALL forcing - ! variables (including zero standard deviations) on a grid (typically, - ! the subgrid of the tile definition grid that covers the domain, or - ! a coarser version of that) - ! - ! in subroutine() get_pert_select all forcing types with a nonzero - ! standard deviation in at least one grid cell will be included - ! in the forcing perturbations - ! - ! this structure should allow for easy implementation of heterogeneous - ! forcing perturbations std's in the future (in this case the std's would - ! probably be read from a file or modified from a nominal value - ! according to the properties of a given catchment) - ! - ! parameters are obtained from namelist file as structures with - ! fields corresponding to the kinds of forcing perturbations, then - ! moved into straight (multidimensional) arrays for further processing - ! outside of this subroutine - ! - ! reichle, 27 Nov 2001 - ! reichle, 24 Mar 2004 - revised for enkf inputs namelist - ! reichle, 27 May 2005 - redesign - ! reichle+pchakrab, 17 May 2013 - parallelized perturbations - ! EXCEPT I/O of distributed %std, %ccorr - ! - ! --------------------------------------------------------------- - - implicit none - - ! --------------------------------------------------------------- - - type(grid_def_type), intent(in) :: pert_grid_l - - character(40), dimension(N_force_pert_max), intent(out) :: & - descr_force_pert - - logical, dimension(N_force_pert_max), intent(out) :: zeromean_force_pert - logical, dimension(N_force_pert_max), intent(out) :: coarsen_force_pert - - real, & - dimension(N_force_pert_max,pert_grid_l%N_lon,pert_grid_l%N_lat), & - intent(out) :: std_force_pert - - real, dimension(N_force_pert_max), intent(out) :: & - std_normal_max_force_pert, & - xcorr_force_pert, & - ycorr_force_pert, & - tcorr_force_pert, & - typ_force_pert - - real, dimension(N_force_pert_max,N_force_pert_max), intent(out) :: & - ccorr_force_pert - - ! --------------------------------------------------------------- - ! - ! local variables - - integer :: ii, jj - - type(force_pert_real_type) :: tmp_force_pert_real - - type(force_pert_logi_type) :: tmp_force_pert_logical - - type(force_pert_char_type) :: tmp_force_pert_character - - real, dimension(N_force_pert_max) :: tmp_force_pert_vec - - logical, dimension(N_force_pert_max) :: stdfromfile_force_pert - - character(300) :: stdfilename_force_pert - - type(force_pert_ccor_type) :: tmp_force_pert_ccorr - - integer :: ccorr_size - - ! pchakrab: variables for reading NetCDF-4 file - integer :: ivar, iproc ! counters - integer :: nc4_stat ! return code of nc4 function calls - integer :: nc4_id, nc4_grpid, nc4_varid ! various IDs - character( 10) :: nc4_varname - character(300) :: nc4_file - real :: nc4_fillval - - integer :: xstart, xcount, ystart, ycount ! for computing local indices - - ! Errlong variables - character(len=*), parameter :: Iam = 'get_force_pert_inputs' - - ! MPI variables - integer :: mpierr - logical :: root_proc - - ! ----------------------------------------------------------------- - - root_proc = (myid==0) - - ! --------- - ! - ! DESCR - - if (root_proc) then - call read_ens_prop_inputs(kw_echo=.false., & - kw_descr_force_pert=tmp_force_pert_character) - - ! move data from structure into regular vector - - call struct2vec_force_pert(tmp_force_pert_character,descr_force_pert) - endif - - ! for now, broadcast each element of the array descr_force_pert individually - ! TODO: send the array in one MPI_Bcast call - do ii=1,N_force_pert_max - call MPI_Bcast(descr_force_pert(ii), 40, MPI_CHARACTER, 0, mpicomm, mpierr) - end do - - ! ---------- - ! - ! ZEROMEAN - - if (root_proc) then - call read_ens_prop_inputs(kw_echo=.false., & - kw_zeromean_force_pert=tmp_force_pert_logical) - - ! move data from structure into regular vector - - call struct2vec_force_pert(tmp_force_pert_logical,zeromean_force_pert) - end if - - ! broadcast zeromean_force_pert - call MPI_Bcast(zeromean_force_pert, N_force_pert_max, MPI_LOGICAL, 0, mpicomm, mpierr) - - ! ---------- - ! - ! COARSEN - - if (root_proc) then - call read_ens_prop_inputs(kw_echo=.false., & - kw_coarsen_force_pert=tmp_force_pert_logical) - - ! move data from structure into regular vector - - call struct2vec_force_pert(tmp_force_pert_logical,coarsen_force_pert) - end if - - ! broadcast coarsen_force_pert - call MPI_Bcast(coarsen_force_pert, N_force_pert_max, MPI_LOGICAL, 0, mpicomm, mpierr) - - ! ----------------------------------------------------------------- - ! - ! STD - - ! obtain (default) homogeneous std of forcing perturbations - - if (root_proc) then - call read_ens_prop_inputs(kw_echo=.false., & - kw_std_force_pert=tmp_force_pert_real) - - ! move data from structure into regular vector - call struct2vec_force_pert(tmp_force_pert_real, tmp_force_pert_vec) - endif - - ! broadcast tmp_force_pert_vec - call MPI_Bcast(tmp_force_pert_vec, N_force_pert_max, MPI_REAL, 0, mpicomm, mpierr) - - - ! initialize std_force_pert to homogeneous value - - do ivar=1,N_force_pert_max - - std_force_pert(ivar,:,:) = tmp_force_pert_vec(ivar) - - end do - - - ! find out whether std_force_pert should be read from file - - if (root_proc) then - call read_ens_prop_inputs(kw_echo=.false., & - kw_stdfromfile_force_pert=tmp_force_pert_logical) - - ! move data from structure into regular vector - - call struct2vec_force_pert(tmp_force_pert_logical,stdfromfile_force_pert) - end if - - ! broadcast stdfromfile_force_pert - call MPI_Bcast(stdfromfile_force_pert, N_force_pert_max, MPI_LOGICAL, 0, mpicomm, mpierr) - - ! read std_force_pert from file as needed - - if (any(stdfromfile_force_pert)) then - - ! find out name (incl full path) of file with std value - - if (root_proc) & - call read_ens_prop_inputs( & - kw_stdfilename_force_pert = stdfilename_force_pert & - ) - - call MPI_BCAST(stdfilename_force_pert,300,MPI_CHARACTER,0,mpicomm,mpierr) - - nc4_file = stdfilename_force_pert - - ! NOTE: the input file is in netcdf format, with a group 'std_force_pert', - ! and the grid in the netcdf file must be the *global* pert grid - ! (see subroutine get_pert_grid()) - - ! --compute-local-shape-first- - ! ASSUMPTION: data in file are on the *global* pert grid - xstart = pert_grid_l%i_offg + 1 - xcount = pert_grid_l%N_lon - ystart = pert_grid_l%j_offg + 1 - ycount = pert_grid_l%N_lat - - ! pchakrab - 05/13/2014 - ! added reading herterogeneous std_force/progn_pert from file - ! NOTE: With the current version of Baselibs (3.3.3), we cannot - ! read 'in parallel'. So, we let each proc read the file in turn - ! and read *its* data. Once, we transition to Baselibs v4, we will - ! open the file in parallel and read the relevant part of the data - - do iproc=0,numprocs-1 - if (myid==iproc) then - ! open file - nc4_stat = nf90_open(path=nc4_file, mode=NF90_NOWRITE, ncid=nc4_id) - if (nc4_stat /= nf90_noerr) call handle_nc4_stat(nc4_stat) - nc4_stat = nf90_inq_ncid(nc4_id, 'std_force_pert', nc4_grpid) - if (nc4_stat /= nf90_noerr) call handle_nc4_stat(nc4_stat) - do ivar=1,N_force_pert_max - if (stdfromfile_force_pert(ivar)) then - nc4_varname = trim(descr_force_pert(ivar)) - ! id the the ivar-th variable - nc4_stat = nf90_inq_varid(nc4_grpid, nc4_varname, nc4_varid) - if (nc4_stat /= nf90_noerr) call handle_nc4_stat(nc4_stat) - ! read variable for iproc into std_force_pert(ivar,:,:) - ! --read-iproc's-slice-of-data- - nc4_stat = nf90_get_var( & - nc4_grpid, & - nc4_varid, & - values=std_force_pert(ivar,:,:), & - start=(/xstart,ystart/), & - count=(/xcount,ycount/) & - ) - if (nc4_stat /= nf90_noerr) call handle_nc4_stat(nc4_stat) - ! get _FillValue for nc4_varname - nc4_stat = nf90_get_att(nc4_grpid, nc4_varid, '_FillValue', nc4_fillval) - if (nc4_stat /= nf90_noerr) call handle_nc4_stat(nc4_stat) - ! replace _FillValue by zero - where (abs(std_force_pert(ivar,:,:)-nc4_fillval)0) then - - m = m+1 - - pert_param(m)%descr = trim(descr_pert(k)) - - pert_param(m)%zeromean = zeromean_pert(k) - pert_param(m)%coarsen = coarsen_pert( k) - - pert_param(m)%std_normal_max = std_normal_max_pert(k) - - pert_param(m)%std = std_pert(k,:,:) - - pert_param(m)%xcorr = xcorr_pert(k) - pert_param(m)%ycorr = ycorr_pert(k) - pert_param(m)%tcorr = tcorr_pert(k) - pert_param(m)%typ = nint(typ_pert(k)) - - - n = 0 - - do l=1,N_pert_max - - if (pert_select(l)>0) then - - n = n+1 - - pert_param(m)%ccorr(n,:,:) = ccorr_pert(k,l) - - end if - - end do - - - end if - - end do - - ! ------------------------------------------------------------- - ! - ! set mean and (if needed) modify standard deviation according to 'typ' - ! (additive or multiplicative perturbations) - - do m=1,N_pert - - select case (pert_param(m)%typ) - - case (0) ! additive (mean=0, std as above) - - pert_param(m)%mean = 0. - - case (1) ! multiplicative and lognormal (mean=1) - - do i=1,pert_grid_l%N_lon - do j=1,pert_grid_l%N_lat - - tmpreal = pert_param(m)%std(i,j) - - tmpreal = log( 1. + tmpreal**2) - - pert_param(m)%mean(i,j) = - .5*tmpreal - pert_param(m)%std(i,j) = sqrt(tmpreal) - - end do - end do - - case default - - err_msg = 'unknown typ of perturbation' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end do - - ! ------------------------------------------------------------- - ! - ! compute sqrt of correlation matrix for each grid point - - do i=1,pert_grid_l%N_lon - do j=1,pert_grid_l%N_lat - - ! extract local correlation matrix for grid point (i,j) - - do m=1,N_pert - do n=1,N_pert - - tmpmat1(m,n) = pert_param(m)%ccorr(n,i,j) - - end do - end do - - ! compute sqrt of local correlation matrix - - call get_sqrt_corr_matrix( N_pert, tmpmat1, tmpmat2 ) - - ! overwrite cross-correlations in forcepert_param with square - ! root of cross-correlation matrix - - do m=1,N_pert - do n=1,N_pert - - pert_param(m)%ccorr(n,i,j) = tmpmat2(m,n) - - end do - end do - - end do - end do - - end subroutine assemble_pert_param - - - ! ********************************************************************* - - subroutine get_pert_select( N_pert_max, pert_grid_l, std_pert, & - N_pert, pert_select ) - - ! determine which components of the prognostics and forcing perturbations - ! are turned on (as identified through nonzero standard deviation) - ! - ! input: - ! N_pert_max : number of prognostic or forcing perturbation variables - ! - ! output: - ! pert_select : vector of length N_pert_max, components are - ! - zero if ALL grid points have zero perturbation std - ! - one if at least one grid point has nonzero std - ! - ! reichle, 30 Nov 2001 - ! reichle, 27 May 2005 - redesign - ! - ! --------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_pert_max - - type(grid_def_type), intent(in) :: pert_grid_l - - real, & - dimension(N_pert_max,pert_grid_l%N_lon,pert_grid_l%N_lat), & - intent(in) :: std_pert - - integer, intent(out) :: N_pert - - integer, intent(out), dimension(N_pert_max) :: pert_select - - ! --------------------------------------------------------------- - ! - ! local variables - - integer :: k, ierr - - ! --------------------------------------------------------------- - ! - ! record which components of the prognostics/forcings are affected - ! with non-zero error standard deviation - - pert_select(1:N_pert_max) = 0 - - if (pert_grid_l%N_lon * pert_grid_l%N_lat >0) then - do k=1,N_pert_max - if (maxval(std_pert(k,:,:)) >0.) pert_select(k) = 1 - end do - endif - - call MPI_Allreduce(MPI_IN_PLACE, pert_select, N_pert_max , MPI_INTEGER, MPI_MAX, mpicomm, ierr ) - - N_pert = sum( pert_select ) - - end subroutine get_pert_select - - ! ********************************************************************* - - subroutine interpolate_pert_to_timestep( & - date_time, pert_time_old, pert_dtstep_real, & - Pert_old, Pert_new, Pert_ntp ) - - ! Linearly interpolates perturbations to model time step - ! - ! "_old" = at old time - ! "_new" = at new time - ! "_ntp" = at current ("interpolated") time - ! - ! reichle, 26 May 2005 - ! - ! pchakrab, 24 Feb 2015 - using assumed shape arrays - - implicit none - - type(date_time_type), intent(in) :: date_time, pert_time_old - - real, intent(in) :: pert_dtstep_real - - real, dimension(:,:), intent(in) :: Pert_old, Pert_new - - real, dimension(:,:), intent(out) :: Pert_ntp - - ! ---------------- - - ! local variables - - real :: w - - ! ------------------------------------------------------------ - ! - ! weight for interpolation - - w = real(datetime2_minus_datetime1( pert_time_old, date_time )) - - w = w/pert_dtstep_real - - Pert_ntp = (1.-w)*Pert_old + w*Pert_new - - end subroutine interpolate_pert_to_timestep - - ! *********************************************************************** - - subroutine echo_pert_param( N_pert, pert_param, ind_i, ind_j ) - - ! echo pert_param for grid point (ind_i,ind_j) - - implicit none - - integer, intent(in) :: N_pert, ind_i, ind_j - - type(pert_param_type), dimension(:), pointer :: pert_param - - ! locals - - integer :: m, n - - ! ------------------------------------------------------------- - - if (root_logit) then - write (logunit,*) 'echo_pert_param():' - - do m=1,N_pert - - write (logunit,*) 'pert_param(',m,')%descr=', pert_param(m)%descr - write (logunit,*) 'pert_param(',m,')%typ=', pert_param(m)%typ - write (logunit,*) 'pert_param(',m,')%zeromean=', pert_param(m)%zeromean - write (logunit,*) 'pert_param(',m,')%coarsen=', pert_param(m)%coarsen - - write (logunit,*) 'pert_param(',m,')%std_normal_max=', & - pert_param(m)%std_normal_max - write (logunit,*) 'pert_param(',m,')%xcorr=', pert_param(m)%xcorr - write (logunit,*) 'pert_param(',m,')%ycorr=', pert_param(m)%ycorr - write (logunit,*) 'pert_param(',m,')%tcorr=', pert_param(m)%tcorr - - write (logunit,*) 'pert_param(',m,')%mean(',ind_i,',',ind_j,')=', & - pert_param(m)%mean(ind_i,ind_j) - write (logunit,*) 'pert_param(',m,')%std(',ind_i,',',ind_j,')=', & - pert_param(m)%std(ind_i,ind_j) - - do n=1,N_pert - - write (logunit,*) 'pert_param(',m,')%ccorr(',n,',',ind_i,',',ind_j,')=', & - pert_param(m)%ccorr(n,ind_i,ind_j) - - end do - end do - endif ! root_logit - end subroutine echo_pert_param - - !************************************************************* - - ! WY noted :: -l is changed to _g. Only read part was kept - subroutine io_pert_rstrt( action, work_path, exp_id, ens_id, & - date_time, pert_grid_g, pert_grid_f, & - N_force_pert, N_progn_pert, Pert_rseed, & - Force_pert_ntrmdt_g, Progn_pert_ntrmdt_g, rc ) - - ! read or write perturbations re-start file. - ! - ! reichle, 21 Jun 2005 - ! reichle, 16 Oct 2008 - added optional output "rc" (success/failure of read) - ! Weiyuan, 30 Apr 2018 addapt to read into MAPL rst. - implicit none - - character, intent(in) :: action ! read or write - - character(200), intent(in) :: work_path - character(40), intent(in) :: exp_id - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: ens_id, N_force_pert, N_progn_pert - - type(grid_def_type), intent(in) :: pert_grid_g, pert_grid_f - - integer, dimension(NRANDSEED), intent(inout) :: Pert_rseed - - real, dimension(pert_grid_g%N_lon,pert_grid_g%N_lat,N_force_pert), & - intent(inout) :: Force_pert_ntrmdt_g - - real, dimension(pert_grid_g%N_lon,pert_grid_g%N_lat,N_force_pert), & - intent(inout) :: Progn_pert_ntrmdt_g - - integer, intent(out), optional :: rc - - ! local variables - - integer :: n, k, i, j, istat - - integer :: nrandseed_tmp, N_force_pert_tmp, N_progn_pert_tmp - - type(grid_def_type) :: pert_grid_f_tmp - - character(300) :: filename - - character(40) :: file_tag = 'pert_ldas_rst', dir_name='rs', file_ext='.bin' - - ! full array for reading/writing pert ntrmdt - ! while reading, the data is read into Pert_ntrmdt_f and dispersed - ! while writing, the data is assembled into Pert_ntrmdt_f and written - real, dimension(:,:), pointer :: Pert_ntrmdt_f => null() - - character(len=*), parameter :: Iam = 'io_pert_rstrt' - character(len=400) :: err_msg - logical :: file_exists - integer :: itmp,jtmp, xstart,xend, ystart,yend - - ! -------------------------------------------------------------------- - - if (present(rc)) rc = 9999 - - select case (action) - - case ('r','R') - - filename = get_io_filename( work_path, exp_id, & - file_tag, date_time=date_time, & - dir_name=dir_name, ens_id=ens_id, file_ext=file_ext ) - -!!$ if (root_proc) then - inquire(file=filename,exist=file_exists) - if(.not. file_exists) then - write (6,'(400A)') & - 'Warning :: Pert restart file NOT found: ' // trim(filename) - if (present(rc)) rc = 1 - return - endif - - open(10, file=filename, convert='big_endian',form='unformatted', status='old', & - action='read', iostat=istat) -!!$ end if - -!!$#ifdef LDAS_MPI -!!$ ! bcast the status of open (all procs need to return if open fails) -!!$ call MPI_Bcast(istat, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, mpierr) -!!$#endif - -!!$ if (root_proc) then - - write (6,'(400A)') & - 'Reading pert restart file ' // trim(filename) - - ! one additional header line (as of 21 May 2010)!!! - - call io_grid_def_type( 'r', 10, pert_grid_f_tmp ) - - read (10) nrandseed_tmp, N_force_pert_tmp, N_progn_pert_tmp - - ! check whether entries in file match passed arguments - ! (check does *not* include *_pert_param!) - - if ( (nrandseed_tmp /= NRANDSEED) .or. & - (N_force_pert_tmp /= N_force_pert) .or. & - (N_progn_pert_tmp /= N_progn_pert) ) then - err_msg = 'pert.rstrt file not compatible (1)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if ( index(pert_grid_f%gridtype,'LatLon')/=0 .or. & - index(pert_grid_f%gridtype,'LATLON')/=0 .or. & - index(pert_grid_f%gridtype,'latlon')/=0 ) then - - if ( (pert_grid_f_tmp%N_lon /= pert_grid_f%N_lon) .or. & - (pert_grid_f_tmp%N_lat /= pert_grid_f%N_lat) .or. & - (abs(pert_grid_f_tmp%ll_lon - pert_grid_f%ll_lon) > 1e-4) .or. & - (abs(pert_grid_f_tmp%ll_lat - pert_grid_f%ll_lat) > 1e-4) .or. & - (abs(pert_grid_f_tmp%dlon - pert_grid_f%dlon) > 1e-4) .or. & - (abs(pert_grid_f_tmp%dlat - pert_grid_f%dlat) > 1e-4) ) then - err_msg = 'pert.rstrt file not compatible (2)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - else - - if ( index(pert_grid_f_tmp%gridtype,pert_grid_f%gridtype)==0 .or. & - (pert_grid_f_tmp%N_lon /= pert_grid_f%N_lon) .or. & - (pert_grid_f_tmp%N_lat /= pert_grid_f%N_lat) .or. & - (pert_grid_f_tmp%i_offg /= pert_grid_f%i_offg) .or. & - (pert_grid_f_tmp%j_offg /= pert_grid_f%j_offg) ) then - err_msg = 'pert.rstrt file not compatible (3)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - - read (10) (Pert_rseed(n), n=1,NRANDSEED) - - ! allocate memory for full pert ntrmdt array (to be dispersed) - allocate (Pert_ntrmdt_f(pert_grid_f%N_lon, pert_grid_f%N_lat)) - -!!$ endif - - itmp = pert_grid_f%i_offg - xstart = itmp + 1 - xend = itmp + pert_grid_f%N_lon - jtmp = pert_grid_f%j_offg - ystart = jtmp + 1 - yend = jtmp + pert_grid_f%N_lat - - do k=1,N_force_pert - -!!$ if (root_proc) then - read (10) ((Pert_ntrmdt_f(i,j), i=1,pert_grid_f%N_lon), & - j=1,pert_grid_f%N_lat) - - Force_pert_ntrmdt_g(xstart:xend, ystart:yend,k) = Pert_ntrmdt_f(:,:) -!!$ end if -!!$ call scatter_arr2d_grid(pert_grid_f, pert_grid_l, & -!!$ Pert_ntrmdt_f, Force_pert_ntrmdt_l(k,:,:)) -!!$#ifdef LDAS_MPI -!!$ call MPI_Barrier(MPI_COMM_WORLD, mpierr) -!!$#endif - - end do - - do k=1,N_progn_pert - -!!$ if (root_proc) then - read (10) ((Pert_ntrmdt_f(i,j), i=1,pert_grid_f%N_lon), & - j=1,pert_grid_f%N_lat) - Progn_pert_ntrmdt_g(xstart:xend, ystart:yend,k) = Pert_ntrmdt_f(:,:) -!!$ end if -!!$ call scatter_arr2d_grid(pert_grid_f, pert_grid_l, & -!!$ Pert_ntrmdt_f, Progn_pert_ntrmdt_l(k,:,:)) -!!$#ifdef LDAS_MPI -!!$ call MPI_Barrier(MPI_COMM_WORLD, mpierr) -!!$#endif - end do - - deallocate(Pert_ntrmdt_f) - - if (present(rc)) rc = 0 - - - case ('w','W') - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'write part not needed any more') - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown action') - - end select - -!! if (root_proc) close (10,status='keep') - close (10,status='keep') - - end subroutine io_pert_rstrt - - ! ****************************************************************** - - ! handle return code of nf90_* calls - ! stop on error - subroutine handle_nc4_stat(status) - ! input - integer, intent (in) :: status - ! local - character(len=*), parameter :: Iam = 'handle_nc4_stat' - character(len=400) :: err_msg - - if(status /= nf90_noerr) then - err_msg = 'Stopped [' // trim(nf90_strerror(status)) // ']' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - end subroutine handle_nc4_stat - - ! ********************************************************************** - -end module LDAS_PertRoutinesMod - - -! **** EOF ****************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/force_and_cat_progn_pert_types.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/force_and_cat_progn_pert_types.F90 deleted file mode 100644 index 560ddad3..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/force_and_cat_progn_pert_types.F90 +++ /dev/null @@ -1,644 +0,0 @@ - -module force_and_cat_progn_pert_types - - ! types and subroutines in this module are primarily meant to - ! facilitate assembly of force_pert_param and progn_pert_param - ! structures that are the parameter inputs to the generation of - ! perturbations - - ! reichle, 1 Jun 2005 - ! reichle, 6 Dec 2013 - introduced "progn_pert_type" - ! (no longer use "cat_progn_type" for progn perts) - ! reichle, 21 Nov 2014 - renamed force_pert_type fields for consistency w/ met_force_type - ! %tmp2m --> %tair (but note lower-case!) - ! %dpt2m --> %qair (but note lower-case!) - ! %wnd --> %wind (but note lower-case!) - - use catch_constants, ONLY: & - N_gt => CATCH_N_GT - - implicit none - - ! everything is private by default unless made public - - private - - public :: N_force_pert_max - - public :: force_pert_real_type - public :: force_pert_logi_type - public :: force_pert_char_type - - public :: force_pert_ccor_type - - public :: N_progn_pert_max - - public :: progn_pert_real_type - public :: progn_pert_logi_type - public :: progn_pert_char_type - - public :: progn_pert_ccor_type - - public :: struct2vec_force_pert, struct2mat_force_pert_ccor - public :: struct2vec_progn_pert, struct2mat_progn_pert_ccor - - public :: assignment (=) - - ! ---------------------------------------------------------------------- - ! - ! force_pert_type and progn_pert_type are used to gather input data and - ! assemble force_pert_param and progn_pert_param - ! - ! ---------------------------------------------------------------------- - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer :: N_force_pert_max = 6 ! must equal the number of fields below - - type :: force_pert_real_type - - real :: pcp - real :: sw - real :: lw - real :: tair - real :: qair - real :: wind - - end type force_pert_real_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: force_pert_logi_type - - logical :: pcp - logical :: sw - logical :: lw - logical :: tair - logical :: qair - logical :: wind - - end type force_pert_logi_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: force_pert_char_type - - character(40) :: pcp - character(40) :: sw - character(40) :: lw - character(40) :: tair - character(40) :: qair - character(40) :: wind - - end type force_pert_char_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: force_pert_ccor_type - - type(force_pert_real_type) :: pcp - type(force_pert_real_type) :: sw - type(force_pert_real_type) :: lw - type(force_pert_real_type) :: tair - type(force_pert_real_type) :: qair - type(force_pert_real_type) :: wind - - end type force_pert_ccor_type - - - ! -------------------------------------------------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer :: N_progn_pert_max = 5+N_gt ! must equal the number of fields below - - type :: progn_pert_real_type - - real :: catdef - real :: rzexc - real :: srfexc - real :: snow - real :: tc - real, dimension(N_gt) :: ght - - end type progn_pert_real_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: progn_pert_logi_type - - logical :: catdef - logical :: rzexc - logical :: srfexc - logical :: snow - logical :: tc - logical, dimension(N_gt) :: ght - - end type progn_pert_logi_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: progn_pert_char_type - - character(40) :: catdef - character(40) :: rzexc - character(40) :: srfexc - character(40) :: snow - character(40) :: tc - character(40), dimension(N_gt) :: ght - - end type progn_pert_char_type - - ! ----------------------------------------- - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: progn_pert_ccor_type - - type(progn_pert_real_type) :: catdef - type(progn_pert_real_type) :: rzexc - type(progn_pert_real_type) :: srfexc - type(progn_pert_real_type) :: snow - type(progn_pert_real_type) :: tc - type(progn_pert_real_type), dimension(N_gt) :: ght - - end type progn_pert_ccor_type - - ! ---------------------------------------------------------------------- - ! - ! interface definitions - - interface struct2vec_force_pert - module procedure struct2vec_force_pert_real - module procedure struct2vec_force_pert_logi - module procedure struct2vec_force_pert_char - end interface - - ! ----------------------------------------- - - interface struct2vec_progn_pert - module procedure struct2vec_progn_pert_real - module procedure struct2vec_progn_pert_logi - module procedure struct2vec_progn_pert_char - end interface - - ! ----------------------------------------- - - interface assignment (=) - module procedure scalar2force_pert_real - module procedure scalar2force_pert_ccor - - module procedure scalar2progn_pert_real - module procedure scalar2progn_pert_ccor - end interface - - ! ********************************************************************* - -contains - - subroutine struct2vec_force_pert_real(force_pert_struct,force_pert_vec) - - implicit none - - type(force_pert_real_type), intent(in) :: force_pert_struct - - real, dimension(N_force_pert_max), intent(out) :: force_pert_vec - - force_pert_vec(1) = force_pert_struct%pcp - force_pert_vec(2) = force_pert_struct%sw - force_pert_vec(3) = force_pert_struct%lw - force_pert_vec(4) = force_pert_struct%tair - force_pert_vec(5) = force_pert_struct%qair - force_pert_vec(6) = force_pert_struct%wind - - end subroutine struct2vec_force_pert_real - - ! ----------------------------------------- - - subroutine struct2vec_force_pert_logi(force_pert_struct,force_pert_vec) - - implicit none - - type(force_pert_logi_type), intent(in) :: force_pert_struct - - logical, dimension(N_force_pert_max), intent(out) :: force_pert_vec - - force_pert_vec(1) = force_pert_struct%pcp - force_pert_vec(2) = force_pert_struct%sw - force_pert_vec(3) = force_pert_struct%lw - force_pert_vec(4) = force_pert_struct%tair - force_pert_vec(5) = force_pert_struct%qair - force_pert_vec(6) = force_pert_struct%wind - - end subroutine struct2vec_force_pert_logi - - ! ----------------------------------------- - - subroutine struct2vec_force_pert_char(force_pert_struct,force_pert_vec) - - implicit none - - type(force_pert_char_type), intent(in) :: force_pert_struct - - character(40), dimension(N_force_pert_max), intent(out) :: force_pert_vec - - force_pert_vec(1) = force_pert_struct%pcp - force_pert_vec(2) = force_pert_struct%sw - force_pert_vec(3) = force_pert_struct%lw - force_pert_vec(4) = force_pert_struct%tair - force_pert_vec(5) = force_pert_struct%qair - force_pert_vec(6) = force_pert_struct%wind - - end subroutine struct2vec_force_pert_char - - - ! ------------------------------------------------------------------------- - - subroutine struct2mat_force_pert_ccor(force_pert_ccor_struct, & - force_pert_ccor_mat ) - - implicit none - - type(force_pert_ccor_type) :: force_pert_ccor_struct - - real, dimension(N_force_pert_max,N_force_pert_max), intent(out) :: & - force_pert_ccor_mat - - call struct2vec_force_pert( force_pert_ccor_struct%pcp , force_pert_ccor_mat(1,:) ) - call struct2vec_force_pert( force_pert_ccor_struct%sw , force_pert_ccor_mat(2,:) ) - call struct2vec_force_pert( force_pert_ccor_struct%lw , force_pert_ccor_mat(3,:) ) - call struct2vec_force_pert( force_pert_ccor_struct%tair, force_pert_ccor_mat(4,:) ) - call struct2vec_force_pert( force_pert_ccor_struct%qair, force_pert_ccor_mat(5,:) ) - call struct2vec_force_pert( force_pert_ccor_struct%wind, force_pert_ccor_mat(6,:) ) - - end subroutine struct2mat_force_pert_ccor - - ! ------------------------------------------------------------------------- - - subroutine scalar2force_pert_real( force_pert_real, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(force_pert_real_type), intent(out) :: force_pert_real - - force_pert_real%pcp = scalar - force_pert_real%sw = scalar - force_pert_real%lw = scalar - force_pert_real%tair = scalar - force_pert_real%qair = scalar - force_pert_real%wind = scalar - - end subroutine scalar2force_pert_real - - ! ------------------------------------------ - - subroutine scalar2force_pert_ccor( force_pert_ccor, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(force_pert_ccor_type), intent(out) :: force_pert_ccor - - force_pert_ccor%pcp = scalar - force_pert_ccor%sw = scalar - force_pert_ccor%lw = scalar - force_pert_ccor%tair = scalar - force_pert_ccor%qair = scalar - force_pert_ccor%wind = scalar - - end subroutine scalar2force_pert_ccor - - - ! ********************************************************************* - - subroutine struct2vec_progn_pert_real( progn_pert_struct, progn_pert_vec ) - - implicit none - - type(progn_pert_real_type), intent(in) :: progn_pert_struct - - real, dimension(N_progn_pert_max), intent(out) :: progn_pert_vec - - integer :: i - - progn_pert_vec( 1) = progn_pert_struct%catdef - progn_pert_vec( 2) = progn_pert_struct%rzexc - progn_pert_vec( 3) = progn_pert_struct%srfexc - progn_pert_vec( 4) = progn_pert_struct%snow - progn_pert_vec( 5) = progn_pert_struct%tc - - do i=1,N_gt - progn_pert_vec(5+i) = progn_pert_struct%ght(i) - end do - - end subroutine struct2vec_progn_pert_real - - ! ----------------------------------------- - - subroutine struct2vec_progn_pert_logi( progn_pert_struct, progn_pert_vec ) - - implicit none - - type(progn_pert_logi_type), intent(in) :: progn_pert_struct - - logical, dimension(N_progn_pert_max), intent(out) :: progn_pert_vec - - integer :: i - - progn_pert_vec( 1) = progn_pert_struct%catdef - progn_pert_vec( 2) = progn_pert_struct%rzexc - progn_pert_vec( 3) = progn_pert_struct%srfexc - progn_pert_vec( 4) = progn_pert_struct%snow - progn_pert_vec( 5) = progn_pert_struct%tc - - do i=1,N_gt - progn_pert_vec(5+i) = progn_pert_struct%ght(i) - end do - - end subroutine struct2vec_progn_pert_logi - - ! ----------------------------------------- - - subroutine struct2vec_progn_pert_char( progn_pert_struct, progn_pert_vec ) - - implicit none - - type(progn_pert_char_type), intent(in) :: progn_pert_struct - - character(40), dimension(N_progn_pert_max), intent(out) :: progn_pert_vec - - integer :: i - - progn_pert_vec( 1) = progn_pert_struct%catdef - progn_pert_vec( 2) = progn_pert_struct%rzexc - progn_pert_vec( 3) = progn_pert_struct%srfexc - progn_pert_vec( 4) = progn_pert_struct%snow - progn_pert_vec( 5) = progn_pert_struct%tc - - do i=1,N_gt - progn_pert_vec(5+i) = progn_pert_struct%ght(i) - end do - - end subroutine struct2vec_progn_pert_char - - ! ----------------------------------------- - - subroutine struct2mat_progn_pert_ccor( progn_pert_ccor_struct, & - progn_pert_ccor_mat ) - - implicit none - - type(progn_pert_ccor_type), intent(in) :: progn_pert_ccor_struct - - real, dimension(N_progn_pert_max,N_progn_pert_max), intent(out) :: & - progn_pert_ccor_mat - - integer :: i - - call struct2vec_progn_pert( progn_pert_ccor_struct%catdef , progn_pert_ccor_mat( 1,:) ) - call struct2vec_progn_pert( progn_pert_ccor_struct%rzexc , progn_pert_ccor_mat( 2,:) ) - call struct2vec_progn_pert( progn_pert_ccor_struct%srfexc , progn_pert_ccor_mat( 3,:) ) - call struct2vec_progn_pert( progn_pert_ccor_struct%snow , progn_pert_ccor_mat( 4,:) ) - call struct2vec_progn_pert( progn_pert_ccor_struct%tc , progn_pert_ccor_mat( 5,:) ) - - do i=1,N_gt - call struct2vec_progn_pert(progn_pert_ccor_struct%ght(i),progn_pert_ccor_mat(5+i,:) ) - end do - - end subroutine struct2mat_progn_pert_ccor - - ! ----------------------------------------- - - subroutine scalar2progn_pert_real( progn_pert_real, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(progn_pert_real_type), intent(out) :: progn_pert_real - - integer :: i - - progn_pert_real%catdef = scalar - progn_pert_real%rzexc = scalar - progn_pert_real%srfexc = scalar - progn_pert_real%snow = scalar - progn_pert_real%tc = scalar - - do i=1,N_gt - progn_pert_real%ght(i) = scalar - end do - - end subroutine scalar2progn_pert_real - - ! ----------------------------------------- - - subroutine scalar2progn_pert_ccor( progn_pert_ccor, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(progn_pert_ccor_type), intent(out) :: progn_pert_ccor - - integer :: i - - progn_pert_ccor%catdef = scalar - progn_pert_ccor%rzexc = scalar - progn_pert_ccor%srfexc = scalar - progn_pert_ccor%snow = scalar - progn_pert_ccor%tc = scalar - - do i=1,N_gt - progn_pert_ccor%ght(i) = scalar - end do - - end subroutine scalar2progn_pert_ccor - -end module force_and_cat_progn_pert_types - -! ******************************************************************* - -#if 0 - -program test - - use force_and_cat_progn_pert_types - - implicit none - - type(force_pert_real_type) :: force_pert_struct_real - - real, dimension(:), allocatable :: force_pert_vec_real - - type(force_pert_logical_type) :: force_pert_struct_logical - - logical, dimension(:), allocatable :: force_pert_vec_logical - - type(force_pert_character_type) :: force_pert_struct_character - - character(40), dimension(:), allocatable :: force_pert_vec_character - - - - type(force_pert_ccorr_type) :: force_pert_ccorr - - real, dimension(:,:), allocatable :: force_pert_ccorr_mat - - - - !-------------------------------------------------------- - - - allocate(force_pert_vec_real(N_force_pert_max)) - - - force_pert_struct_real%pcp =1. - force_pert_struct_real%sw =2. - force_pert_struct_real%lw =3. - force_pert_struct_real%tair =4. - force_pert_struct_real%qair =5. - force_pert_struct_real%wind =6. - - call struct2vec_force_pert( force_pert_struct_real, force_pert_vec_real) - - write (*,*) force_pert_vec_real - - - allocate(force_pert_vec_logical(N_force_pert_max)) - - - force_pert_struct_logical%pcp =.true. - force_pert_struct_logical%sw =.true. - force_pert_struct_logical%lw =.true. - force_pert_struct_logical%tair =.false. - force_pert_struct_logical%qair =.true. - force_pert_struct_logical%wind =.true. - - call struct2vec_force_pert( force_pert_struct_logical, force_pert_vec_logical) - - write (*,*) force_pert_vec_logical - - allocate(force_pert_vec_character(N_force_pert_max)) - - - force_pert_struct_character%pcp ='1.asdf' - force_pert_struct_character%sw ='2asdf.' - force_pert_struct_character%lw ='3.asdf' - force_pert_struct_character%tair ='4.asdf' - force_pert_struct_character%qair ='5.asdf' - force_pert_struct_character%wind ='6.asdf' - - call struct2vec_force_pert( force_pert_struct_character, force_pert_vec_character) - - write (*,*) force_pert_vec_character - - ! ----------------------------------- - - force_pert_ccorr%pcp%pcp =1. - force_pert_ccorr%pcp%sw =2. - force_pert_ccorr%pcp%lw =3. - force_pert_ccorr%pcp%tair =4. - force_pert_ccorr%pcp%qair =5. - force_pert_ccorr%pcp%wind =6. - - force_pert_ccorr%sw%pcp =10. - force_pert_ccorr%sw%sw =20. - force_pert_ccorr%sw%lw =30. - force_pert_ccorr%sw%tair =40. - force_pert_ccorr%sw%qair =50. - force_pert_ccorr%sw%wind =60. - - force_pert_ccorr%lw%pcp =100. - force_pert_ccorr%lw%sw =200. - force_pert_ccorr%lw%lw =300. - force_pert_ccorr%lw%tair =400. - force_pert_ccorr%lw%qair =500. - force_pert_ccorr%lw%wind =600. - - force_pert_ccorr%tair%pcp =1000. - force_pert_ccorr%tair%sw =2000. - force_pert_ccorr%tair%lw =3000. - force_pert_ccorr%tair%tair =4000. - force_pert_ccorr%tair%qair =5000. - force_pert_ccorr%tair%wind =6000. - - force_pert_ccorr%qair%pcp =10000. - force_pert_ccorr%qair%sw =20000. - force_pert_ccorr%qair%lw =30000. - force_pert_ccorr%qair%tair =40000. - force_pert_ccorr%qair%qair =50000. - force_pert_ccorr%qair%wind =60000. - - force_pert_ccorr%wind%pcp =100000. - force_pert_ccorr%wind%sw =200000. - force_pert_ccorr%wind%lw =300000. - force_pert_ccorr%wind%tair =400000. - force_pert_ccorr%wind%qair =500000. - force_pert_ccorr%wind%wind =600000. - - allocate(force_pert_ccorr_mat(N_force_pert_max,N_force_pert_max)) - - !! force_pert_ccorr = 1.11111 - - call struct2mat_force_pert_ccorr(force_pert_ccorr, & - force_pert_ccorr_mat ) - - - write (*,*) 'force_pert_ccorr=', force_pert_ccorr - - write (*,*) 'force_pert_ccorr_mat=', force_pert_ccorr_mat - - -end program test - - -#endif - -! =============== EOF ================================================ diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/land_pert.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/land_pert.F90 deleted file mode 100644 index ee948e0e..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/land_pert.F90 +++ /dev/null @@ -1,1663 +0,0 @@ -! -! modules to generate land surface perturbations: -! -! module land_pert_types -! module land_pert_routines -! -! can be used to perturb forcing fields such as precipitation and radiation -! or model prognostic variables such as soil moisture or soil temperature -! -! MUST initialize random seed and Pert_ntrmdt by calling -! get_pert() with initialize=.true. at the start of the driver program -! (otherwise set initialize=.false.) -! -! compile line for test program: -! cpp -P -C nr_ran2_gasdev.f90 nr_ran2_gasdev.cpp.f90; cpp -P -C random_fields.f90 random_fields.cpp.f90; cpp -P -C land_pert.f90 land_pert.cpp.f90; f90 nr_ran2_gasdev.cpp.f90 random_fields.cpp.f90 land_pert.cpp.f90 -! -! reichle, 24 Jan 2005 -! reichle, 11 Feb 2005 -! reichle, 26 May 2005 -! reichle, 7 Jun 2005 - more init options -! reichle, 14 Apr 2006 - split land_pert.F90 into 2 files to avoid -! having more than one module per file -! reichle, 8 Aug 2008 - added "logunit" for use within LDASsa -! reichle, 1 Oct 2009 - added "stop_it" for use within LDASsa -! -! ------------------------------------------------------------ - -module land_pert_routines - - use ESMF - - use LDAS_PertTypes, ONLY: & - pert_param_type, & - allocate_pert_param - - use nr_ran2_gasdev, ONLY: & - NRANDSEED, & - init_randseed - - use Random_FieldsMod - use StringRandom_fieldsMapMod - - use nr_jacobi, ONLY: & - jacobi - - use LDAS_TileCoordType, ONLY: & - grid_def_type - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use LDAS_ensdrv_Globals, only: root_logit, logunit - - use MAPL - implicit none - - ! everything is private by default unless made public - - private - - public :: get_pert - public :: propagate_pert - public :: assemble_forcepert_param - public :: get_sqrt_corr_matrix - public :: get_init_Pert_rseed - public :: clear_rf - - ! ********************************************************************** - - type(StringRandom_fieldsMap) :: random_fieldsMap - -contains - - ! ********************************************************************** - - subroutine get_pert( & - N_pert, fft_npert, N_ens, & - pert_grid_l, pert_grid_f, & - dtstep, & - pert_param, & - Pert_rseed, & - Pert_ntrmdt, & - Pert, & - initialize_rseed, & - initialize_ntrmdt, & - diagnose_pert_only ) - - ! get perturbations - ! - ! reichle, 22 Jun 2005 - ! reichle, 17 Jul 2020 - switched order of input arguments pert_grid_f and pert_grid_l - ! for consistency with other subroutines - ! - ! This subroutine unifies subroutines GEOSldas_get_pert() and LDASsa_get_pert(). - ! GEOSldas_get_pert() was used for forcing and prognostics perturbations and did - ! not have an array dimension for ensemble members. - ! LDASsa_get_pert() was used for observations perturbations and included an array - ! dimension for ensemble members (and a call to subroutine adjust_mean()). - ! Otherwise the two subroutines were identical. - ! - wjiang+reichle, 9 Apr 2021 - - - implicit none - - ! N_pert is the number of *perturbation* fields and is not - ! necessarily equal to the number of forcing fields. - ! E.g. generate N_pert=3 perturbations for precip, - ! shortwave radiation, and longwave radiation. These can then be - ! applied to N_force forcing fields, possibly various precip fields - ! (incl large-scale & convective precip and snow) and to radiation - ! fields. - - integer, intent(in) :: N_pert ! # different perturbations - integer, intent(in) :: fft_npert ! # different perturbations for fft; equals n_pert if proc has tiles. - - integer, intent(in) :: N_ens ! # ensemble members - - type(grid_def_type), intent(in) :: pert_grid_l - type(grid_def_type), intent(in) :: pert_grid_f - - real, intent(in) :: dtstep ! perturbation time step in seconds - - ! Parameter structure for perturbations (see type definition for details). - - type(pert_param_type), dimension(:), pointer :: pert_param - - ! Pert_ntrmdt are intermediate perturbation fields - ! that need to be remembered between calls to this subroutine. - ! In essence, they store N_pert mutually uncorrelated - ! perturbation fields of standard-normal distribution. - ! Pert_rseed is the random seed for the generation of - ! Pert_ntrmdt and is treated similarly to a prognostic variable. - ! Each ensemble member has its own random seed. - - integer, dimension(NRANDSEED,N_ens), intent(inout) :: Pert_rseed - - real, dimension(pert_grid_l%N_lon, pert_grid_l%N_lat, N_pert, N_ens), intent(inout) :: Pert_ntrmdt - - ! Pert are N_pert cross-correlated perturbation - ! fields that are rotated and scaled versions of Pert_ntrmdt - ! so that Pert has the the mean values, standard deviations and - ! cross-correlations specified in pert_param. - ! The distribution is lognormal for multiplicative perturbations. - ! Pert should be used as follows for field F (eg. large-scale - ! precip, convective precip, lw radiation, ...) - ! - ! Fprime = F+Pert for additive perturbations - ! Fprime = F*Pert for multiplicative perturbations - ! - ! Note that this subroutine does NOT ensure physically meaningful - ! perturbed fields. This is best done outside this subroutine - ! after the perturbations have been applied. - - real, dimension(pert_grid_l%N_lon, pert_grid_l%N_lat, N_pert, N_ens), intent( out) :: Pert - - ! If initialize_rseed==.true., set initial random seed vector. - ! If initialize_rseed==.true., the first row of Pert_rseed must be - ! filled with a different negative integer for each ensemble member. - ! See sample subroutine get_init_Pert_rseed(). - ! - ! If initialize_ntrmdt==.true., generate initial Pert_ntrmdt (must be - ! allocated!!!). - ! - ! Note that when get_pert() is used for generating independent - ! perturbations to forcings and prognostic variables, only one - ! common Pert_rseed should be used, so one of the "ntrmdt" fields - ! must be initialized without initializing "rseed" again. - - ! If initialize_*==.false. or absent, Pert_rseed and - ! Pert_ntrmdt must be what was obtained as output from the last call - ! to get_pert(). There is only one exception: if there are no temporal - ! correlations, it is not necessary to remember Pert_ntrmdt. - - ! If diagnose_pert_only==.true., Pert_ntrmdt must be available (for - ! example from a restart file) and Pert will then be "diagnosed" from - ! Pert_ntrmdt (and initialize_* must be .false.). - - logical, intent(in), optional :: initialize_rseed - logical, intent(in), optional :: initialize_ntrmdt - - logical, intent(in), optional :: diagnose_pert_only - - ! -------------------------------------------------- - ! - ! local variables - - integer :: i, j, m, mm, n - - real, dimension(pert_grid_l%N_lon, pert_grid_l%N_lat) :: tmp_grid - - real :: tmpreal - - logical :: init_rseed, init_ntrmdt, diagn_only - - character(len=*), parameter :: Iam = 'get_pert' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - ! - ! initialize random seed if necessary - - init_rseed = .false. - init_ntrmdt = .false. - - if (present(initialize_rseed)) init_rseed = initialize_rseed - if (present(initialize_ntrmdt)) init_ntrmdt = initialize_ntrmdt - - if (init_rseed) then - - do n=1,N_ens - - call init_randseed(Pert_rseed(:,n)) - - end do - - end if - - ! ------------------------------------------------------------------ - - diagn_only = .false. - - if (present(diagnose_pert_only)) diagn_only = diagnose_pert_only - - if ( diagn_only .and. (init_rseed .or. init_ntrmdt) ) then - err_msg = 'contradictory optional inputs' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! ------------------------------------------------------------------ - ! - ! Pert_ntrmdt are standard-normal with desired - ! temporal and spatial correlation structure. - ! Cross-correlations between different fields and scaling to desired - ! mean and variance is NOT included in Pert_ntrmdt. - ! - ! Propagate perturbation fields: - ! On input, Pert_ntrmdt must contain fields from last time step. - ! (If init_ntrmdt=.true. Pert_ntrmdt is initialized to a - ! standard-normal field with the desired spatial correlation structure) - - if (.not. diagn_only) & - call propagate_pert( & - fft_npert, N_ens, pert_grid_l, pert_grid_f, & - dtstep, & - Pert_rseed, & - pert_param, & - Pert_ntrmdt, & - init_ntrmdt ) - - ! compute diagnostic "Pert" - - ! ensure that ensemble mean perturbation is zero - ! (must have N_ens>2 for this to make sense). - ! - ! NOTE: since the sample mean model error varies spatially, - ! this adjustment slightly changes the *spatial* mean and - ! covariance of the model error fields - ! likely, the benefits of the adjustments for small - ! ensemble sizes outweigh the disadvantages of altering - ! the statistical properties - - do m=1,N_pert - - if ( (pert_param(m)%zeromean) .and. (N_ens>2)) then - - do i=1,pert_grid_l%N_lon - - call adjust_mean(pert_grid_l%N_lat, N_ens, Pert_ntrmdt(i,:,m,:) ) - - end do - - end if - - end do - - ! compute rotated fields to get desired cross-correlations between - ! different fields, then scale to desired mean and std - - do m=1,N_pert - - do n=1,N_ens - - ! rotate to get desired multivariate correlations - - do j=1,pert_grid_l%N_lat - do i=1,pert_grid_l%N_lon - - tmp_grid(i,j) = 0. - - do mm=1,N_pert - - tmp_grid(i,j) = tmp_grid(i,j) + & - pert_param(m)%ccorr(mm,i,j) * Pert_ntrmdt(i,j,mm,n) - - end do - - end do - end do - - ! scale back freak outliers - - call truncate_std_normal( pert_grid_l%N_lon, pert_grid_l%N_lat, & - pert_param(m)%std_normal_max, tmp_grid ) - - ! scale - - do j=1,pert_grid_l%N_lat - do i=1,pert_grid_l%N_lon - - tmpreal = pert_param(m)%mean(i,j) + & - pert_param(m)%std(i,j) * tmp_grid(i,j) - - select case (pert_param(m)%typ) - - case (0) ! additive - - Pert(i,j,m,n) = tmpreal - - case (1) ! multiplicative and lognormal - - Pert(i,j,m,n) = exp(tmpreal) - - case default - - err_msg = 'encountered unknown typ_pert' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end do - end do - - end do ! end loop through ensemble members (1:N_ens) - end do ! end loop through different fields (1:N_pert) - - end subroutine get_pert - - ! ******************************************************************************* - - subroutine get_init_Pert_rseed( ens_id, init_Pert_rseed ) - - ! get initial random seed "init_Pert_rseed" for initializing - ! Pert_rseed within get_pert() - ! - ! A different random seed is necessary for each ensemble member. - ! - ! This subroutine is meant as a sample for how the initial Pert_rseed - ! can be set. - ! In this example, ens_id is meant to be a nonnegative small integer. - - implicit none - - integer, intent(in) :: ens_id - - integer, intent(out) :: init_Pert_rseed - - ! -------------------------------------------------- - ! - ! local parameter values for initial random seed - - integer, parameter :: RSEED_CONST0 = -1 - integer, parameter :: RSEED_CONST2 = -10 ! must be negative - - ! -------------------------------------------------- - ! - ! local variables - - character(len=*), parameter :: Iam = 'get_init_Pert_rseed' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - init_Pert_rseed = RSEED_CONST0 + ens_id*RSEED_CONST2 - - ! make sure init_Pert_rseed is negative and no two numbers are the same - if (init_Pert_rseed>=0) then - - err_msg = 'found nonnegative component of init_Pert_rseed' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end subroutine get_init_Pert_rseed - - ! ******************************************************************************* - - subroutine propagate_pert( & - N_pert, N_ens, pert_grid_l, pert_grid_f, dtstep, & - Pert_rseed, & - pert_param, & - Pert_ntrmdt, & - initialize ) - - ! generate zero-mean, unit-variance (!!) time series - ! of N_pert 2d perturbation fields - ! - ! can also be used just to get a set of 2d random fields (set dtstep - ! to arbitrary number and "initialize" to .true.) - ! - ! on input, Pert_ntrmdt must contain the corresponding - ! perturbations from the previous time step - ! - ! accounts for temporal correlation with AR(1) approach - ! (if pert_param%tcorr==0 then error is white in time) - ! - ! adapted from off-line EnKF, subroutine propagate_err() - ! from NCAT_59124_tskin in enkf_catchment.f90 - ! - ! reichle, 14 Feb 2005 - - ! This subroutine unifies subroutines GEOSldas_propagate_pert() and LDASsa_propagate_pert(). - ! GEOSldas_propagate_pert() was used for forcing and prognostics perturbations and did - ! not have an array dimension for ensemble members. - ! LDASsa_propagate_pert() was used for observations perturbations and included an array - ! dimension for ensemble members and a call to subroutine adjust_mean(). - ! Otherwise the two subroutines were identical. - ! - wjiang+reichle, 9 Apr 2021 - - implicit none - - ! --------------------------- - - integer, intent(in) :: N_ens, N_pert - - type(grid_def_type), intent(in) :: pert_grid_l, pert_grid_f ! local/full grids - - type(pert_param_type), dimension(N_pert), intent(in) :: pert_param - - real, intent(in) :: dtstep ! time step of generation of error fields [s] - - integer, dimension(NRANDSEED,N_ens), intent(inout) :: Pert_rseed - - real, dimension(pert_grid_l%N_lon, pert_grid_l%N_lat, N_pert, N_ens), & - intent(inout) :: Pert_ntrmdt - - logical, intent(in) :: initialize ! switch - - ! --------------------------- - - ! locals - - ! Depending on the input logical switch pert_param%coarsen, perturbations may - ! be computed on a coarsened grid with spacing automatically determined by - ! - the original perturbation grid spacing, - ! - the spatial correlation scale, and - ! - the following parameter: - - real, parameter :: coarsen_param = 0.8 - - ! Example: For the global SMAP EASEv2 M09 grid with dlon~dlat~0.1 and - ! xcorr=ycorr=0.5, coarsen_param=0.8 results in xstride=ystride=4, - ! which implies that perturbations are effectively computed on - ! the EASEv2 M36 grid. - ! - ! ---------------------- - - integer :: i, j, m, n, Nx, Ny, Nx_fft, Ny_fft, xStride, yStride, imax, jmax - - real :: cc, dd, xCorr, yCorr, tCorr, tmpReal, rdlon, rdlat - - real, dimension(pert_grid_f%N_lon,pert_grid_f%N_lat), target :: rfield, rfield2 - - real, dimension(:,:), pointer :: ptr2rfield, ptr2rfield2 - - logical :: white_in_time, white_in_space, stored_field - - integer :: tmpInt, xstart, xend, ystart, yend - - type(random_fields), pointer :: rf - - type(ESMF_VM) :: vm - integer :: mpicomm, status - - call ESMF_VmGetCurrent(vm, rc=status) - call ESMF_VmGet(vm, mpicommunicator=mpicomm, rc=status) - - do m=1,N_pert - - ! shorthand - - xCorr = pert_param(m)%xcorr - yCorr = pert_param(m)%ycorr - tCorr = pert_param(m)%tcorr - - ! get parameters for temporal correlation - - if ((.not. initialize) .and. (tCorr>0.0)) then - - white_in_time = .false. - cc = exp( - dtstep / tCorr ) - dd = sqrt( 1 - cc**2 ) - else - cc = 0. - dd = 1. - white_in_time = .true. - end if - - ! find out whether there are spatial correlations - if ( (xCorr>0.0) .or. (yCorr>0.0) ) then - white_in_space = .false. - else - white_in_space = .true. - end if - - - ! get grid parameters for generation of new random fields on - ! possibly coarsened grid - - call calc_fft_grid(pert_param(m), pert_grid_f, Nx, Ny, Nx_fft, Ny_fft, xStride, yStride, rdlon, rdlat) - - ptr2rfield => rfield( 1:pert_grid_f%N_lon:xStride,1:pert_grid_f%N_lat:yStride) - ptr2rfield2 => rfield2(1:pert_grid_f%N_lon:xStride,1:pert_grid_f%N_lat:yStride) - - ! generate new random fields and propagate AR(1) - ! - ! Note that rfg2d always produces a pair of random fields! - ! - ! Use logical variable "stored_field" to figure out whether a second - ! standard-normal random field is available for next ensemble member. - ! (in other words, this subroutine is most efficient if N_ens=even - ! number, and it is least efficient if N_ens=1) - - stored_field = .false. - - ! initialize instance rf of class random_fields - ! this needs to be done for each pert field -#ifdef MKL_AVAILABLE - ! W.J Note: hardcoded comm = mpicomm to activate parallel fft - rf => find_rf(Nx, Ny, Nx_fft, Ny_fft, comm=mpicomm ) -#else - rf => find_rf(Nx, Ny, Nx_fft, Ny_fft) -#endif - - do n=1,N_ens - - ! generate a random field - - if (white_in_space) then - - call rf%generate_white_field(Pert_rseed(:,n), ptr2rfield) - - else ! spatially correlated random fields - - ! NOTE: rfg2d_fft() relies on CXML math library (22 Feb 05) - ! rfg2d_fft() now relies on Intel MKL (19 Jun 13) - - if (.not. stored_field) then - call rf%rfg2d_fft(Pert_rseed(:,n), ptr2rfield, ptr2rfield2, xCorr, yCorr, rdlon, rdlat) - stored_field = .true. - else - rfield = rfield2 - stored_field = .false. - end if - - end if - - !! ----------------------------------------------------------- - !! - !! adjust std of fields to match exactly 1.0 - !! - !! WARNING: before doing this should check that - !! N_x*dx>>xcorr .and. N_y*dy>>ycorr .and. N_x*N_y>>1 - !! - !! Cannot use adjust_std if the field is small relative to - !! its spatial correlation scales or if it contains only a few - !! grid cells (even for white noise in space) - !! - !! reichle, 25 Jan 2005 - !! - !! call adjust_std( loc_grid%N_x, loc_grid%N_y, rfield ) - !! - !! ----------------------------------------------------------- - - ! copy to fine grid - - ! [At a later time, perhaps insert bilinear interpolation here. - ! For that, will need rfield grid to extend *beyond* pert_grid_f!] - - do i=1,pert_grid_f%N_lon,xStride - - do j=1,pert_grid_f%N_lat,yStride - - tmpReal = rfield(i,j) - - imax = min( i+xStride-1, pert_grid_f%N_lon ) - jmax = min( j+yStride-1, pert_grid_f%N_lat ) - - rfield(i:imax,j:jmax) = tmpReal - - end do - end do - - ! restrict rfield to local pert grid - if (pert_grid_l%n_lon /=0) then - tmpInt = pert_grid_l%i_offg - pert_grid_f%i_offg - xstart = tmpInt + 1 - xend = tmpInt + pert_grid_l%N_lon - - tmpInt = pert_grid_l%j_offg - pert_grid_f%j_offg - ystart = tmpInt + 1 - yend = tmpInt + pert_grid_l%N_lat - - ! propagate AR(1) - - if (white_in_time) then - Pert_ntrmdt(:,:,m,n) = rfield(xstart:xend, ystart:yend) - else - Pert_ntrmdt(:,:,m,n) = cc*Pert_ntrmdt(:,:,m,n) + dd*rfield(xstart:xend, ystart:yend) - end if - endif - end do ! n=1,N_ens - - ! finalize rf - ! The rf map will be destroyed in the finalize of GEOSLandperp_Gridcomp - !call rf%finalize - - end do ! m=1,N_pert - - end subroutine propagate_pert - - ! ****************************************************************************************** - - subroutine calc_fft_grid(pert_param, pert_grid_f, Nx, Ny, N_x_fft, N_y_fft, xStride, yStride, rdlon, rdlat) - - type(pert_param_type), intent(in) :: pert_param - type(grid_def_type), intent(in) :: pert_grid_f - - integer, intent(out) :: Nx, Ny, N_x_fft, N_y_fft, xStride, yStride - real, intent(out) :: rdlon, rdlat - - ! local variables - - integer :: Nx_fft, Ny_fft - real, parameter :: mult_of_xcorr = 2. - real, parameter :: mult_of_ycorr = 2. - real, parameter :: coarsen_param = 0.8 - real :: xCorr, yCorr - - xCorr = pert_param%xcorr - yCorr = pert_param%ycorr - - xStride = 1 - yStride = 1 - if (pert_param%coarsen) then - xStride = max( 1, floor(coarsen_param * xCorr / pert_grid_f%dlon) ) - yStride = max( 1, floor(coarsen_param * yCorr / pert_grid_f%dlat) ) - endif - rdlon = real(xStride)*pert_grid_f%dlon - rdlat = real(yStride)*pert_grid_f%dlat - - ! NOTE: number of grid cells of coarsened grid might not evenly divide - ! that of pert_grid_f - - Nx = pert_grid_f%N_lon / xStride - Ny = pert_grid_f%N_lat / yStride - - if (mod(pert_grid_f%N_lon,xStride)>0) Nx = Nx + 1 - if (mod(pert_grid_f%N_lat,yStride)>0) Ny = Ny + 1 - - ! add minimum required correlation lengths - Nx_fft = Nx + ceiling(mult_of_xcorr*xCorr/rdlon) - Ny_fft = Ny + ceiling(mult_of_ycorr*yCorr/rdlat) - - ! ensure N_x_fft, N_y_fft are powers of two - N_x_fft = 2**ceiling(log(real(Nx_fft))/log(2.)) - N_y_fft = 2**ceiling(log(real(Ny_fft))/log(2.)) - - end subroutine - - ! ****************************************************************** - - subroutine truncate_std_normal( N_x, N_y, std_normal_max, grid_data ) - - ! truncate a realization of standard normal variables - ! (scale back freak outliers) - - implicit none - - integer, intent(in) :: N_x, N_y - - real, intent(in) :: std_normal_max - - real, dimension(N_x,N_y), intent(inout) :: grid_data - - ! local variables - - integer :: i,j - - ! -------------------------------------------------------- - - do i=1,N_x - do j=1,N_y - - ! want: -std_normal_max < cat_data < std_normal_max - - grid_data(i,j) = & - sign( min(abs(grid_data(i,j)),std_normal_max), grid_data(i,j) ) - - end do - end do - - end subroutine truncate_std_normal - - ! ************************************************************** - - subroutine adjust_mean( N_row, N_col, A, M ) - - ! adjust N_row by N_col matrix A such that - ! mean over columns for each row is given by the - ! corresponding element in vector M of length N_row - ! - ! vector of mean values M is optional input, if not present - ! zero mean is assumed - - implicit none - - integer, intent(in) :: N_row, N_col - - real, intent(inout), dimension(N_row,N_col) :: A - - real, intent(in), optional, dimension(N_row) :: M - - ! ---------------------------- - - ! locals - - integer i - - real, dimension(N_row) :: correction - - ! ------------------------------------------------------------ - - if (present(M)) then - correction = M - sum(A,2)/real(N_col) - else - correction = - sum(A,2)/real(N_col) - end if - - do i=1,N_col - A(:,i) = A(:,i) + correction - end do - - end subroutine adjust_mean - - ! ************************************************************************* - -#if 0 - ! This subroutine is not used. - ! Note that my_matrix_functions.F90 contains another (commented-out) version. - ! wjiang + reichle, 25 Nov 2020 - - subroutine adjust_std( N_row, N_col, A, std ) - - ! adjust N_row by N_col matrix A such that (sample) standard deviation - ! of all elements is exactly equal to std - ! - ! std is optional input, if not present std=1 is assumed - - implicit none - - integer, intent(in) :: N_row, N_col - - real, intent(inout), dimension(N_row,N_col) :: A - - real, intent(in), optional :: std - - ! ---------------------------- - - ! locals - - integer :: i, j - - real :: correction, sample_std - - ! ------------------------------------------------------------ - - ! compute sample std - - call matrix_std( N_row, N_col, A, sample_std ) - - if (present(std)) then - correction = std/sample_std - else - correction = 1./sample_std - end if - - do i=1,N_row - do j=1,N_col - A(i,j) = correction*A(i,j) - end do - end do - - end subroutine adjust_std -#endif - - ! *************************************************************************** - -#if 0 - ! This subroutine is not used. - ! Note that my_matrix_functions.F90 contains other (commented-out) versions. - ! wjiang + reichle, 25 Nov 2020 - - subroutine matrix_std( N_row, N_col, A, std ) - - ! compute std of all elements of N_row by N_col matrix A - - implicit none - - integer, intent(in) :: N_row, N_col - - real, intent(inout), dimension(N_row,N_col) :: A - - real, intent(out) :: std - - ! ---------------------------- - - ! locals - - integer :: i, j - - real :: x2, m, N_real, N_real_minus_one - - ! ------------------------------------------------------------ - - N_real = real(N_row)*real(N_col) - - N_real_minus_one = N_real - 1. - - ! compute sample std - - x2 = 0.0 - m = 0.0 - - do i=1,N_row - do j=1,N_col - m = m + A(i,j) - x2 = x2 + A(i,j)*A(i,j) - end do - end do - - std = sqrt( ( x2 - m**2/N_real )/N_real_minus_one ) - - end subroutine matrix_std -#endif - - ! ***************************************************************** - ! ***************************************************************** - - subroutine assemble_forcepert_param( N_x, N_y, & - N_forcepert, forcepert_param ) - - ! *sample* subroutine that demonstrates how pert_param can be - ! assembled for forcing perturbations - ! - ! THIS SUBROUTINE IS NOT USED IN LDASsa - reichle, 8/8/2008 - ! - ! return N_force_pert, allocate and assemble structure forcepert_param - ! - ! make sure order of fields is compatible with your driver - ! - ! forcing field 1 = precip - ! forcing field 2 = shortwave - ! forcing field 3 = longwave - ! forcing field 4 = air temperature - ! - ! reichle, 11 Feb 2005 - ! reichle, 8 Jun 2005 - - implicit none - - integer, intent(in) :: N_x, N_y - - integer, intent(out) :: N_forcepert - - type(pert_param_type), dimension(:), pointer :: forcepert_param ! out - - ! ----------------------------------------------------------------- - - ! forcing perturbation parameters - - ! # of forcing variables that are perturbed - ! (currently pcp, sw, lw, tair) - - integer, parameter :: N_tmp = 4 - - integer, parameter :: ind_pcp = 1 - integer, parameter :: ind_sw = 2 - integer, parameter :: ind_lw = 3 - integer, parameter :: ind_tair = 4 - - character(40), parameter :: descr_pcp = 'pcp' - character(40), parameter :: descr_sw = 'sw' - character(40), parameter :: descr_lw = 'lw' - character(40), parameter :: descr_tair = 'tair' - - - ! limit on range of random numbers: - ! specify max absolute value allowed to be drawn from a standard - ! normal distribution - - real, parameter :: std_normal_max = 2.5 - - ! decide whether to ensure zero mean for synthetically generated errors - ! (IMPORTANT: this will only have an effect for N_ens>2!!!) - - logical, parameter :: zeromean = .true. - - ! Allow perturbations to be computed on coarsened grid? - ! Coarse grid spacing automatically determined as a function of model - ! grid spacing and spatial correlation scales (see random_fields.F90) - - logical, parameter :: coarsen = .false. - - ! temporal correlation scale - - real, parameter :: tcorr = 10800 ! 86400 ! [s] - - ! horizontal correlation scales - - real, parameter :: xcorr = 0. - real, parameter :: ycorr = 0. - - ! perturbations are either - ! - ! typ=0: additive, mean=0 - ! typ=1: multiplicative and lognormal, mean=1 - - integer, parameter :: typ_pcp = 1 - real, parameter :: std_pcp = .3 - - integer, parameter :: typ_sw = 1 - real, parameter :: std_sw = .15 - - integer, parameter :: typ_lw = 0 - real, parameter :: std_lw = 15. - - integer, parameter :: typ_tair = 0 - real, parameter :: std_tair = 1. - - ! correlation coefficients -1 <= rho <= 1 - ! - ! (these numbers are made up and are not tested with any data!) - - real, parameter :: rho_pcp_sw = -.5 - real, parameter :: rho_pcp_lw = .5 - real, parameter :: rho_pcp_tair = -.3 - real, parameter :: rho_sw_lw = -.5 - real, parameter :: rho_sw_tair = .5 - real, parameter :: rho_lw_tair = .4 - - ! --------------------------------------------------------------------- - ! - ! local variables - - integer :: i, j, k, l - real :: tmpreal - real, dimension(N_tmp,N_tmp) :: tmpmat1, tmpmat2 - - ! --------------------------------------------------------------------- - ! - ! allocate forcepert_param (must not be associated at this time) - - if (associated(forcepert_param)) then - write (*,*) 'assemble_forcepert_param(): this needs work...' - write (*,*) 'stopping' - stop - end if - - N_forcepert = N_tmp - - call allocate_pert_param(N_forcepert, N_x, N_y, forcepert_param) - - ! ---------------------------------------- - ! - ! copy inputs into structure - - ! precip perturbations - - forcepert_param(ind_pcp)%descr = descr_pcp - forcepert_param(ind_pcp)%typ = typ_pcp - forcepert_param(ind_pcp)%std_normal_max = std_normal_max - forcepert_param(ind_pcp)%zeromean = zeromean - forcepert_param(ind_pcp)%coarsen = coarsen - forcepert_param(ind_pcp)%tcorr = tcorr - forcepert_param(ind_pcp)%xcorr = xcorr - forcepert_param(ind_pcp)%ycorr = ycorr - - forcepert_param(ind_pcp)%std = std_pcp - - forcepert_param(ind_pcp)%ccorr(1,:,:) = 1. - forcepert_param(ind_pcp)%ccorr(2,:,:) = rho_pcp_sw - forcepert_param(ind_pcp)%ccorr(3,:,:) = rho_pcp_lw - forcepert_param(ind_pcp)%ccorr(4,:,:) = rho_pcp_tair - - ! shortwave perturbations - - forcepert_param(ind_sw)%descr = descr_sw - forcepert_param(ind_sw)%typ = typ_sw - forcepert_param(ind_sw)%std_normal_max = std_normal_max - forcepert_param(ind_sw)%zeromean = zeromean - forcepert_param(ind_sw)%coarsen = coarsen - forcepert_param(ind_sw)%tcorr = tcorr - forcepert_param(ind_sw)%xcorr = xcorr - forcepert_param(ind_sw)%ycorr = ycorr - - forcepert_param(ind_sw)%std = std_sw - - forcepert_param(ind_sw)%ccorr(1,:,:) = rho_pcp_sw - forcepert_param(ind_sw)%ccorr(2,:,:) = 1. - forcepert_param(ind_sw)%ccorr(3,:,:) = rho_sw_lw - forcepert_param(ind_sw)%ccorr(4,:,:) = rho_sw_tair - - ! longwave perturbations - - forcepert_param(ind_lw)%descr = descr_lw - forcepert_param(ind_lw)%typ = typ_lw - forcepert_param(ind_lw)%std_normal_max = std_normal_max - forcepert_param(ind_lw)%zeromean = zeromean - forcepert_param(ind_lw)%coarsen = coarsen - forcepert_param(ind_lw)%tcorr = tcorr - forcepert_param(ind_lw)%xcorr = xcorr - forcepert_param(ind_lw)%ycorr = ycorr - - forcepert_param(ind_lw)%std = std_lw - - forcepert_param(ind_lw)%ccorr(1,:,:) = rho_pcp_lw - forcepert_param(ind_lw)%ccorr(2,:,:) = rho_sw_lw - forcepert_param(ind_lw)%ccorr(3,:,:) = 1. - forcepert_param(ind_lw)%ccorr(4,:,:) = rho_lw_tair - - ! air temperature perturbations - - forcepert_param(ind_tair)%descr = descr_tair - forcepert_param(ind_tair)%typ = typ_tair - forcepert_param(ind_tair)%std_normal_max = std_normal_max - forcepert_param(ind_tair)%zeromean = zeromean - forcepert_param(ind_tair)%coarsen = coarsen - forcepert_param(ind_tair)%tcorr = tcorr - forcepert_param(ind_tair)%xcorr = xcorr - forcepert_param(ind_tair)%ycorr = ycorr - - forcepert_param(ind_tair)%std = std_tair - - forcepert_param(ind_tair)%ccorr(1,:,:) = rho_pcp_tair - forcepert_param(ind_tair)%ccorr(2,:,:) = rho_sw_tair - forcepert_param(ind_tair)%ccorr(3,:,:) = rho_lw_tair - forcepert_param(ind_tair)%ccorr(4,:,:) = 1. - - ! ------------------------------------------------------------- - ! - ! set mean and (if needed) modify standard deviation according to 'typ' - ! (additive or multiplicative perturbations) - - do k=1,N_forcepert - - select case (forcepert_param(k)%typ) - - case (0) ! additive (mean=0, std as above) - - forcepert_param(k)%mean = 0. - - case (1) ! multiplicative and lognormal (mean=1) - - do i=1,N_x - do j=1,N_y - - tmpreal = forcepert_param(k)%std(i,j) - - tmpreal = log( 1. + tmpreal**2) - - forcepert_param(k)%mean(i,j) = - .5*tmpreal - forcepert_param(k)%std(i,j) = sqrt(tmpreal) - - end do - end do - - case default - - write (*,*) 'assemble_forcepert_param(): encountered unknown' - write (*,*) 'type of error, stopping...' - stop - - end select - - end do - - - - ! echo part of forcepert_param (mean, std, and ccorr for i=1, j=1 only): - if(root_logit) then - do i=1,N_forcepert - - write (logunit,*) 'forcepert_param(',i,')%descr=', & - forcepert_param(i)%descr - write (logunit,*) 'forcepert_param(',i,')%typ=', & - forcepert_param(i)%typ - write (logunit,*) 'forcepert_param(',i,')%zeromean=', & - forcepert_param(i)%zeromean - write (logunit,*) 'forcepert_param(',i,')%coarsen=', & - forcepert_param(i)%coarsen - write (logunit,*) 'forcepert_param(',i,')%std_normal_max=', & - forcepert_param(i)%std_normal_max - write (logunit,*) 'forcepert_param(',i,')%xcorr=', & - forcepert_param(i)%xcorr - write (logunit,*) 'forcepert_param(',i,')%ycorr=', & - forcepert_param(i)%ycorr - write (logunit,*) 'forcepert_param(',i,')%tcorr=', & - forcepert_param(i)%tcorr - - write (logunit,*) 'forcepert_param(',i,')%mean(1,1)=', & - forcepert_param(i)%mean(1,1) - write (logunit,*) 'forcepert_param(',i,')%std(1,1)=', & - forcepert_param(i)%std(1,1) - - do j=1,N_forcepert - - write (logunit,*) 'forcepert_param(',i,')%ccorr(',j,',1,1)=', & - forcepert_param(i)%ccorr(j,1,1) - end do - end do - endif ! root_logit - - - - - ! ------------------------------------------------------------- - ! - ! compute sqrt of correlation matrix for each grid point - - do i=1,N_x - do j=1,N_y - - ! extract local correlation matrix for grid point (i,j) - - do k=1,N_forcepert - do l=1,N_forcepert - - tmpmat1(k,l) = forcepert_param(k)%ccorr(l,i,j) - - end do - end do - - ! compute sqrt of local correlation matrix - - call get_sqrt_corr_matrix( N_forcepert, tmpmat1, tmpmat2 ) - - ! overwrite cross-correlations in forcepert_param with square - ! root of cross-correlation matrix - - do k=1,N_forcepert - do l=1,N_forcepert - - forcepert_param(k)%ccorr(l,i,j) = tmpmat2(k,l) - - end do - end do - - end do - end do - - end subroutine assemble_forcepert_param - - ! ************************************************************************ - -#if 0 - subroutine get_sqrt_corr_matrix( N, rho12, rho13, rho23, A ) - - ! get sqrt of correlation matrix - ! - ! correlation matrix has diagonal=variance=1 - ! - ! corr_matrix = [ 1 rho12 rho13; rho12 1 rho23; rho13 rho23 1 ] - ! - ! A is lower tri-angular - ! - ! A = sqrt_corr_matrix = [ a11 0 0; a12 a22 0; a13 a23 a33 ] - ! - ! A*transpose(A) = corr_matrix - ! - ! so far only implemented for 3-by-3 correlation matrices with all - ! nonnegative eigenvalues (no check for eigenvalues!) - ! - ! reichle, 25 Jan 2005 - - implicit none - - integer, intent(in) :: N - real, intent(in) :: rho12, rho13, rho23 - - real, intent(out), dimension(N,N) :: A - - ! ------------------------------------------------------------------ - - if (N/=3) then - - write (*,*) 'get_sqrt_corr_matrix() not implemented for N<=3' - - else - - A(3,3) = 1. - rho12*rho12 ! temporary - - A(1,1) = 1. - - A(1,2) = 0. - A(2,1) = rho12 - - A(2,2) = sqrt(A(3,3)) - - A(1,3) = 0. - A(3,1) = rho13 - A(2,3) = 0. - A(3,2) = (rho23-rho12*rho13)/A(2,2) - - A(3,3) = & - sqrt( & - (A(3,3) - rho13*rho13 - rho23*rho23 + 2*rho12*rho13*rho23) & - / & - A(3,3) ) - - end if - - end subroutine get_sqrt_corr_matrix -#endif - - ! ************************************************************************ - - subroutine get_sqrt_corr_matrix( N, A, S ) - - ! get sqrt S of real, symmetric (correlation) matrix A - ! - ! NOTE: there is no check that A is indeed symmetric! - ! - ! A = S*transpose(S) - ! - ! reichle, 7 Jun 2005 - - implicit none - - integer, intent(in) :: N - real, intent(in), dimension(N,N) :: A - real, intent(out), dimension(N,N) :: S - - ! local - - integer :: j - - real, dimension(N) :: D - - character(len=*), parameter :: Iam = 'get_sqrt_corr_matrix' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - - call jacobi(A,N,D,S) - - do j=1,N - - if (D(j)<0.) then - err_msg = 'negative eigenvalue found, invalid corr matrix' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - S(:,j) = S(:,j)*sqrt(D(j)) - - end do - - end subroutine get_sqrt_corr_matrix - - ! ************************************************************************ - - function find_rf(Nx, Ny, Nx_fft, Ny_fft, comm) result (rf) - - type(random_fields), pointer :: rf - integer, intent(in) :: Nx, Ny, Nx_fft, Ny_fft - integer, optional, intent(in) :: comm - - ! local variables - - type(StringRandom_fieldsMapIterator) :: iter - Character(len=:), allocatable :: id_string - type(random_fields) :: rf_tmp - - id_string = i_to_string(Nx)//":"//i_to_string(Ny)//":"//i_to_string(Nx_fft)//":"//i_to_string(Ny_fft) - iter = random_fieldsMap%find(id_string) - if (iter == random_fieldsMap%end() ) then - rf_tmp = random_fields(Nx, Ny, Nx_fft, Ny_fft, comm=comm) - call random_fieldsMap%insert(id_string, rf_tmp) - iter = random_fieldsMap%find(id_string) - endif - rf => iter%value() - - end function find_rf - - ! ************************************************************************ - - subroutine clear_rf() - - type(StringRandom_fieldsMapIterator) :: iter - type(random_fields), pointer :: rf_ptr - - iter = random_fieldsMap%begin() - do while (iter /= random_fieldsMap%end()) - rf_ptr => iter%value() - call rf_ptr%finalize() - ! remove the files - call random_fieldsMap%erase(iter) - iter = random_fieldsMap%begin() - enddo - end subroutine clear_rf - - -end module land_pert_routines - -! *************************************************************************** -! *************************************************************************** - -#if 0 - -program test - - ! test land_pert_types - - use land_pert_types - - implicit none - - integer :: i, j, k, l, Nx=4, Ny=2, Nf=3 - - type(pert_param_type), dimension(:), pointer :: pp - - character(40) :: tmpstr - - ! -------------------------------------------------------------------- - - nullify(pp) - - call allocate_pert_param(Nf, Nx, Ny, pp) - - ! assemble - - do k=1,Nf - - write (tmpstr,'(i4.4)') k - - tmpstr = 'descr' // trim(tmpstr) - - pp(k)%descr = tmpstr - - do i=1,Nx - do j=1,Ny - - pp(k)%mean(i,j) = k**2 - - do l=1,Nf - pp(k)%ccorr(l,i,j) = real(i*j)/real(k*l) - end do - - end do - end do - - end do - - ! write - - do k=1,Nf - - write (*,*) pp(k)%descr - do i=1,Nx - write (*,*) pp(k)%mean(i,:) - end do - write (*,*) 'ccorr', k - do i=1,Nx - do j=1,Ny - write (*,*) (pp(k)%ccorr(l,i,j), l=1,Nf) - end do - end do - - end do - -end program test - -#endif - -! ------------------------------------------------------------- - -#if 0 - -program test - - use land_pert_routines - use land_pert_types - use nr_jacobi - - implicit none - - integer, parameter :: N = 3 - - real, dimension(N,N) :: A, V, S - - real, dimension(N) :: D - - integer :: i,j - - ! ------------------------------------------------ - - A(1,1) = 1. - A(1,2) = -.8 - A(1,3) = .5 - A(2,2) = 1. - A(2,3) = -.5 - A(3,3) = 1. - A(2,1) = A(1,2) - A(3,2) = A(2,3) - A(3,1) = A(1,3) - - - do i=1,N - write (*,*) A(i,:) - end do - - call jacobi(A,N,D,V) - - do i=1,N - write (*,*) A(i,:) - end do - - do i=1,N - write (*,*) V(i,:) - end do - - write (*,*) D - - - call get_sqrt_corr_matrix(N,A,S) - - do i=1,N - write (*,*) S(i,:) - end do - - call get_sqrt_corr_matrix(1,A(1,3),S(1,1)) - - write (*,*) S(1,1) - - call get_sqrt_corr_matrix(2,A(1:2,1:2),S(1:2,1:2)) - - do i=1,2 - write (*,*) S(i,1:2) - end do - -end program test - -#endif - -! ------------------------------------------------------------------ - -#if 0 - -program test - - ! driver routine for testing subroutine precip_rad_perturb() - - ! ifort clsm_ensdrv_glob_param.o random_fields.F90 land_pert_types.o nr_ran2_gasdev.o nr_jacobi.o nr_fft.o land_pert.F90 - - ! reichle, 24 Jan 2005 - ! reichle, 16 Feb 2005 - ! reichle, 3 Dec 2013 - updated to new interface of get_pert() - - ! reichle, 9 Apr 2021 - adapted to new order of array dimensions in pert fields after unification of get_pert() - ! and propagate_pert(). MAY NEED MORE WORK!!! - - ! ------------------------------------------------------------ - - use land_pert_routines - use land_pert_types - use nr_ran2_gasdev - use tile_coord_types, ONLY: grid_def_type - - - implicit none - - integer, parameter :: N_ens = 30 - integer, parameter :: N_x = 4 - integer, parameter :: N_y = 8 - - integer, parameter :: N_domain = 1 - - integer :: N_t, i, j, tt, n, N_forcepert - - real :: dx, dy, dtstep - - integer, dimension(N_ens,N_domain) :: init_Pert_rseed - integer, dimension(N_ens) :: ens_id - integer, dimension(N_domain) :: domain_id - - integer, dimension(:,:), allocatable :: Forcepert_rseed - - real, dimension(:,:,:,:), allocatable :: Forcepert - real, dimension(:,:,:,:), allocatable :: Forcepert_ntrmdt - - type(pert_param_type), dimension(:), pointer :: forcepert_param - - type(grid_def_type) :: pert_grid - - ! ----------------------------------------- - - nullify(forcepert_param) - - write (*,*) NRANDSEED - - dx = 2.5 - dy = 2. - - dtstep = 1800. - - N_t = 1000 - - ! open files for output - - open(991, file='tmp_precip.dat', form='formatted', status='unknown', & - action='write') - open(992, file='tmp_swdn.dat', form='formatted', status='unknown', & - action='write') - open(993, file='tmp_lwdn.dat', form='formatted', status='unknown', & - action='write') - open(994, file='tmp_tair.dat', form='formatted', status='unknown', & - action='write') - - ! initialize - - call assemble_forcepert_param(N_x, N_y, N_forcepert, forcepert_param) - - ! echo part of forcepert_param (mean, std, and ccorr for i=1, j=1 only): - - do i=1,N_forcepert - - write (*,*) 'forcepert_param(',i,')%descr=', & - forcepert_param(i)%descr - write (*,*) 'forcepert_param(',i,')%typ=', & - forcepert_param(i)%typ - write (*,*) 'forcepert_param(',i,')%zeromean=', & - forcepert_param(i)%zeromean - write (*,*) 'forcepert_param(',i,')%coarsen=', & - forcepert_param(i)%coarsen - write (*,*) 'forcepert_param(',i,')%std_normal_max=', & - forcepert_param(i)%std_normal_max - write (*,*) 'forcepert_param(',i,')%xcorr=', & - forcepert_param(i)%xcorr - write (*,*) 'forcepert_param(',i,')%ycorr=', & - forcepert_param(i)%ycorr - write (*,*) 'forcepert_param(',i,')%tcorr=', & - forcepert_param(i)%tcorr - - write (*,*) 'forcepert_param(',i,')%mean(1,1)=', & - forcepert_param(i)%mean(1,1) - write (*,*) 'forcepert_param(',i,')%std(1,1)=', & - forcepert_param(i)%std(1,1) - - do j=1,N_forcepert - - write (*,*) 'forcepert_param(',i,')%ccorr(',j,',1,1)=', & - forcepert_param(i)%ccorr(j,1,1) - - end do - - end do - - ! ------------------------------------------------------------------- - - allocate(Forcepert_rseed(NRANDSEED,N_ens)) - - allocate(Forcepert_ntrmdt(N_x,N_y,N_forcepert,N_ens)) - allocate(Forcepert( N_x,N_y,N_forcepert,N_ens)) - - Forcepert_ntrmdt = 0. ! initialize just in case (should not be needed) - Forcepert = 0. ! initialize just in case (should not be needed) - - do n=1,N_ens - ens_id(n) = n-1 - end do - - do n=1,N_domain - domain_id(n) = n - end do - - ! get different negative integer for each ensemble member and - ! each domain - - !call get_init_Pert_rseed( N_ens, N_domain, ens_id, domain_id, & - ! init_Pert_rseed ) - call get_init_Pert_rseed( N_ens, ens_id, domain_id, init_Pert_rseed ) - - - ! initialize first row of Forcepert_rseed (for first domain) - - Forcepert_rseed(1,:) = init_Pert_rseed( :, 1) - - ! initial call to get_pert (for first domain) - ! - ! this initializes Forcepert_ntrmdt and the rest of Forcepert_rseed - ! - ! NOTE: after initial call to get_pert use restart files - ! for Forcepert_rseed and Forcepert_ntrmdt to continue - ! the perturbation time series whenever the land model - ! integration is interrupted - - pert_grid%N_lon = N_x - pert_grid%N_lat = N_y - pert_grid%dlon = dx - pert_grid%dlat = dy - - call get_pert( & - N_forcepert, N_ens, pert_grid, & - pert_grid, dtstep, & - forcepert_param, & - Forcepert_rseed, & - Forcepert_ntrmdt, & - Forcepert, & - initialize_rseed=.true., & - initialize_ntrmdt=.true. ) - - - write (*,*) 'Forcepert_rseed=', Forcepert_rseed - - ! output - - do i=1,N_forcepert - - write (990+i, '(3312(e13.5))') Forcepert(:,:,i,:) - - end do - - write (*,*) Forcepert(:,1,1,1) - - ! loop through time - - do tt=1,N_t - - call get_pert( & - N_forcepert, N_ens, pert_grid, & - pert_grid, dtstep, & - forcepert_param, & - Forcepert_rseed, & - Forcepert_ntrmdt, & - Forcepert ) - - ! output - - do i=1,N_forcepert - - write (990+i, '(3312(e13.5))') Forcepert(:,:,i,:) - - end do - - write (*,*) Forcepert(:,1,1,1) - - end do - -end program test - -#endif - -! =============== EOF ================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_fft.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_fft.F90 deleted file mode 100644 index 626d68c3..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_fft.F90 +++ /dev/null @@ -1,106 +0,0 @@ - -! adapted from f77 Numerical Recipes -! -! reichle, 8 Jun 2005 -! -! ----------------------------------------------------------------- - -module nr_fft - - implicit none - - private - - public :: fourn - -contains - - SUBROUTINE fourn(data,nn,ndim,isign) - - ! Replaces data by its ndim-dimensional discrete Fourier transform, - ! if isign is input as 1. nn(1:ndim) is an integer array containing the - ! lengths of each dimension (number of complex values), which MUST all - ! be powers of 2. data is a real array of length twice the - ! product of these lengths, in which the data are stored as in a - ! multidimensional complex FORTRAN array. If isign is input as -1, - ! data is replaced by its inverse transform times - ! the product of the lengths of all dimensions. - - INTEGER isign,ndim,nn(ndim) - REAL data(*) - INTEGER i1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2,ip3,k1, & - k2,n,nprev,nrem,ntot - REAL tempi,tempr - DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp - ntot=1 - do idim=1,ndim - ntot=ntot*nn(idim) - end do - nprev=1 - do idim=1,ndim - n=nn(idim) - nrem=ntot/(n*nprev) - ip1=2*nprev - ip2=ip1*n - ip3=ip2*nrem - i2rev=1 - do i2=1,ip2,ip1 - if(i2.lt.i2rev)then - do i1=i2,i2+ip1-2,2 - do i3=i1,ip3,ip2 - i3rev=i2rev+i3-i2 - tempr=data(i3) - tempi=data(i3+1) - data(i3)=data(i3rev) - data(i3+1)=data(i3rev+1) - data(i3rev)=tempr - data(i3rev+1)=tempi - end do - end do - end if - ibit=ip2/2 -1 if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then - i2rev=i2rev-ibit - ibit=ibit/2 - goto 1 - end if - i2rev=i2rev+ibit - end do - ifp1=ip1 -2 if(ifp1.lt.ip2)then - ifp2=2*ifp1 - theta=isign*6.28318530717959d0/(ifp2/ip1) - wpr=-2.d0*sin(0.5d0*theta)**2 - wpi=sin(theta) - wr=1.d0 - wi=0.d0 - do i3=1,ifp1,ip1 - do i1=i3,i3+ip1-2,2 - do i2=i1,ip3,ifp2 - k1=i2 - k2=k1+ifp1 - tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1) - tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2) - data(k2)=data(k1)-tempr - data(k2+1)=data(k1+1)-tempi - data(k1)=data(k1)+tempr - data(k1+1)=data(k1+1)+tempi - end do - end do - wtemp=wr - wr=wr*wpr-wi*wpi+wr - wi=wi*wpr+wtemp*wpi+wi - end do - ifp1=ifp2 - goto 2 - endif - nprev=n*nprev - end do - return - END SUBROUTINE fourn - -end module nr_fft - - -! ========================== EOF ================================ - diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_jacobi.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_jacobi.F90 deleted file mode 100644 index 80902f62..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_jacobi.F90 +++ /dev/null @@ -1,243 +0,0 @@ - -module nr_jacobi - - ! Jacobi transformation - ! - ! adapted from f77 Numerical Recipes by reichle, 7 Jun 2005 - - implicit none - - private - - public :: jacobi - -contains - - subroutine jacobi(amat,n,d,v,nrot) - - ! Computes all eigenvalues and eigenvectors of a real symmetric matrix - ! amat, which is of size n by n. The vector d returns the - ! eigenvalues of amat in its first n elements. v is a matrix with the same - ! dimensions as amat, whose columns contain, on output, - ! the normalized eigenvectors of amat. nrot returns the number of Jacobi - ! rotations that were required. - - ! The Jacobi method is absolutely foolproof for all real symmetric - ! matrices. For matrices of order greater than about 10, say, the - ! algorithm is slower, by a significant constant factor, than the QR - ! method. However, the Jacobi algorithm is much simpler than - ! the more efficient methods. We thus recommend it for matrices of - ! moderate order, where expense is not a major consideration. - - ! Eigenvector decomposition: - ! - ! Amat = V*diag(D)*transpose(V) - - integer, intent(in) :: n - real, dimension(n,n), intent(in) :: amat - real, dimension(n,n), intent(out) :: v - real, dimension(n), intent(out) :: d - integer, intent(out), optional :: nrot - - ! local variables - - integer :: i,ip,iq,j - - real :: c, g, h, s, sm, t, tau, theta, tresh - - real, dimension(n,n) :: a - real, dimension(n) :: b, z - - ! ------------------------------------------------------------ - ! - ! make sure this is not used for large matrices - ! (comment out this block if you want to apply nr_jacobi to - ! large matrices) - - if (n>100) then - write (*,*) 'nr_jacobi(): Jacobi not efficient for large matrices' - write (*,*) 'use of QR factorization suggested' - write (*,*) 'STOPPING.' - stop - end if - - ! initialize temporary matrix a - - a = amat - - ! Initialize to the identity matrix. - - do ip=1,n - do iq=1,n - v(ip,iq)=0. - end do - v(ip,ip)=1. - end do - - ! Initialize b and d to the diagonal of a. - ! The vector z will accumulate terms of the form ta(p,q) - ! as in equation (11.1.14). - - do ip=1,n - b(ip)=a(ip,ip) - d(ip)=b(ip) - z(ip)=0. - end do - if (present(nrot)) nrot=0 - do i=1,50 - sm=0. - do ip=1,n-1 ! Sum off-diagonal elements. - do iq=ip+1,n - sm=sm+abs(a(ip,iq)) - end do - end do - - ! normal return (relies on quadratic convergence to machine underflow. - - if(sm.eq.0.) & - return - - if(i.lt.4)then - tresh=0.2*sm/n**2 ! ...on first three sweeps - else - tresh=0. ! ...thereafter - end if - do ip=1,n-1 - do iq=ip+1,n - g=100.*abs(a(ip,iq)) - if((i.gt.4).and.(abs(d(ip))+ & - g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then - a(ip,iq)=0. - else if (abs(a(ip,iq)).gt.tresh)then - h=d(iq)-d(ip) - if(abs(h)+g.eq.abs(h))then - t=a(ip,iq)/h - else - theta=0.5*h/a(ip,iq) - t=1./(abs(theta)+sqrt(1.+theta**2)) - if(theta.lt.0.)t=-t - end if - c=1./sqrt(1+t**2) - s=t*c - tau=s/(1.+c) - h=t*a(ip,iq) - z(ip)=z(ip)-h - z(iq)=z(iq)+h - d(ip)=d(ip)-h - d(iq)=d(iq)+h - a(ip,iq)=0. - do j=1,ip-1 - g=a(j,ip) - h=a(j,iq) - a(j,ip)=g-s*(h+g*tau) - a(j,iq)=h+s*(g-h*tau) - end do - do j=ip+1,iq-1 - g=a(ip,j) - h=a(j,iq) - a(ip,j)=g-s*(h+g*tau) - a(j,iq)=h+s*(g-h*tau) - end do - do j=iq+1,n - g=a(ip,j) - h=a(iq,j) - a(ip,j)=g-s*(h+g*tau) - a(iq,j)=h+s*(g-h*tau) - end do - do j=1,n - g=v(j,ip) - h=v(j,iq) - v(j,ip)=g-s*(h+g*tau) - v(j,iq)=h+s*(g-h*tau) - end do - if (present(nrot)) nrot=nrot+1 - end if - end do - end do - do ip=1,n - b(ip)=b(ip)+z(ip) - d(ip)=b(ip) - z(ip)=0. - end do - end do - pause 'too many iterations in jacobi' - return - - end subroutine jacobi - -end module nr_jacobi - -! *********************************************************** - -#if 0 - -program test - - use nr_jacobi - - implicit none - - integer, parameter :: N = 3 - - real, dimension(N,N) :: A, V - - real, dimension(N) :: D - - integer :: i,j,k - - character(8) :: date_string - character(10) :: time_string - - ! ------------------------------------------------ - - A(1,1) = 1. - A(1,2) = -.8 - A(1,3) = .5 - A(2,2) = 1. - A(2,3) = -.5 - A(3,3) = 1. - A(2,1) = A(1,2) - A(3,2) = A(2,3) - A(3,1) = A(1,3) - - do i=1,N - write (*,*) A(i,:) - end do - - write (*,*) - - call date_and_time(date_string, time_string) - - write (*,*) 'started looping at ', date_string, ', ', time_string - - do k=1,1000000 - - call jacobi(A,N,D,V) - - end do - - call date_and_time(date_string, time_string) - - write (*,*) 'ended looping at ', date_string, ', ', time_string - - do i=1,N - write (*,*) A(i,:) - end do - - write (*,*) - - do i=1,N - write (*,*) V(i,:) - end do - - write (*,*) - - write (*,*) D - - write (*,*) - -end program test - -#endif - -! ============== EOF ========================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_ran2_gasdev.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_ran2_gasdev.F90 deleted file mode 100644 index 705e33ec..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/nr_ran2_gasdev.F90 +++ /dev/null @@ -1,298 +0,0 @@ - -!********************************************************************** -! -! nr_ran2_gasdev.f90 -! -! adapted Numerical Recipes random number generator ran2() and gasdev() -! -! use ran2() instead of rand() and/or ran1() for longer period (~1e18) -! -! gasdev() uses ran2() instead of ran1() -! -! eliminate all save attributes, convert functions into subroutines, -! pass seed state vector into subroutines, enclose in module -! -! reichle, 16 Feb 2005 -! reichle, 18 Feb 2005 - make nr_ran2() public, change call statement -! reichle, 24 Mar 2016 - added vectorized version nr_ran2_2d() by Matt Thompson -! -! ********************************************************************* - -module nr_ran2_gasdev - - implicit none - - private - - public :: NRANDSEED - public :: nr_ran2_2d - public :: nr_gasdev - public :: init_randseed - - integer, parameter :: NRANDSEED = 35 - - integer, parameter :: NTAB = NRANDSEED-3 - integer, parameter :: IM1=2147483563 - integer, parameter :: IM2=2147483399 - real, parameter :: AM=1./IM1 - integer, parameter :: IMM1=IM1-1 - integer, parameter :: IA1=40014 - integer, parameter :: IA2=40692 - integer, parameter :: IQ1=53668 - integer, parameter :: IQ2=52774 - integer, parameter :: IR1=12211 - integer, parameter :: IR2=3791 - integer, parameter :: NDIV=1+IMM1/NTAB - real, parameter :: EPS=1.2e-7 - real, parameter :: RNMX=1.-EPS - - ! RNMX should approximate the largest floating value that is less than 1. - -contains - - !********************************************************************** - ! - ! ran2() - ! - ! Long period (>2!1e18) random number generator of L Ecuyer with - ! Bays-Durham shuffle and added safeguards. Returns a uniform - ! random deviate between 0.0 and 1.0 (exclusive of the endpoint - ! values). - - subroutine nr_ran2(rseed, ran_num) - - implicit none - - integer, dimension(NRANDSEED), intent(inout) :: rseed - - real, intent(out) :: ran_num - - ! local variables - - integer :: idum, idum2, iy - - integer, dimension(NTAB) :: iv - - integer :: j, k - - ! ------------------------------------------------------- - - idum = rseed(1) - idum2 = rseed(2) - iy = rseed(3) - iv = rseed(4:NRANDSEED) - - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ran_num=min(AM*iy,RNMX) - - rseed(1) = idum - rseed(2) = idum2 - rseed(3) = iy - rseed(4:NRANDSEED) = iv - - return - - END subroutine nr_ran2 - - !********************************************************************** - ! - ! vectorized version of nr_ran2(), provided by Matt Thompson - ! - reichle, 24 Mar 2016 - - subroutine nr_ran2_2d(nx, ny, rseed, ran_num) - - implicit none - - integer, intent(in) :: nx, ny - - integer, dimension(NRANDSEED), intent(inout) :: rseed - - real, dimension(nx, ny), intent(out) :: ran_num - - ! local variables - - integer :: idum, idum2, iy - - integer, dimension(NTAB) :: iv - - integer :: j, k, icnt, jcnt - - ! ------------------------------------------------------- - - do jcnt = 1, ny - do icnt = 1, nx - - idum = rseed(1) - idum2 = rseed(2) - iy = rseed(3) - iv = rseed(4:NRANDSEED) - - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ran_num(icnt,jcnt)=min(AM*iy,RNMX) - - rseed(1) = idum - rseed(2) = idum2 - rseed(3) = iy - rseed(4:NRANDSEED) = iv - - end do - end do - - return - - END subroutine nr_ran2_2d - - !************************************************************************* - ! - ! init_randseed() - ! - ! initialize by calling with negative integer rseed(1) - ! and fill in the other NRANDSEED-1 integers (stored in idum2, iy, iv) - - subroutine init_randseed( rseed ) - - implicit none - - integer, dimension(NRANDSEED), intent(inout) :: rseed - - ! local variables - - integer :: idum, idum2, iy - - integer, dimension(NTAB) :: iv - - integer :: j, k - - ! ------------------------------------------------------------ - - idum = rseed(1) - - if (idum<=0) then - idum=max(-idum,1) - idum2=idum - do j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - if (j.le.NTAB) iv(j)=idum - end do - iy=iv(1) - else - write (*,*) 'init_randseed(): initialize by calling with rseed(1)<0' - write (*,*) 'STOPPING.' - stop - end if - - rseed(1) = idum - rseed(2) = idum2 - rseed(3) = iy - rseed(4:NRANDSEED) = iv - - end subroutine init_randseed - - !****************************************************************** - ! - ! gasdev() adapted to use ran2() - ! - ! Returns TWO normally distributed deviates with zero mean and unit - ! variance, using ran2() as the source of uniform deviates. - ! - ! Use init_randseed() to initialize. - - subroutine nr_gasdev(rseed, gasdev) - - implicit none - - integer, dimension(NRANDSEED), intent(inout) :: rseed - - real, dimension(2), intent(out) :: gasdev - - ! local variables - - real :: fac, rsq, v1, v2 - - ! --------------- - -1 call nr_ran2(rseed, v1) - call nr_ran2(rseed, v2) - v1=2.*v1-1. - v2=2.*v2-1. - rsq=v1**2+v2**2 - if(rsq.ge.1..or.rsq.eq.0.)goto 1 - fac=sqrt(-2.*log(rsq)/rsq) - gasdev(1)=v1*fac - gasdev(2)=v2*fac - - return - - end subroutine nr_gasdev - - ! ************************************************************ - -end module nr_ran2_gasdev - -! ***************************************************************** -! -! driver for testing module nr_ran2_gasdev - -#if 0 - -program test_my_random_numbers - - use nr_ran2_gasdev - - implicit none - - integer :: i, RSEEDCONST - - integer, dimension(NRANDSEED) :: rseed - - real, dimension(2) :: x - - ! -------------------------------- - - RSEEDCONST = -777 - - rseed(1) = RSEEDCONST - - write (*,*) RSEEDCONST - - call init_randseed(rseed) - - x = .0 - - do i=1,10 - - !x = gasdev(RSEED) - - call nr_gasdev(rseed, x) - - write (*,*) 'rr ', x(2), rseed(1) - write (*,*) 'rr ', x(1), rseed(1) - - end do - -end program test_my_random_numbers - -#endif - - -! ******* EOF ********************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/random_fields.F90 b/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/random_fields.F90 deleted file mode 100644 index 3ed12e69..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSlandpert_GridComp/random_fields.F90 +++ /dev/null @@ -1,782 +0,0 @@ -! ========================================================================= -! -! random_fields.f90 -! -! random field generator in 2d: -! generate a pair of random fields in 2d with zero mean -! -! subroutines rfg2d_fft() and sqrt_gauss_spectrum are translated from -! C++ code rfg2d.C written for MIT EnKF work by reichle -! (see janus:~reichle/nasa/EnKF) -! -! covariance is specified through its spectrum, so far only Gaussian -! -! IMPORTANT: read comments for function rfg2d_fft() -! -! written for NSIPP - EnKF -! Type: f90 -! Author: Rolf Reichle -! Date: 2 Nov 2001 -! -! reichle, 18 Feb 2005 - updated for use with module nr_ran2_gasdev -! deleted use of module select_kinds -! reichle, 8 Jun 2005 - added nr_fft should CXML fft not be available -! pchakrab, 17 Jun 2013 - redesigned to make the module object-oriented (F03) - -! use intel mkl fft when available -#ifdef MKL_AVAILABLE -#include "mkl_dfti.f90" -#else -#define NR_FALLBACK -#endif - -#include "MAPL_ErrLog.h" -#include "unused_dummy.H" - -module random_fieldsMod - -#ifdef MKL_AVAILABLE - use, intrinsic :: iso_c_binding, only: c_loc, c_f_pointer, c_ptr, c_sizeof, C_NULL_PTR - use mpi - use MKL_DFTI -#else - use nr_fft, ONLY: & - fourn -#endif - - use nr_ran2_gasdev, ONLY: & - NRANDSEED, & - nr_ran2_2d, & - nr_gasdev - - use MAPL_ExceptionHandling - - implicit none - - private - - real, parameter :: TWO_PI = 2.*3.14159265 - real, parameter :: SQRT2 = sqrt(2.0) - - type, public :: random_fields - private - integer :: N_x, N_y - integer :: N_x_fft, N_y_fft ! computed by calc_fft_grid - real, allocatable :: field1_fft(:,:), field2_fft(:,:) - integer :: fft_lens(2) ! length of each dim for 2D transform -#ifdef MKL_AVAILABLE - integer :: comm - integer :: node_comm - integer :: win - type (c_ptr) :: base_address - - type(DFTI_DESCRIPTOR), pointer :: Desc_Handle - type(DFTI_DESCRIPTOR), pointer :: Desc_Handle_dim1 - type(DFTI_DESCRIPTOR), pointer :: Desc_Handle_dim2 - integer, allocatable :: dim1_counts(:) - integer, allocatable :: dim2_counts(:) -#endif - - contains - - ! procedure, public :: initialize - procedure, public :: finalize - procedure, public :: rfg2d_fft - procedure, public :: generate_white_field - procedure, private :: sqrt_gauss_spectrum_2d -#ifdef MKL_AVAILABLE - procedure, private :: win_allocate - procedure, private :: win_deallocate -#endif - end type random_fields - - interface random_fields - module procedure new_random_fields - end interface random_fields - -contains - - ! constructor (set parameter values), allocate memory - function new_random_fields(Nx, Ny, Nx_fft, Ny_fft, comm, rc) result (rf) - - ! input/output variables [NEED class(random_fields) - ! instead of type(random_fields)] - F2003 quirk?!? - type(random_fields) :: rf - integer, intent(in) :: Nx, Ny, Nx_fft, Ny_fft - integer, optional, intent(in) :: comm - integer, optional, intent(out) :: rc - - ! local variables - integer :: status, ierror - integer :: rank, npes, local_dim1, local_dim2, remainder - integer :: Stride(2) - - ! set obj param vals - rf%N_x = Nx - rf%N_y = Ny - - ! ensure N_x_fft, N_y_fft are powers of two - rf%N_x_fft = Nx_fft - rf%N_y_fft = Ny_fft - - - ! allocate memory - allocate(rf%field1_fft(rf%N_x_fft, rf%N_y_fft)) - allocate(rf%field2_fft(rf%N_x_fft, rf%N_y_fft)) - -#ifdef MKL_AVAILABLE - if (present(comm)) then - rf%comm = comm - - call MPI_Comm_split_type(rf%comm, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, rf%Node_Comm,ierror) - call MPI_Comm_size(rf%Node_Comm, npes, ierror) - call MPI_Comm_rank(rf%Node_Comm, rank, ierror) - - if (npes > minval([Nx_fft, Ny_fft]) ) then - print*, " Two many processors are acquired in a node for parallel FFT" - print*, " The number of processors acquired in a node should be smaller than or equal to FFT grid size: ", minval([Nx_fft, Ny_fft]) - _FAIL('Parallel FFT failed') - endif - - call rf%win_allocate(Nx_fft, Ny_fft, _RC) - - ! distribution of the grid for fft - allocate(rf%dim1_counts(npes),rf%dim2_counts(npes)) - local_dim1 = Nx_fft/npes - rf%dim1_counts = local_dim1 - remainder = mod(Nx_fft, npes) - rf%dim1_counts(1:remainder) = local_dim1 + 1 - local_dim1 = rf%dim1_counts(rank+1) - - local_dim2 = Ny_fft/npes - rf%dim2_counts = local_dim2 - remainder = mod(Ny_fft, npes) - rf%dim2_counts(1:remainder) = local_dim2 + 1 - local_dim2 = rf%dim2_counts(rank+1) - - - status = DftiCreateDescriptor(rf%Desc_Handle_Dim1, DFTI_SINGLE,& - DFTI_COMPLEX, 1, Nx_fft ) - _VERIFY(status) - status = DftiCreateDescriptor(rf%Desc_Handle_Dim2, DFTI_SINGLE,& - DFTI_COMPLEX, 1, Ny_fft ) - _VERIFY(status) - - ! perform local_dim2 one-dimensional transforms along 1st dimension - status = DftiSetValue( rf%Desc_Handle_Dim1, DFTI_NUMBER_OF_TRANSFORMS, local_dim2 ) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim1, DFTI_INPUT_DISTANCE, Nx_fft ) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim1, DFTI_OUTPUT_DISTANCE, Nx_fft ) - _VERIFY(status) - status = DftiCommitDescriptor( rf%Desc_Handle_Dim1 ) - _VERIFY(status) - ! status = DftiComputeForward( rf%Desc_Handle_Dim1, X ) - ! local_dim1 one-dimensional transforms along 2nd dimension - Stride(1) = 0; Stride(2) = local_dim1 - status = DftiSetValue( rf%Desc_Handle_Dim2, DFTI_NUMBER_OF_TRANSFORMS, local_dim1) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim2, DFTI_INPUT_DISTANCE, 1 ) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim2, DFTI_OUTPUT_DISTANCE, 1 ) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim2, DFTI_INPUT_STRIDES, Stride ) - _VERIFY(status) - status = DftiSetValue( rf%Desc_Handle_Dim2, DFTI_OUTPUT_STRIDES, Stride ) - _VERIFY(status) - status = DftiCommitDescriptor( rf%Desc_Handle_Dim2 ) - _VERIFY(status) - !status = DftiComputeForward( rf%Desc_Handle_Dim2, X ) - else - rf%comm = MPI_COMM_NULL - ! allocate mem and init mkl dft - status = DftiCreateDescriptor(rf%Desc_Handle, DFTI_SINGLE, DFTI_COMPLEX, 2, [Nx_fft, Ny_fft]) - _VERIFY(status) - - ! initialize for actual dft computation - status = DftiCommitDescriptor(rf%Desc_Handle) - _VERIFY(status) - endif -#endif - _RETURN(_SUCCESS) - end function new_random_fields - - ! ************************************************************************** - - ! destructor - deallocate memory - subroutine finalize(this, rc) - - ! input/output variables - class(random_fields), intent(inout) :: this - integer, optional, intent(out) :: rc - ! local variable - integer :: status - - ! deallocate memory - if(allocated(this%field1_fft)) deallocate(this%field1_fft) - if(allocated(this%field2_fft)) deallocate(this%field2_fft) - -#ifdef MKL_AVAILABLE - if (this%comm == MPI_COMM_NULL) then - status = DftiFreeDescriptor(this%Desc_Handle) - _VERIFY(status) - else - - status = DftiFreeDescriptor(this%Desc_Handle_dim1) - _VERIFY(status) - status = DftiFreeDescriptor(this%Desc_Handle_dim2) - _VERIFY(status) - - call this%win_deallocate( _RC) - - deallocate(this%dim1_counts, this%dim2_counts) - endif -#endif - - end subroutine finalize - - - ! subroutine sqrt_gauss_spectrum_2d() - ! - ! get SQUARE ROOT of 2d Gaussian spectrum (incl volume element) - ! - ! 2d Gaussian spectrum: - ! - ! S(kx,ky) = variance - ! * - ! lambda_x*lambda_y/(2*pi) - ! * - ! exp( -(kx^2*lambda_x^2 + ky^2*lambda_y^2)/2 ) - ! - ! return: sqrt( S*dkx*dky ) - ! - ! that is return the SQUARE ROOT of the spectrum multiplied with the - ! square root of the volume element d2k=dkx*dky of the ifft integral - ! - ! spectrum is returned in "wrap-around" order compatible with CXML and - ! matlab FFT algorithms - ! - ! inputs: - ! variance : variance desired for complex field, if pair of real fields - ! is used each field must eventually be multiplied with sqrt(2) - ! N_x : number of nodes in x direction - ! N_y : number of nodes in y direction - ! dkx : wave number spacing in x direction - ! dky : wave number spacing in y direction - ! lambda_x : decorrelation length in x direction - ! lambda_y : decorrelation length in y direction - ! - ! modifies this%field1_fft - - subroutine sqrt_gauss_spectrum_2d(this, lx, ly, dx, dy) - - ! input/output variables - class(random_fields), intent(inout) :: this - real, intent(in) :: lx, ly, dx, dy - - ! local variables - real :: dkx, dky, fac, lamx2dkx2, lamy2dky2 - real :: lx2kx2(this%N_x_fft), ly2ky2(this%N_y_fft) - integer :: i, j, i1, i2, rank, ierror - real :: var - - var = 1.0 - ! start - dkx = (TWO_PI)/(float(this%N_x_fft)*dx) - dky = (TWO_PI)/(float(this%N_y_fft)*dy) - - ! factor includes sqrt of volume element of ifft integral - fac = sqrt(var*lx*ly/(TWO_PI)*dkx*dky ) - lamx2dkx2 = lx*lx*dkx*dkx - lamy2dky2 = ly*ly*dky*dky - - ! precompute (lambda_x*k_x)^2 in "wrap-around" - ! order suitable for CXML fft - do i=1,(this%N_x_fft/2) - lx2kx2(i) = lamx2dkx2*(i-1)*(i-1) - end do - do i=(this%N_x_fft/2+1),this%N_x_fft - lx2kx2(i) = lamx2dkx2*(this%N_x_fft-i+1)*(this%N_x_fft-i+1) - end do - - ! precompute (lambda_y*k_y)^2 in "wrap-around" - ! order suitable for CXML fft - do j=1,(this%N_y_fft/2) - ly2ky2(j) = lamy2dky2*(j-1)*(j-1) - end do - do j=(this%N_y_fft/2+1),this%N_y_fft - ly2ky2(j) = lamy2dky2*(this%N_y_fft-j+1)*(this%N_y_fft-j+1) - end do - - ! assemble spectrum in "wrap-around" order - i1 = 1 - i2 = this%N_x_fft - if (this%comm /= MPI_COMM_NULL) then - call MPI_COMM_Rank(this%node_comm, rank, ierror) - i1 = sum(this%dim1_counts(1:rank)) + 1 - i2 = sum(this%dim1_counts(1:rank+1)) - endif - - do j=1,this%N_y_fft - this%field1_fft(i1:i2,j) = fac*exp(-.25*(lx2kx2(i1:i2)+ly2ky2(j))) - end do - - return - - end subroutine sqrt_gauss_spectrum_2d - - ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - ! ---------------------------------------------------------------------- - ! - ! subroutine rfg2d_fft() - ! - ! generate a pair of 2d zero-mean random fields using FFT method - ! (so far only Gaussian covariance implemented) - ! - ! NOTE: implemented with index counters of type int, must have - ! - ! N_x*N_y < maximum integer on given machine - ! - ! on yama/alborz (at MIT) int varies from -2147483648...2147483647 - ! -> can handle up to N_x*N_y = (32768)^2 - ! if larger fields are needed, rewrite with type long int etc - ! - ! NOTE: The fft method for generating random fields produces - ! fields that are periodic with the size of the domain, - ! that is the field is (almost) the same on each boundary. - ! This introduces unwanted correlations at lags shorter than - ! the domain size. Therefore, only a part of the generated - ! field is usable. As a rule of thumb, the fields should be - ! generated on a grid that is two correlation lenghts bigger - ! than the field on which the grid is desired. Then cut out - ! fields of the necessary size. - ! This procedure is included in rfg2d_fft(). - ! - ! NOTE: The variance specified as input is the theoretical variance of - ! the complex field that is obtained from the inverse fft of the - ! realization dZ. - ! The sample variance of this *complex* field is a FIXED (non-random) - ! number which depends on the size of the domain, the grid spacing, - ! and the correlation length (but not on the random seed!!). - ! (This number is non-random because the variance is the integral - ! of the absolute value of the spectrum. In this integral the - ! randomness disappears because we only choose a random phase angle.) - ! For vanishing discretization and spectral truncation error, - ! this number converges to the theoretical (input) value. - ! - ! This function is set up to use the pair of two real fields, where - ! - ! field1 = sqrt(2)*real(ifft(dZ)) - ! field2 = sqrt(2)*imag(ifft(dZ)). - ! - ! The factor sqrt(2) re-scales the variance of field1 and field2 - ! such that for vanishing discretization error and spectral - ! truncation error each field converges to the specified theoretical - ! (input) variance. - ! NOTE: The sum of the sample variances of the two real fields - ! is equal to the (FIXED) sample variance of the complex field - ! (before re-scaling with sqrt(2)). - ! The individual sample variances within each pair vary from - ! realization to realization. - - subroutine rfg2d_fft(this, rseed, rfield, rfield2, lx, ly, dx, dy) - - ! input/output variables - class(random_fields), intent(inout) :: this ! ffield*_fft is modified - integer, intent(inout) :: rseed(NRANDSEED) ! nr_ran2 modifies rseed - real, dimension(this%N_x,this%N_y), intent(out) :: rfield, rfield2 - real, intent(in) :: lx, ly, dx, dy - - ! local variables - !real :: theta, ran_num ! rng - real,allocatable,dimension(:,:) :: theta, ran_num ! rng - integer :: N_xy_fft, k ! fft - integer :: i, j - integer :: N_x_fft, N_y_fft - real :: N_xy_fft_real -#ifdef MKL_AVAILABLE - integer :: status - complex, allocatable :: z_inout(:) - complex, pointer :: tmp_field(:,:) - complex, pointer :: tmp_field_dim1(:,:) - complex, pointer :: tmp_field_dim2(:,:) - integer :: n1, n2, npes, rank, ldim1, ldim2, ierror - complex, pointer :: X(:) - type (c_ptr) :: cptr -#else - real, allocatable :: tmpdata(:) -#endif - - ! start - N_x_fft = this%N_x_fft - N_y_fft = this%N_y_fft - - ! follow Ruan & McLaughlin, 1998: - ! compute dZ = H * exp(i*theta) * sqrt(d2k) - ! start with square root of spectrum (factor H*sqrt(d2k)), put into field1 - ! modify this%field1_fft - call this%sqrt_gauss_spectrum_2d(lx, ly, dx, dy) - - ! multiply by random phase angle - !! do j=1,N_y_fft - !! do i=1,N_x_fft - !! call nr_ran2(rseed, ran_num) - !! theta = (TWO_PI)*ran_num ! random phase angle - !! this%field2_fft(i,j) = sin(theta)*this%field1_fft(i,j) - !! this%field1_fft(i,j) = cos(theta)*this%field1_fft(i,j) - !! end do - !! end do - - allocate( theta(N_x_fft, N_y_fft)) - allocate(ran_num(N_x_fft, N_y_fft)) - - call nr_ran2_2d(N_x_fft, N_y_fft, rseed, ran_num) - theta = (TWO_PI)*ran_num ! random phase angle - n1 = 1 - n2 = N_x_fft -#ifdef MKL_AVAILABLE - if (this%comm /= MPI_COMM_NULL) then - call MPI_comm_rank(this%node_comm, rank, ierror) - n1 = sum(this%dim1_counts(1:rank)) + 1 - n2 = sum(this%dim1_counts(1:rank+1)) - endif -#endif - this%field2_fft(n1:n2,:) = sin(theta(n1:n2,:))*this%field1_fft(n1:n2,:) - this%field1_fft(n1:n2,:) = cos(theta(n1:n2,:))*this%field1_fft(n1:n2,:) - - deallocate( theta) - deallocate(ran_num) - - - ! force dZ(1,1) to zero - ! (zero mean random field) - this%field1_fft(1,1) = 0. - this%field2_fft(1,1) = 0. - - ! apply 2D FFT - N_xy_fft = N_x_fft*N_y_fft - N_xy_fft_real = real(N_xy_fft) - -#ifdef MKL_AVAILABLE - ! use MKL FFT - ! fill temporary 1D array - if (this%comm == MPI_COMM_NULL) then - allocate(z_inout(N_xy_fft)) - k = 0 - do j=1,N_y_fft - do i=1,N_x_fft - k=k+1 - z_inout(k) = cmplx(this%field1_fft(i,j),this%field2_fft(i,j)) - end do - end do - - ! compute in-place backward transform (scale=1) - ! NOTE: MKL backward transform is the same as NR forward transform - status = DftiComputeBackward(this%Desc_Handle, z_inout) - if (status/= DFTI_NO_ERROR) call quit('DftiComputeBackward failed!') - - ! extract random fields from z_inout - z_inout = z_inout/N_xy_fft_real - k = 0 - do j=1,N_y_fft - do i=1,N_x_fft - k=k+1 - this%field1_fft(i,j) = real(z_inout(k)) - this%field2_fft(i,j) = aimag(z_inout(k)) - end do - end do - - deallocate(z_inout) - else - call MPI_comm_size(this%node_comm, npes, ierror) - call c_f_pointer(this%base_address, tmp_field, shape=[N_x_fft, N_y_fft]) - ldim1 = this%dim1_counts(rank+1) - - allocate(tmp_field_dim1(ldim1, N_y_fft)) - tmp_field_dim1 = cmplx(this%field1_fft(n1:n2,:),this%field2_fft(n1:n2,:)) - cptr = c_loc(tmp_field_dim1(1,1)) - call c_f_pointer (cptr, X, [ldim1*N_y_fft]) - status = DftiComputeBackward( this%Desc_Handle_Dim2, X ) - if (status/= DFTI_NO_ERROR) call quit('DftiComputeBackward dim2 failed!') - call MPI_Barrier(this%node_comm, ierror) - tmp_field(n1:n2,:) = tmp_field_dim1 - - call MPI_Win_fence(0, this%win, ierror) - - n1 = sum(this%dim2_counts(1:rank)) + 1 - n2 = sum(this%dim2_counts(1:rank+1)) - ldim2 = this%dim2_counts(rank+1) - allocate(tmp_field_dim2(N_x_fft, ldim2)) - tmp_field_dim2 = tmp_field(:,n1:n2) - cptr = c_loc(tmp_field_dim2(1,1)) - call c_f_pointer (cptr, X, [N_x_fft*ldim2]) - status = DftiComputeBackward( this%Desc_Handle_Dim1, X ) - if (status/= DFTI_NO_ERROR) call quit('DftiComputeBackward dim1 failed!') - tmp_field(:,n1:n2) = tmp_field_dim2/N_xy_fft_real - - call MPI_Win_fence(0, this%win, ierror) - - this%field1_fft = real(tmp_field) - this%field2_fft = aimag(tmp_field) - - deallocate(tmp_field_dim1, tmp_field_dim2) - endif -#else - ! use nr_fft - ! fill tmpdata according to Figs 12.2.2 - ! and 12.4.1 of f77 NR book - allocate(tmpdata(2*N_xy_fft)) - k=0 - do j=1,N_y_fft - do i=1,N_x_fft - k=k+1 - tmpdata(k) = this%field1_fft(i,j) - k=k+1 - tmpdata(k) = this%field2_fft(i,j) - end do - end do - - ! apply nr_fft - call fourn(tmpdata,this%fft_lens,2,1) - - ! extract random fields from tmpdata - k=0 - do j=1,N_y_fft - do i=1,N_x_fft - k=k+1 - this%field1_fft(i,j) = tmpdata(k)/N_xy_fft_real - k=k+1 - this%field2_fft(i,j) = tmpdata(k)/N_xy_fft_real - end do - end do - - deallocate(tmpdata) - -#endif - - ! multiply with factor sqrt(2) to get correct variance - ! (see above and p. 388 Ruan and McLaughlin, 1998), - ! also multiply with N_x_fft*N_y_fft to get correct scaling, - ! also retain only usable part of field?_fft - ! output variables - rfield = SQRT2*N_xy_fft_real*this%field1_fft(1:this%N_x,1:this%N_y) - rfield2 = SQRT2*N_xy_fft_real*this%field2_fft(1:this%N_x,1:this%N_y) - - end subroutine rfg2d_fft - - - - ! generate standard-normal random field that is white in space - ! - ! note that nr_gasdev always produces a pair of random numbers - ! - ! do not store random numbers between subsequent calls to - ! the random field generator - works best if fields are large - ! (ie. avoid using this subroutine with N_x=N_y=1) - ! - ! revised to avoid branching (if statement w/in do loop) - ! - pchakrab+reichle, 29 Nov 2013 - ! - subroutine generate_white_field(this, rseed, rfield) - - implicit none - - ! input/output variables - class(random_fields), intent(in) :: this - integer, intent(inout) :: rseed(NRANDSEED) ! nr_gasdev modifies rseed - real, dimension(this%N_x,this%N_y), intent(out), target :: rfield - - ! local variables - integer :: Nxy, index - real, pointer :: ptr2rfield(:) - logical :: NxyIsOdd - real :: tmp_real(2) - - Nxy = this%N_x*this%N_y - - ptr2rfield(1:Nxy) => rfield(:,:) ! ptr rank remapping - - NxyIsOdd = .false. - if (mod(Nxy,2)==1) NxyIsOdd = .true. - - do index=1,Nxy-1,2 - call nr_gasdev(rseed, tmp_real) - ptr2rfield(index) = tmp_real(1) - ptr2rfield(index+1) = tmp_real(2) - end do - if (NxyIsOdd) then - call nr_gasdev(rseed, tmp_real) - ptr2rfield(Nxy) = tmp_real(1) - end if - - end subroutine generate_white_field - - ! a local, small stop routine - subroutine quit(message) - - implicit none - - character(*), intent(in) :: message - - write (*,*) trim(message) - stop - - end subroutine quit - - subroutine win_allocate(this, nx, ny, rc) - class(random_fields), intent(inout) :: this - integer, intent(in) :: nx, ny - integer, optional, intent(out) :: rc - complex :: dummy - integer(kind=MPI_ADDRESS_KIND) :: windowsize - integer :: disp_unit,status, Rank - integer(kind=MPI_ADDRESS_KIND) :: n_bytes - - - call MPI_Comm_rank( this%node_comm, rank, status) - n_bytes = nx*ny*c_sizeof(dummy) - windowsize = 0_MPI_ADDRESS_KIND - if (Rank == 0) windowsize = n_bytes - disp_unit = 4 - call MPI_Win_allocate_shared(windowsize, disp_unit, MPI_INFO_NULL, this%node_comm, & - this%base_address, this%win, status) - _VERIFY(status) - if (rank /=0) CALL MPI_Win_shared_query(this%win, 0, windowsize, disp_unit, this%base_address, status) - call MPI_Win_fence(0, this%win, status) - _VERIFY(status) - call MPI_Barrier(this%node_comm, status) - _VERIFY(status) - _RETURN(_SUCCESS) - end subroutine win_allocate - - subroutine win_deallocate(this, rc) - class(random_fields), intent(inout) :: this - integer, optional, intent(out) :: rc - integer :: status - call MPI_Win_fence(0, this%win, status) - _VERIFY(status) - call MPI_Win_free(this%win, status) - _VERIFY(status) - call MPI_comm_free(this%node_comm, status) - _VERIFY(status) - - end subroutine win_deallocate - -end module Random_fieldsMod - -module StringRandom_fieldsMapMod - use Random_fieldsMod - -#include "types/key_deferredLengthString.inc" -#define _value type (random_fields) -#define _value_equal_defined - -#define _map StringRandom_fieldsMap -#define _iterator StringRandom_fieldsMapIterator - -#define _alt - -#include "templates/map.inc" - -#undef _alt -#undef _iterator -#undef _map -#undef _value -#undef _key -#undef _value_equal_defined -end module StringRandom_fieldsMapMod - - -#ifdef TEST_RFG2D - -!program test_rfg2d -! -! use Random_fieldsMod -! use nr_ran2_gasdev -! -! implicit none -! -! integer :: N_x, N_y, i, j, n_e, N_e_tot -! real :: dx, dy, lx, ly, var -! real, allocatable, dimension(:,:) :: field1, field2 -! -! character(300) :: file_name -! character(10) :: n_e_string -! character(100) :: output_format -! character(10) :: tmp_string -! -! integer :: RSEEDCONST -! integer, dimension(NRANDSEED) :: rseed -! -! character(5) :: fft_tag -! -! ! instance of random_fields -! type(random_fields) :: rf -! -! ! start -! RSEEDCONST = -777 -! rseed(1) = RSEEDCONST -! write (*,*) RSEEDCONST -! call init_randseed(rseed) -! -! N_x = 144 -! N_y = 91 -! dx = 5000. -! dy = 5000. -! lx = 45000. -! ly = 45000. -! var = 1. -! -! -! allocate(field1(N_x,N_y)) -! allocate(field2(N_x,N_y)) -! -!#ifdef MKL_AVAILABLE -! fft_tag = 'mklx.' -!#else -! fft_tag = 'nrxx.' -!#endif -! -! ! get N_e fields -! N_e_tot = 10 -! do n_e=1,N_e_tot,2 -! -! rf = random_fields(N_x, N_y, Nx_fft, Ny_fft) -! call rf%rfg2d_fft(rseed, field1, field2, lx, ly, dx, dy) -! !call rf%generate_white_field(rseed, field1) -! call rf%finalize -! -! ! write to file -! ! field1 -! write(n_e_string, '(i3.3)') n_e -! file_name = 'rf.'//fft_tag// n_e_string(1:len_trim(n_e_string)) // '.dat' -! write(tmp_string, '(i3.3)') N_y -! output_format = '(' // tmp_string(1:len_trim(tmp_string)) // '(1x,e13.5))' -! open (10,file=file_name,status='unknown') -! do i=1,N_x -! write (10,output_format(1:len_trim(output_format))) (field1(i,j), j=1,N_y) -! end do -! close (10,status='keep') -! -! ! field2 -! write(n_e_string, '(i3.3)') n_e+1 -! file_name = 'rf.' //fft_tag// n_e_string(1:len_trim(n_e_string)) // '.dat' -! write(tmp_string, '(i3.3)') N_y -! output_format = '(' // tmp_string(1:len_trim(tmp_string)) // '(1x,e13.5))' -! open (10,file=file_name,status='unknown') -! do i=1,N_x -! write (10,output_format(1:len_trim(output_format))) (field2(i,j), j=1,N_y) -! end do -! close (10,status='keep') -! -! end do -! -!end program test_rfg2d - - -#endif - - -! ======= EOF ================================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt deleted file mode 100644 index 1075229e..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/CMakeLists.txt +++ /dev/null @@ -1,49 +0,0 @@ - -ecbuild_add_executable ( - TARGET GEOSldas.x - SOURCES GEOSldas.F90 - LIBS GEOSldas_GridComp MAPL) - -ecbuild_add_executable ( - TARGET preprocess_ldas.x - SOURCES preprocess_ldas.F90 preprocess_ldas_routines.F90 - LIBS GEOSldas_GridComp MAPL) - -ecbuild_add_executable ( - TARGET tile_bin2nc4.x - SOURCES tile_bin2nc4.F90 - LIBS MAPL) - -ecbuild_add_executable ( - TARGET mwrtm_bin2nc4.x - SOURCES util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 - LIBS GEOSlandassim_GridComp) - -set (scripts - process_hist.csh - remap_config_ldas.py - ens_forcing/average_ensemble_forcing.py - ens_forcing/ensemble_forc.py - ens_forcing/regrid_forc.csh - ens_forcing/enpert_forc.csh - util/config/rewind_GEOSldas.csh - ) - -install ( - PROGRAMS ${scripts} - DESTINATION bin - ) - -set(file ldas_setup) -configure_file(${file} ${file} @ONLY) -install(PROGRAMS ${CMAKE_CURRENT_BINARY_DIR}/${file} DESTINATION bin) - -file(GLOB rc_files GEOSldas_*rc) -file(GLOB nml_files LDASsa_DEFAULT*nml) - -install( - FILES ${rc_files} ${nml_files} lenkf.j.template - DESTINATION etc - ) - -esma_add_subdirectories(util/inputs/ASCAT_sm_mask) diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 deleted file mode 100644 index 5a09b3bc..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas.F90 +++ /dev/null @@ -1,34 +0,0 @@ -#define I_AM_MAIN - -#include "MAPL_Generic.h" - -program LDAS_Main - - - ! !USES: - use MAPL - use GEOS_LDASGridCompMod, only: ROOT_SetServices => SetServices - - implicit none - - character(len=*), parameter :: Iam = "LDAS_Main" - type (MAPL_Cap) :: cap - type (MAPL_FargparseCLI) :: cli - type (MAPL_CapOptions) :: cap_options - integer :: status - -!EOP -!---------------------------------------------------------------------- -!BOC - - cli = MAPL_FargparseCLI() - cap_options = MAPL_CapOptions(cli) - cap_options%egress_file = 'EGRESS.ldas' - - cap = MAPL_Cap('LDAS', ROOT_SetServices, cap_options = cap_options) - call cap%run(_RC) - - !call MAPL_CAP(ROOT_SetServices, FinalFile='EGRESS.ldas', rc=status) - !VERIFY_(status) - -end program LDAS_Main diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc deleted file mode 100644 index 42650936..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_CAP.rc +++ /dev/null @@ -1,34 +0,0 @@ -MAPLROOT_COMPNAME: GEOSldas - ROOT_NAME: GEOSldas - ROOT_CF: LDAS.rc - HIST_CF: HISTORY.rc - -# the date and segment will be set by run script lenk...j - -BEG_DATE: -END_DATE: -JOB_SGMT: -NUM_SGMT: - -HEARTBEAT_DT: 450 - -# Parameters for Cycled REPLAY Forecasts -# -------------------------------------- - -# default using shared memory -# The root of a node reads and shares - -USE_SHMEM: 1 - -BEG_REPDATE: YYYYMMDD -END_REPDATE: YYYYMMDD -FCST_SEGMENT: 00000000 - -#PERPETUAL_YEAR: YYYY -#PERPETUAL_MONTH: MM -#PERPETUAL_DAY: DD - -MAPL_ENABLE_TIMERS: YES -MAPL_ENABLE_MEMUTILS: NO -PRINTSPEC: 0 # (0: OFF, 1: IMPORT & EXPORT, 2: IMPORT, 3: EXPORT) -PRINTRC: 1 diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_ExtData.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_ExtData.rc deleted file mode 100644 index e69de29b..00000000 diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc deleted file mode 100644 index adb52654..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_HIST.rc +++ /dev/null @@ -1,480 +0,0 @@ -# Sample HISTORY.rc file for GEOSldas -# -# This HISTORY template is edited by "ldas_setup" via "process_hist.csh". -# The strings '#ASSIM', '#EASE', and '#CUBE' are *not* linked to MAPL HISTORY -# functionality. For example, the line -# "#CUBE 'tavg24_2d_lnd_Nx'" -# does *not* mean that the 'lnd' output will be on a cube-sphere grid. - -#CUBE VERSION: 1 - -# Must edit 'EXPID' manually if HISTORY file is re-used without going -# through "ldas_setup". -# -EXPID: GEOSldas_expid - -COLLECTIONS: -#EASE 'tavg24_1d_lfs_Nt' -#CUBE 'tavg24_2d_lfs_Nx' -#EASE 'tavg24_1d_lnd_Nt' -#CUBE 'tavg24_2d_lnd_Nx' -#ASSIM 'SMAP_L4_SM_gph' -# 'inst1_1d_lnr_Nt' -# 'catch_progn_incr' -# 'inst3_1d_lndfcstana_Nt' -# 'inst3_2d_lndfcstana_Nx' - :: - -#CUBE GRID_LABELS: PC720x361-DC - -#CUBE :: - -#CUBE PC720x361-DC.GRID_TYPE: LatLon -#CUBE PC720x361-DC.IM_WORLD: 720 -#CUBE PC720x361-DC.JM_WORLD: 361 -#CUBE PC720x361-DC.POLE: PC -#CUBE PC720x361-DC.DATELINE: DC -#CUBE PC720x361-DC.LM: 1 - -# Detailed definition of the collections listed above -# -# Bit shaving: Retain only scientifically meaningful precision and modify meaningless -# bits to facilitate better compression in post-processing; -# *.nbits specifies the number of bits retained; -# For example, many MERRA-2 and FP products use nbits=12 and nbits=10, resp. -# IMPORTANT: To realize the disk space savings, bit-shaved output must be compressed -# after the GEOSldas simulation has finished. Binary files can be compressed -# with "gzip"; nc4 files can be compressed using the "compress_bit-shaved_nc4.sh" -# utility script. - - tavg24_1d_lfs_Nt.descr: 'Tile-space,Daily,Time-Averaged,Single-Level,Assimilation,Land Surface Forcings and States', - tavg24_1d_lfs_Nt.nbits: 12, - tavg24_1d_lfs_Nt.template: '%y4%m2%d2_%h2%n2z.bin', - tavg24_1d_lfs_Nt.archive: '%c/Y%y4', - tavg24_1d_lfs_Nt.mode: 'time-averaged', - tavg24_1d_lfs_Nt.frequency: 240000, - tavg24_1d_lfs_Nt.ref_time: 000000, - tavg24_1d_lfs_Nt.fields:'Tair' , 'METFORCE' , - 'Qair' , 'METFORCE' , - 'LWdown' , 'METFORCE' , - 'SWdown' , 'METFORCE' , - 'Wind' , 'METFORCE' , - 'Psurf' , 'METFORCE' , - 'Rainf_C' , 'METFORCE' , - 'Rainf' , 'METFORCE' , - 'Snowf' , 'METFORCE' , - 'RainfSnowf' , 'METFORCE' , - 'RefH' , 'METFORCE' , - 'CATDEF' , 'GridComp' , - 'RZEXC' , 'GridComp' , - 'SRFEXC' , 'GridComp' , - 'WESNN1' , 'GridComp' , - 'WESNN2' , 'GridComp' , - 'WESNN3' , 'GridComp' , - 'HLWUP' , 'GridComp' , - :: - - tavg24_2d_lfs_Nx.descr: '2d,Daily,Time-Averaged,Single-Level,Assimilation,Land Surface Forcings and States', - tavg24_2d_lfs_Nx.nbits: 12, - tavg24_2d_lfs_Nx.template: '%y4%m2%d2_%h2%n2z.nc4', - tavg24_2d_lfs_Nx.archive: '%c/Y%y4', - tavg24_2d_lfs_Nx.mode: 'time-averaged', - tavg24_2d_lfs_Nx.frequency: 240000, - tavg24_2d_lfs_Nx.ref_time: 000000, - tavg24_2d_lfs_Nx.format: 'CFIO', - tavg24_2d_lfs_Nx.regrid_exch: '../input/tile.data', - tavg24_2d_lfs_Nx.regrid_name: 'GRIDNAME', - tavg24_2d_lfs_Nx.grid_label: PC720x361-DC, - tavg24_2d_lfs_Nx.deflate: 2, - tavg24_2d_lfs_Nx.fields:'Tair' , 'METFORCE' , - 'Qair' , 'METFORCE' , - 'LWdown' , 'METFORCE' , - 'SWdown' , 'METFORCE' , - 'Wind' , 'METFORCE' , - 'Psurf' , 'METFORCE' , - 'Rainf_C' , 'METFORCE' , - 'Rainf' , 'METFORCE' , - 'Snowf' , 'METFORCE' , - 'RainfSnowf' , 'METFORCE' , - 'RefH' , 'METFORCE' , - 'CATDEF' , 'GridComp' , - 'RZEXC' , 'GridComp' , - 'SRFEXC' , 'GridComp' , - 'WESNN1' , 'GridComp' , - 'WESNN2' , 'GridComp' , - 'WESNN3' , 'GridComp' , - 'HLWUP' , 'GridComp' , - :: - - tavg24_1d_lnd_Nt.descr: 'Tile-space,Daily,Time-Averaged,Single-Level,Assimilation,Land Surface Diagnostics', - tavg24_1d_lnd_Nt.nbits: 12, - tavg24_1d_lnd_Nt.template: '%y4%m2%d2_%h2%n2z.bin', - tavg24_1d_lnd_Nt.mode: 'time-averaged', - tavg24_1d_lnd_Nt.frequency: 240000, - tavg24_1d_lnd_Nt.ref_time: 000000, - tavg24_1d_lnd_Nt.fields: 'WET3' , 'GridComp' , 'GWETPROF' , - 'WET2' , 'GridComp' , 'GWETROOT' , - 'WET1' , 'GridComp' , 'GWETTOP' , - 'WCPR' , 'GridComp' , 'PRMC' , - 'WCRZ' , 'GridComp' , 'RZMC' , - 'WCSF' , 'GridComp' , 'SFMC' , - 'TPSNOW' , 'GridComp' , - 'TPUNST' , 'GridComp' , 'TUNST' , - 'TPSAT' , 'GridComp' , 'TSAT' , - 'TPWLT' , 'GridComp' , 'TWLT' , - 'TPSURF' , 'GridComp' , 'TSURF' , - 'GRN' , 'VEGDYN' , - 'LAI' , 'VEGDYN' , - 'TP1' , 'GridComp' , - 'TP2' , 'GridComp' , - 'TP3' , 'GridComp' , - 'TP4' , 'GridComp' , - 'TP5' , 'GridComp' , - 'TP6' , 'GridComp' , - 'PRLAND' , 'GridComp' , 'PRECTOTLAND' , - 'SNOLAND' , 'GridComp' , 'PRECSNOLAND' , - 'TSLAND' , 'GridComp' , 'SNOMAS' , - 'SNOWDP' , 'GridComp' , 'SNODP' , - 'EVPSOI' , 'GridComp' , 'EVPSOIL' , - 'EVPVEG' , 'GridComp' , 'EVPTRNS' , - 'EVPINT' , 'GridComp' , 'EVPINTR' , - 'EVPICE' , 'GridComp' , 'EVPSBLN' , - 'RUNSURF' , 'GridComp' , 'RUNOFF' , - 'BASEFLOW' , 'GridComp' , - 'SMLAND' , 'GridComp' , - 'QINFIL' , 'GridComp' , - 'FRUST' , 'GridComp' , 'FRUNST' , - 'FRSAT' , 'GridComp' , - 'ASNOW' , 'GridComp' , 'FRSNO' , - 'FRWLT' , 'GridComp' , - 'DFPARLAND' , 'GridComp' , 'PARDFLAND' , - 'DRPARLAND' , 'GridComp' , 'PARDRLAND' , - 'SHLAND' , 'GridComp' , - 'LHLAND' , 'GridComp' , - 'EVLAND' , 'GridComp' , - 'LWLAND' , 'GridComp' , - 'SWLAND' , 'GridComp' , - 'GHLAND' , 'GridComp' , - 'TWLAND' , 'GridComp' , - 'TELAND' , 'GridComp' , - 'DWLAND' , 'GridComp' , 'WCHANGE' , - 'DHLAND' , 'GridComp' , 'ECHANGE' , - 'SPLAND' , 'GridComp' , - 'SPWATR' , 'GridComp' , - 'SPSNOW' , 'GridComp' , - 'PEATCLSM_WATERLEVEL', 'GridComp' , - 'PEATCLSM_FSWCHANGE' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU002' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU003' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU004' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU005' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTBC001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTBC002' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTOC001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTOC002' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNLAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNTLAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNSAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNTOTC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNVEGC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNROOT' , 'GridComp' , ->>>HIST_CATCHCNCLM45<<< 'CNFROOTC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNNPP' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNGPP' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNSR' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNNEE' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNXSMR' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNADD' , 'GridComp' , ->>>HIST_CATCHCN<<< 'PARABS' , 'GridComp' , ->>>HIST_CATCHCN<<< 'PARINC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'SCSAT' , 'GridComp' , ->>>HIST_CATCHCN<<< 'SCUNS' , 'GridComp' , ->>>HIST_CATCHCN<<< 'BTRANT' , 'GridComp' , 'BTRAN' , ->>>HIST_CATCHCN<<< 'SIF' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNLOSS' , 'GridComp' , 'CLOSS' , ->>>HIST_CATCHCN<<< 'CNBURN' , 'GridComp' , 'BURN' , ->>>HIST_CATCHCN<<< 'CNFSEL' , 'GridComp' , 'FSEL' , ->>>HIST_CATCHCN<<< 'EVPSNO' , 'GridComp' , ->>>HIST_CATCHCN<<< 'GHTSKIN' , 'GridComp' , ->>>HIST_CATCHCN<<< 'WAT10CM' , 'GridComp' , ->>>HIST_CATCHCN<<< 'WATSOI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'ICESOI' , 'GridComp' , ->>>HIST_IRRIG<<< 'IRRIGRATE' , 'GridComp' , - :: - - tavg24_2d_lnd_Nx.descr: '2d,Daily,Time-Averaged,Single-Level,Assimilation,Land Surface Diagnostics', - tavg24_2d_lnd_Nx.nbits: 12, - tavg24_2d_lnd_Nx.template: '%y4%m2%d2_%h2%n2z.nc4', - tavg24_2d_lnd_Nx.mode: 'time-averaged', - tavg24_2d_lnd_Nx.frequency: 240000, - tavg24_2d_lnd_Nx.ref_time: 000000, - tavg24_2d_lnd_Nx.format: 'CFIO', - tavg24_2d_lnd_Nx.regrid_exch: '../input/tile.data' - tavg24_2d_lnd_Nx.regrid_name: 'GRIDNAME' - tavg24_2d_lnd_Nx.grid_label: PC720x361-DC - tavg24_2d_lnd_Nx.deflate: 2, - tavg24_2d_lnd_Nx.fields: 'WET3' , 'GridComp' , 'GWETPROF' , - 'WET2' , 'GridComp' , 'GWETROOT' , - 'WET1' , 'GridComp' , 'GWETTOP' , - 'WCPR' , 'GridComp' , 'PRMC' , - 'WCRZ' , 'GridComp' , 'RZMC' , - 'WCSF' , 'GridComp' , 'SFMC' , - 'TPSNOW' , 'GridComp' , - 'TPUNST' , 'GridComp' , 'TUNST' , - 'TPSAT' , 'GridComp' , 'TSAT' , - 'TPWLT' , 'GridComp' , 'TWLT' , - 'TPSURF' , 'GridComp' , 'TSURF' , - 'GRN' , 'VEGDYN' , - 'LAI' , 'VEGDYN' , - 'TP1' , 'GridComp' , - 'TP2' , 'GridComp' , - 'TP3' , 'GridComp' , - 'TP4' , 'GridComp' , - 'TP5' , 'GridComp' , - 'TP6' , 'GridComp' , - 'PRLAND' , 'GridComp' , 'PRECTOTLAND' , - 'SNOLAND' , 'GridComp' , 'PRECSNOLAND' , - 'TSLAND' , 'GridComp' , 'SNOMAS' , - 'SNOWDP' , 'GridComp' , 'SNODP' , - 'EVPSOI' , 'GridComp' , 'EVPSOIL' , - 'EVPVEG' , 'GridComp' , 'EVPTRNS' , - 'EVPINT' , 'GridComp' , 'EVPINTR' , - 'EVPICE' , 'GridComp' , 'EVPSBLN' , - 'RUNSURF' , 'GridComp' , 'RUNOFF' , - 'BASEFLOW' , 'GridComp' , - 'SMLAND' , 'GridComp' , - 'QINFIL' , 'GridComp' , - 'FRUST' , 'GridComp' , 'FRUNST' , - 'FRSAT' , 'GridComp' , - 'ASNOW' , 'GridComp' , 'FRSNO' , - 'FRWLT' , 'GridComp' , - 'DFPARLAND' , 'GridComp' , 'PARDFLAND' , - 'DRPARLAND' , 'GridComp' , 'PARDRLAND' , - 'SHLAND' , 'GridComp' , - 'LHLAND' , 'GridComp' , - 'EVLAND' , 'GridComp' , - 'LWLAND' , 'GridComp' , - 'SWLAND' , 'GridComp' , - 'GHLAND' , 'GridComp' , - 'TWLAND' , 'GridComp' , - 'TELAND' , 'GridComp' , - 'DWLAND' , 'GridComp' , 'WCHANGE' , - 'DHLAND' , 'GridComp' , 'ECHANGE' , - 'SPLAND' , 'GridComp' , - 'SPWATR' , 'GridComp' , - 'SPSNOW' , 'GridComp' , - 'PEATCLSM_WATERLEVEL', 'GridComp' , - 'PEATCLSM_FSWCHANGE' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU002' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU003' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU004' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTDU005' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTBC001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTBC002' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTOC001' , 'GridComp' , ->>>HIST_AEROSOL<<< 'RMELTOC002' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNLAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNTLAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNSAI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNTOTC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNVEGC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNROOT' , 'GridComp' , ->>>HIST_CATCHCNCLM45<<< 'CNFROOTC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNNPP' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNGPP' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNSR' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNNEE' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNXSMR' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNADD' , 'GridComp' , ->>>HIST_CATCHCN<<< 'PARABS' , 'GridComp' , ->>>HIST_CATCHCN<<< 'PARINC' , 'GridComp' , ->>>HIST_CATCHCN<<< 'SCSAT' , 'GridComp' , ->>>HIST_CATCHCN<<< 'SCUNS' , 'GridComp' , ->>>HIST_CATCHCN<<< 'BTRANT' , 'GridComp' , 'BTRAN' , ->>>HIST_CATCHCN<<< 'SIF' , 'GridComp' , ->>>HIST_CATCHCN<<< 'CNLOSS' , 'GridComp' , 'CLOSS' , ->>>HIST_CATCHCN<<< 'CNBURN' , 'GridComp' , 'BURN' , ->>>HIST_CATCHCN<<< 'CNFSEL' , 'GridComp' , 'FSEL' , ->>>HIST_CATCHCN<<< 'EVPSNO' , 'GridComp' , ->>>HIST_CATCHCN<<< 'GHTSKIN' , 'GridComp' , ->>>HIST_CATCHCN<<< 'WAT10CM' , 'GridComp' , ->>>HIST_CATCHCN<<< 'WATSOI' , 'GridComp' , ->>>HIST_CATCHCN<<< 'ICESOI' , 'GridComp' , ->>>HIST_IRRIG<<< 'IRRIGRATE' , 'GridComp' , - :: - - SMAP_L4_SM_gph.descr: 'Tile-space,3-Hourly,Time-Averaged,Single-Level,Assimilation,SMAP L4_SM Land Geophysical Diagnostics', - SMAP_L4_SM_gph.nbits: 12, - SMAP_L4_SM_gph.template: '%y4%m2%d2_%h2%n2z.bin', - SMAP_L4_SM_gph.mode: 'time-averaged', - SMAP_L4_SM_gph.frequency: 030000, - SMAP_L4_SM_gph.ref_time: 000000, - SMAP_L4_SM_gph.fields: 'WCSF' , 'ENSAVG' , 'sm_surface' , - 'WCRZ' , 'ENSAVG' , 'sm_rootzone' , - 'WCPR' , 'ENSAVG' , 'sm_profile' , - 'WET1' , 'ENSAVG' , 'sm_surface_wetness' , - 'WET2' , 'ENSAVG' , 'sm_rootzone_wetness' , - 'WET3' , 'ENSAVG' , 'sm_profile_wetness' , - 'TPSURF' , 'ENSAVG' , 'surface_temp' , - 'TSOIL1TILE' , 'ENSAVG' , 'soil_temp_layer1' , - 'TSOIL2TILE' , 'ENSAVG' , 'soil_temp_layer2' , - 'TSOIL3TILE' , 'ENSAVG' , 'soil_temp_layer3' , - 'TSOIL4TILE' , 'ENSAVG' , 'soil_temp_layer4' , - 'TSOIL5TILE' , 'ENSAVG' , 'soil_temp_layer5' , - 'TSOIL6TILE' , 'ENSAVG' , 'soil_temp_layer6' , - 'SNOWMASS' , 'ENSAVG' , 'snow_mass' , - 'SNOWDP' , 'ENSAVG' , 'snow_depth' , - 'EVLAND' , 'ENSAVG' , 'land_evapotranspiration_flux' , - 'RUNSURF' , 'ENSAVG' , 'overland_runoff_flux' , - 'BASEFLOW' , 'ENSAVG' , 'baseflow_flux' , - 'SMLAND' , 'ENSAVG' , 'snow_melt_flux' , - 'QINFIL' , 'ENSAVG' , 'soil_water_infiltration_flux' , - 'FRSAT' , 'ENSAVG' , 'land_fraction_saturated' , - 'FRUST' , 'ENSAVG' , 'land_fraction_unsaturated' , - 'FRWLT' , 'ENSAVG' , 'land_fraction_wilting' , - 'ASNOW' , 'ENSAVG' , 'land_fraction_snow_covered' , - 'SHLAND' , 'ENSAVG' , 'heat_flux_sensible' , - 'LHLAND' , 'ENSAVG' , 'heat_flux_latent' , - 'GHLAND' , 'ENSAVG' , 'heat_flux_ground' , - 'SWLAND' , 'ENSAVG' , 'net_downward_shortwave_flux' , - 'LWLAND' , 'ENSAVG' , 'net_downward_longwave_flux' , - 'SWDOWNLAND' , 'ENSAVG' , 'radiation_shortwave_downward_flux' , - 'LWDNSRF' , 'ENSAVG' , 'radiation_longwave_absorbed_flux' , - 'RainfSnowf' , 'ENSAVG' , 'precipitation_total_surface_flux' , - 'SNO' , 'ENSAVG' , 'snowfall_surface_flux' , - 'PS' , 'ENSAVG' , 'surface_pressure' , - 'DZ' , 'ENSAVG' , 'height_lowatmmodlay' , - 'TA' , 'ENSAVG' , 'temp_lowatmmodlay' , - 'QA' , 'ENSAVG' , 'specific_humidity_lowatmmodlay' , - 'UU' , 'ENSAVG' , 'windspeed_lowatmmodlay' , - 'GRN' , 'VEGDYN' , 'vegetation_greenness_fraction' , - 'LAI' , 'VEGDYN' , 'leaf_area_index' , - 'PEATCLSM_WATERLEVEL', 'ENSAVG' , 'depth_to_water_table_from_surface_in_peat' , - 'PEATCLSM_FSWCHANGE' , 'ENSAVG' , 'free_surface_water_on_peat_flux' , - 'MWRTM_VEGOPACITY' , 'LANDASSIM' , 'mwrtm_vegopacity', , - :: - - inst1_1d_lnr_Nt.descr: 'Tile-space,1-Hourly,Instantaneous,Single-Level,Assimilation,Land Nature Run Diagnostics', - inst1_1d_lnr_Nt.nbits: 12, - inst1_1d_lnr_Nt.template: '%y4%m2%d2_%h2%n2z.bin' , - inst1_1d_lnr_Nt.mode: 'instantaneous' , - inst1_1d_lnr_Nt.frequency: 010000 , - inst1_1d_lnr_Nt.ref_time: 000000, - inst1_1d_lnr_Nt.fields: 'TPSURF' , 'ENSAVG' , 'surface_temp' , - 'TSOIL1TILE' , 'ENSAVG' , 'soil_temp_layer1' , - 'TPSNOW' , 'ENSAVG' , 'snow_temp_layer1' , - 'TB_LAND_1410MHZ_40DEG_HPOL' , 'LANDASSIM' , 'tb_h' , - 'TB_LAND_1410MHZ_40DEG_VPOL' , 'LANDASSIM' , 'tb_v' , - :: - -# For catch_progn_incr, *.frequency and *.ref_time must be consistent with the LDAS.rc resource -# parameters LANDASSIM_DT and LANDASSIM_T0. -# By default, no bit shaving for increments output. - - catch_progn_incr.descr: 'Tile-space,3-Hourly,Instantaneous,Single-Level,Assimilation,Ensemble-Average Land Prognostics Increments', - catch_progn_incr.template: '%y4%m2%d2_%h2%n2z.bin', - catch_progn_incr.mode: 'instantaneous', - catch_progn_incr.frequency: 030000, - catch_progn_incr.ref_time: 000000, - catch_progn_incr.fields: 'TCFSAT_INCR' , 'LANDASSIM' , - 'TCFTRN_INCR' , 'LANDASSIM' , - 'TCFWLT_INCR' , 'LANDASSIM' , - 'QCFSAT_INCR' , 'LANDASSIM' , - 'QCFTRN_INCR' , 'LANDASSIM' , - 'QCFWLT_INCR' , 'LANDASSIM' , - 'CAPAC_INCR' , 'LANDASSIM' , - 'CATDEF_INCR' , 'LANDASSIM' , - 'RZEXC_INCR' , 'LANDASSIM' , - 'SRFEXC_INCR' , 'LANDASSIM' , - 'GHTCNT1_INCR' , 'LANDASSIM' , - 'GHTCNT2_INCR' , 'LANDASSIM' , - 'GHTCNT3_INCR' , 'LANDASSIM' , - 'GHTCNT4_INCR' , 'LANDASSIM' , - 'GHTCNT5_INCR' , 'LANDASSIM' , - 'GHTCNT6_INCR' , 'LANDASSIM' , - 'WESNN1_INCR' , 'LANDASSIM' , - 'WESNN2_INCR' , 'LANDASSIM' , - 'WESNN3_INCR' , 'LANDASSIM' , - 'HTSNNN1_INCR' , 'LANDASSIM' , - 'HTSNNN2_INCR' , 'LANDASSIM' , - 'HTSNNN3_INCR' , 'LANDASSIM' , - 'SNDZN1_INCR' , 'LANDASSIM' , - 'SNDZN2_INCR' , 'LANDASSIM' , - 'SNDZN3_INCR' , 'LANDASSIM' , - :: - -# For lndfcstana, *.frequency and *.ref_time must be consistent with the LDAS.rc resource -# parameters LANDASSIM_DT and LANDASSIM_T0. -# Output of the ensemble std-dev (ENSSTD) requires simultaneous output of the ensemble mean. If the -# ensemble mean is not written out for a given field, that field's ENSSTD output will be MAPL_UNDEF. - - inst3_1d_lndfcstana_Nt.descr: 'Tile-space,3-Hourly,Instantaneous,Single-Level,Assimilation,Ensemble Land Forecast and Analysis Diagnostics', - inst3_1d_lndfcstana_Nt.nbits: 12, - inst3_1d_lndfcstana_Nt.template: '%y4%m2%d2_%h2%n2z.bin', - inst3_1d_lndfcstana_Nt.mode: 'instantaneous', - inst3_1d_lndfcstana_Nt.frequency: 030000, - inst3_1d_lndfcstana_Nt.ref_time: 000000, - inst3_1d_lndfcstana_Nt.fields: 'WCSF' , 'ENSAVG' , 'SFMC_FCST' , - 'WCRZ' , 'ENSAVG' , 'RZMC_FCST' , - 'WCPR' , 'ENSAVG' , 'PRMC_FCST' , - 'TPSURF' , 'ENSAVG' , 'TSURF_FCST' , - 'TSOIL1TILE' , 'ENSAVG' , 'TSOIL1_FCST' , - 'WCSF_ENSSTD' , 'ENSAVG' , 'SFMC_FCST_ENSSTD' , - 'WCRZ_ENSSTD' , 'ENSAVG' , 'RZMC_FCST_ENSSTD' , - 'WCPR_ENSSTD' , 'ENSAVG' , 'PRMC_FCST_ENSSTD' , - 'TPSURF_ENSSTD' , 'ENSAVG' , 'TSURF_FCST_ENSSTD' , - 'TSOIL1TILE_ENSSTD' , 'ENSAVG' , 'TSOIL1_FCST_ENSSTD' , - 'WCSF_ANA' , 'LANDASSIM' , 'SFMC_ANA' , - 'WCRZ_ANA' , 'LANDASSIM' , 'RZMC_ANA' , - 'WCPR_ANA' , 'LANDASSIM' , 'PRMC_ANA' , - 'TPSURF_ANA' , 'LANDASSIM' , 'TSURF_ANA' , - 'TSOIL1_ANA' , 'LANDASSIM' , 'TSOIL1_ANA' , - 'WCSF_ANA_ENSSTD' , 'LANDASSIM' , 'SFMC_ANA_ENSSTD' , - 'WCRZ_ANA_ENSSTD' , 'LANDASSIM' , 'RZMC_ANA_ENSSTD' , - 'WCPR_ANA_ENSSTD' , 'LANDASSIM' , 'PRMC_ANA_ENSSTD' , - 'TPSURF_ANA_ENSSTD' , 'LANDASSIM' , 'TSURF_ANA_ENSSTD' , - 'TSOIL1_ANA_ENSSTD' , 'LANDASSIM' , 'TSOIL1_ANA_ENSSTD' - :: - -# For lndfcstana, *.frequency and *.ref_time must be consistent with the LDAS.rc resource -# parameters LANDASSIM_DT and LANDASSIM_T0. -# Output of the ensemble std-dev (ENSSTD) requires simultaneous output of the ensemble mean. If the -# ensemble mean is not written out for a given field, that field's ENSSTD output will be MAPL_UNDEF. - - inst3_2d_lndfcstana_Nx.descr: '2d,3-Hourly,Instantaneous,Single-Level,Assimilation,Ensemble Land Forecast and Analysis Diagnostics', - inst3_2d_lndfcstana_Nx.nbits: 12, - inst3_2d_lndfcstana_Nx.template: '%y4%m2%d2_%h2%n2z.nc4', - inst3_2d_lndfcstana_Nx.archive: '%c/Y%y4', - inst3_2d_lndfcstana_Nx.mode: 'instantaneous', - inst3_2d_lndfcstana_Nx.frequency: 030000, - inst3_2d_lndfcstana_Nx.ref_time: 000000, - inst3_2d_lndfcstana_Nx.format: 'CFIO', - inst3_2d_lndfcstana_Nx.regrid_exch: '../input/tile.data', - inst3_2d_lndfcstana_Nx.regrid_name: 'GRIDNAME', - inst3_2d_lndfcstana_Nx.grid_label: PC720x361-DC, - inst3_2d_lndfcstana_Nx.deflate: 2, - inst3_2d_lndfcstana_Nx.fields: 'WCSF' , 'ENSAVG' , 'SFMC_FCST' , - 'WCRZ' , 'ENSAVG' , 'RZMC_FCST' , - 'WCPR' , 'ENSAVG' , 'PRMC_FCST' , - 'TPSURF' , 'ENSAVG' , 'TSURF_FCST' , - 'TSOIL1TILE' , 'ENSAVG' , 'TSOIL1_FCST' , - 'WCSF_ENSSTD' , 'ENSAVG' , 'SFMC_FCST_ENSSTD' , - 'WCRZ_ENSSTD' , 'ENSAVG' , 'RZMC_FCST_ENSSTD' , - 'WCPR_ENSSTD' , 'ENSAVG' , 'PRMC_FCST_ENSSTD' , - 'TPSURF_ENSSTD' , 'ENSAVG' , 'TSURF_FCST_ENSSTD' , - 'TSOIL1TILE_ENSSTD' , 'ENSAVG' , 'TSOIL1_FCST_ENSSTD' , - 'WCSF_ANA' , 'LANDASSIM' , 'SFMC_ANA' , - 'WCRZ_ANA' , 'LANDASSIM' , 'RZMC_ANA' , - 'WCPR_ANA' , 'LANDASSIM' , 'PRMC_ANA' , - 'TPSURF_ANA' , 'LANDASSIM' , 'TSURF_ANA' , - 'TSOIL1_ANA' , 'LANDASSIM' , 'TSOIL1_ANA' , - 'WCSF_ANA_ENSSTD' , 'LANDASSIM' , 'SFMC_ANA_ENSSTD' , - 'WCRZ_ANA_ENSSTD' , 'LANDASSIM' , 'RZMC_ANA_ENSSTD' , - 'WCPR_ANA_ENSSTD' , 'LANDASSIM' , 'PRMC_ANA_ENSSTD' , - 'TPSURF_ANA_ENSSTD' , 'LANDASSIM' , 'TSURF_ANA_ENSSTD' , - 'TSOIL1_ANA_ENSSTD' , 'LANDASSIM' , 'TSOIL1_ANA_ENSSTD' - :: - -# ========================== EOF ============================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc b/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc deleted file mode 100644 index df92fdb0..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/GEOSldas_LDAS.rc +++ /dev/null @@ -1,259 +0,0 @@ -#################################################################################### -# # -# GEOSldas Resource Parameters # -# # -# Values below override the hardcoded default values # -# in *.F90 calls to MAPL_GetResource(). # -# # -# Users can further override the values below by # -# editing the "exeinp" file during ldas setup. # -# # -#################################################################################### - - -# ---- Using Catchment[CN] offline? -# -# 0: DEFAULT for GCM, (WW,CH,CM,CQ,FR) are required in Catchment restart file -# 1: DEFAULT for GEOSldas, (WW,CH,CM,CQ,FR) are optional -# 2: Option for GEOSldas, (WW,CH,CM,CQ,FR) are optional for input restart but will be in output -# restart; select when using GEOSldas to create restarts for the GCM. -# -CATCHMENT_OFFLINE: 1 - - -# ---- Catchment[CN] spinup mode -# -# 0 : No spinup (default) -# 1 : remove snow every Aug 1 in N. Hemisphere and every Feb 1 in S. Hemisphere -# -CATCHMENT_SPINUP: 0 - - -# ---- Choice of land surface model -# -# 1 : Catchment model (default) -# 2 : CatchmentCN-CLM4.0 -# -LSM_CHOICE: 1 - - -# ---- Domain definition -# -# The domain is determined by specifying a lat/lon rectangle in conjunction -# with ExcludeList and IncludeList files. The files contain the IDs of tiles to -# be excluded and included in the domain. -# Included are all tiles within the rectangle or the IncludeList but not in the ExcludeList. -# In case of conflict, the ExcludeList takes precedence. -# The default is a GLOBAL (land) domain. -# -# Specify extremities of lat/lon rectangle: -# Max lat/lon range: lon=-180:180, lat=-90:90. -# If only IncludeList should be used, specify dummy values such that: -# MINLON > MAXLON and MINLAT > MAXLAT. -# -# MINLON: -180. -# MAXLON: 180. -# MINLAT: -90. -# MAXLAT: 90. -# -# Path and filenames for ExcludeList and IncludeList files. -# (May leave blank.) -# -# EXCLUDE_FILE: '' -# INCLUDE_FILE: '' - - -# ---- Surface meteorological forcing: Horizonal interpolation -# -# 1 : bilinear interpolation (default) -# 0 : nearest neighbor -# -# When forcing is on CS grid, must set MET_HINTERP: 0 -# -MET_HINTERP: 1 - - -# ---- Specify if running model only or data assimilation -# -# NO : model only, with or without perturbations (default) -# YES : assimilation (full land analysis or just processing of obs for "innovations" output) -# -LAND_ASSIM: NO - -# ---- Specify land assimilation times (when "LAND_ASSIM: YES") -# -# LANDASSIM_DT : land analysis time step (seconds) -# LANDASSIM_T0 : land analysis "reference" time (hhmmss) -# -# LANDASSIM_T0 ("T0") and LANDASSIM_DT ("DT") define an infinite sequence of land analysis times: -# -# ..., T0-3*DT, T0-2*DT, T0-DT, T0, T0+DT, T0+2*DT, T0+3*DT, ... -# -# There is never a land analysis at the restart time. Otherwise, the land analysis times are -# independent of the restart time. There may be a land analysis at the final time. -# -# LANDASSIM_DT must be <=86400s, be a multiple of HEARTBEAT_DT, and evenly divide a day. -# Consequently, only HHMMSS information is needed for LANDASSIM_T0. -# -# Examples: -# T0=013000, DT=10800s --> land analysis whenever model time reaches 1:30z, 4:30z, ..., 22:30z. -# T0=163000, DT=10800s --> land analysis whenever model time reaches 1:30z, 4:30z, ..., 22:30z. -# T0=120000, DT=21600s --> land analysis whenever model time reaches 0z, 6z, 12z, and 18z. -# -# LANDASSIM_DT and LANDASSIM_T0 work almost but not quite like "frequency" and "reftime" from MAPL -# HISTORY. The difference is that MAPL HISTORY will not write output until "reftime" even when -# (reftime - restarttime)/frequency > 1. E.g., if frequency=3h, reftime=9z, and restarttime=0z, -# then MAPL HISTORY will not write output until 9z, whereas with DT=3h, T0=9z, and restarttime=0z, -# the land analysis will be run at 3z, 6z, 9z, 12z, ... -# -# LANDASSIM_DT: 10800 -# LANDASSIM_T0: 000000 - - -# ---- Perturbations: On/off -# -# If num_ensemble > 1, PERTURBATIONS will automatically be set to 1. -# -# 0 : No perturbactions. -# 1 : With perturbations. -# -PERTURBATIONS: 0 - -# ---- Perturbations: ID of first ensemble member -# -FIRST_ENS_ID: 0 - - -# ---- Ensemble forcing -# -# NO : Deterministic met forcing (default) -# YES : Ensemble met forcing -# - Typically used in land-atmosphere data assimilation (LADAS) configuration -# when coupled to 4dHybridEnVar ADAS. -# - Must have forcing with matching ensemble ID for each land ensemble member. -# - Forcing files must be stored in member-specific directories MET_PATH[NNN]/, -# where NNN is the 3-digit ensemble ID. -# - User-specified MET_PATH and MET_TAG must not contain ensemble IDs. -# - FIRST_ENS_ID may be used to align ensemble IDs. -# -ENSEMBLE_FORCING: NO - - -# ---- Path to special namelist input files -# -# Applies only for ensemble simulations. The variable values in the special -# namelist overwrite the DEFAULT values. There may be three files: -# LDASsa_SPECIAL_inputs_ensupd.nml -# LDASsa_SPECIAL_inputs_ensprop.nml -# LDASsa_SPECIAL_inputs_catbias.nml -# -# NML_INPUT_PATH: '' - - -# ---- Path to (L-band) microwave radiative transfer model (mwRTM) parameter files: -# -# [MWRTM_PATH]/[BCS_RESOLUTION]/mwRTM_param.nc4 - static (time-invariant) mwRTM parameters -# [MWRTM_PATH]/[BCS_RESOLUTION]/vegopacity.bin - seaonally-varying clim of veg opacity (OPTIONAL) -# -# Must be provided for -# - output of Tb through HISTORY or -# - Tb assimilation. -# Otherwise, leave unspecified (i.e., use default empty string). -# -# If empty or commented out, GEOSldas will search the restart directory. -# -# Must be tile-space data with resolution matching that of BCS (see BCS_RESOLUTION). -# -# mwRTM_param.nc4 can be created from a binary file with the program mwrtm_bin2nc4.x. -# -# Vegetation attenuation is *either* computed from static parameters (bh, bv, lewt) and LAI -# *or* prescribed from the vegopacity.bin file. If the latter is used, (bh, bv, lewt) must -# be no-data values in mwRTM_param.nc4. -# -# MWRTM_PATH: '' - - -# ---- Job segments: Length -# -# Specify period between GEOSldas.x restart and shutdown. -# Default is the entire simulation period (END_DATE minus BEG_DATE). -# Format: yyyymmdd hhmmss -# -# JOB_SGMT: 00000100 000000 - -# ---- Job segments: Number -# -# One lenkf.j job simulates (NUM_SGMT*JOB_SGMT) time, then re-submits itself. -# Avoid unnecessarily exiting and re-initializing GEOSldas.x by using -# NUM_SGMT=1 (default) and the max possible JOB_SGMT so that (NUM_SGMT*JOB_SGMT) -# completes within the job's wall time limit (12 hours at NCCS). -# If desired, request intermediate restart files using RECORD_FREQUENCY. -# -# NUM_SGMT: 1 - - -# ---- CHECKPOINT file output -# -# By default, CHECKPOINT (restart) files are are written at the end of each job segment. -# Restart files can also be written before exiting GEOSldas.x. -# The following resource parameters specify the frequency and reference time and date. -# -# RECORD_FREQUENCY: 0240000 # hhhmmss (can be greater than 1 day!) -# RECORD_REF_TIME: 000000 # hhmmss (reference time-of-day) -# RECORD_REF_DATE: 19790101 000000 # yyyymmdd hhmmss (date/time after which checkpoints are written) - - -# ---- Output: Write log file (YES/NO)? -# -LDAS_logit: YES - -# ---- Output: HISTORY definition of model diagnostics -# -# User-defined path and filename of output (HISTORY) specification file. -# If empty, ldas_setup will generate a default HISTORY.rc file. -# -# For the "catch_progn_incr" and "lndfcstana" output Collections, the "frequency" and "ref_time" -# settings must be consistent with "LANDASSIM_DT" and "LANDASSIM_T0" (see above). -# -# HISTRC_FILE: '' - -# ---- Concatenate sub-daily nc4 files into daily nc4 files and write monthly-mean output? -# -# Optional post-processing of model diagnostics output into bundled daily files and monthly means. -# Reduces the file count and (optionally) the output volume. -# -# Accurate monthly-means of time-average Collections require setting "ref_time" to "000000" in HISTRC_FILE! -# -# 0 : No post-processing (default). -# 1 : For complete days, concatenate (bundle) sub-daily nc4 files, if any, into daily nc4 files. -# For complete months, write monthly-mean nc4 files. -# 2 : As in 1, but delete daily nc4 files. -# -# POSTPROC_HIST: 0 - - -# ---- Name of file containing Surface GridComp resource parameters -# -SURFRC: LDAS.rc - - -#--------------------------------------------------------# -# Do not change the following parameters in GEOSldas # -#--------------------------------------------------------# - -# ---- No dycore for offline -# -DYCORE: none - -# ---- For MAPL_RestartOptional -# -MAPL_ENABLE_BOOTSTRAP: YES - -#----- Write restart or checkpoint by oserver -# -WRITE_RESTART_BY_OSERVER: NO - -# -# =================================== EOF ========================================== - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml deleted file mode 100644 index 10fdcd6d..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_adapt.nml +++ /dev/null @@ -1,122 +0,0 @@ -! -! namelist of EnKF inputs for adaptive filtering -! -! reichle, 14 Dec 2006 -! reichle, 24 Aug 2007 (added adapt_type=12) -! reichle, 21 Nov 2014 - renamed force_pert_type fields for consistency w/ met_force_type -! %tmp2m --> %tair (but note lower-case!) -! %dpt2m --> %qair (but note lower-case!) -! %wnd --> %wind (but note lower-case!) -! -------------------------------------------------------------------- - -&adapt_inputs - -! choose algorithm for adaptive filtering -! -! adapt_type = 0: no adaptive filtering -! adapt_type = 1: (NOT USED) -! adapt_type = 2: (NOT USED) -! adapt_type = 3: (NO LONGER USED) tuning of P only via time moving average of nOmBxOmB -! adapt_type = 4: (NO LONGER USED) in sync tuning of P and R via time moving average of -! nOmBxOmB (same as Desroziers based on nAmBxOmB and nOmAxOmB because -! with "perfect" EnKF update nOmBxOmB=nAmBxOmB=nOmAxOmB) -! adapt_type = 5: (NO LONGER USED) separate tuning of P and R via time moving average of -! AmBxOmB, HPHt, OmAxOmB, and R -! (a.k.a. "A0005" in RedArk_adapt, Desroziers et al, QJR Met Soc, 2005) -! adapt_type = 6: (NO LONGER USED) separate tuning of P and R via time moving average of -! nOmBxOmB and nOmBtm1xOmBt (Crow and Bolten, GRL, 2007) -! adapt_type = 7-9: (NO LONGER USED) -! adapt_type = 10: separate tuning of P and R via time moving average of -! AmBxOmB, HPHt, OmAxOmB, and R (Desroziers et al, QJR Met Soc, 2005) -! (a.k.a. "A0010" in WRR_3 "RedArk_adapt" -! adapt_type = 11: (NO LONGER USED) same as adapt_type=10 but with computation -! of E[AmB OmB] etc from ensemble -! adapt_type = 12: same as adapt_type=10 but tuning of P only -! -! adding a new adapt_type: -! - in clsm_adapt_routines.F90 write appropriate io_adapt_X, update_adapt_X and -! check "select case(adapt_type)" statement in get_adapt_param() -! - in clsm_ensdrv_main.F90 add necessary variables to declarations and fill -! in new information in each "select case(adapt_type)" - -adapt_type = 0 - -! Misc adapt params - -adapt_misc_param%gamma_P = 0.02 -adapt_misc_param%gamma_R = 0.02 - -adapt_misc_param%delta_P = 0.005 -adapt_misc_param%delta_R = 0.005 - -adapt_misc_param%beta_P = 1.06 -adapt_misc_param%beta_R = 1. - -adapt_misc_param%min_alpha_P = 0.01 -adapt_misc_param%max_alpha_P = 100. - -adapt_misc_param%min_alpha_R = 0.01 -adapt_misc_param%max_alpha_R = 100. - -! Determine if std of given forcing/prognostics perturbations is adaptive -! and which kind of innovations statistics is used for adaptive filtering. -! -! In the code, the variable "Pert_adapt" (N_adapt-by-N_catd) estimates -! the statistics of normalized innovations for different kinds of variables -! such as sfmc, rzmc, tsurf, etc. The latter classification loosely -! follows get_obs_pred(): -! -! 0 = *not* adaptive (default) -! 1 = adapt according to innovations of sfmc -! 2 = adapt according to innovations of rzmc -! 3 = adapt according to innovations of tsurf -! 4 = ... -! -! Mapping of innovations to adaptive feedback is done in two steps: -! -! 1.) Innovations of a given obs species i contribute to the j-th component -! Pert_adapt(j,:) as defined in obs_param(i)%adapt=j -! -! 2.) Perturbations of a given forcing/prognostic variable are adapted -! in response to Pert_adapt(j,:) as defined in the nml variables below. -! -! NOTE: -! Adaptive tuning of obs error covariance R is done for each obs species -! and does not require special mapping. - -adapt_force_pert%pcp = 0 -adapt_force_pert%sw = 0 -adapt_force_pert%lw = 0 -adapt_force_pert%tair = 0 -adapt_force_pert%qair = 0 -adapt_force_pert%wind = 0 - -adapt_progn_pert%tc1 = 0 -adapt_progn_pert%tc2 = 0 -adapt_progn_pert%tc4 = 0 -adapt_progn_pert%qa1 = 0 -adapt_progn_pert%qa2 = 0 -adapt_progn_pert%qa4 = 0 -adapt_progn_pert%capac = 0 -adapt_progn_pert%catdef = 0 -adapt_progn_pert%rzexc = 0 -adapt_progn_pert%srfexc = 0 -adapt_progn_pert%ght(1) = 0 -adapt_progn_pert%ght(2) = 0 -adapt_progn_pert%ght(3) = 0 -adapt_progn_pert%ght(4) = 0 -adapt_progn_pert%ght(5) = 0 -adapt_progn_pert%ght(6) = 0 -adapt_progn_pert%wesn(1) = 0 -adapt_progn_pert%wesn(2) = 0 -adapt_progn_pert%wesn(3) = 0 -adapt_progn_pert%htsn(1) = 0 -adapt_progn_pert%htsn(2) = 0 -adapt_progn_pert%htsn(3) = 0 -adapt_progn_pert%sndz(1) = 0 -adapt_progn_pert%sndz(2) = 0 -adapt_progn_pert%sndz(3) = 0 - -/ - -! =========================== EOF ======================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml deleted file mode 100644 index cfdb79be..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_catbias.nml +++ /dev/null @@ -1,166 +0,0 @@ -! -! DEFAULT namelist of catbias inputs for land EnKF -! -! reichle, 19 Oct 2005 -! reichle+draper, 26 Mar 2013 - renamed to LDASsa_DEFAULT_inputs_catbias.nml -! - revised structures for cat_bias_param -! -! -------------------------------------------------------------------- - -&cat_bias_inputs - -! ---------------------------------------------------------------------- -! -! bias correction is selected by cat_progn field -! -! Nparam indicates how many bias parameters are estimated -! per cat_progn field: -! -! Nparam = 0 - no bias correction -! -! Nparam = 1 - constant bias corr (w/o diurnal cycle) -! -! Nparam = 3 - diurnal sine/cosine bias corr -! Nparam = 5 - semi-diurnal sine/cosine bias corr -! -! Nparam = 2 - "time-of-day" bias corr with 2 separate bias estimates per day -! Nparam = 4 - "time-of-day" bias corr with 4 separate bias estimates per day -! Nparam = 8 - "time-of-day" bias corr with 8 separate bias estimates per day - -cat_bias_param%Nparam%tc1 = 0 ! 1 -cat_bias_param%Nparam%tc2 = 0 ! 1 -cat_bias_param%Nparam%tc4 = 0 ! 1 -cat_bias_param%Nparam%qa1 = 0 -cat_bias_param%Nparam%qa2 = 0 -cat_bias_param%Nparam%qa4 = 0 -cat_bias_param%Nparam%capac = 0 -cat_bias_param%Nparam%catdef = 0 -cat_bias_param%Nparam%rzexc = 0 -cat_bias_param%Nparam%srfexc = 0 -cat_bias_param%Nparam%ght(1) = 0 -cat_bias_param%Nparam%ght(2) = 0 -cat_bias_param%Nparam%ght(3) = 0 -cat_bias_param%Nparam%ght(4) = 0 -cat_bias_param%Nparam%ght(5) = 0 -cat_bias_param%Nparam%ght(6) = 0 -cat_bias_param%Nparam%wesn(1) = 0 -cat_bias_param%Nparam%wesn(2) = 0 -cat_bias_param%Nparam%wesn(3) = 0 -cat_bias_param%Nparam%htsn(1) = 0 -cat_bias_param%Nparam%htsn(2) = 0 -cat_bias_param%Nparam%htsn(3) = 0 -cat_bias_param%Nparam%sndz(1) = 0 -cat_bias_param%Nparam%sndz(2) = 0 -cat_bias_param%Nparam%sndz(3) = 0 - -! --------------------------------------------------------------------------- -! -! The bias estimate is updated from analysis increments whenever observations -! are available. The bias time scale relative to the temporal spacing of -! the observations is described by "tconst_bias". -! -! tconst_bias = dimensionless bias time constant -! -! DEFINITION: P_bias = tconst_bias * P_forecast (P is forecast error cov) -! -! tconst_bias is a.k.a. "gamma" in Dee's 2003 ECWMF proceedings paper -! -! ASSUMPTION: tconst << 1 -! -! CRUDE APPROXIMATION: tconst = dt_obs/tcorr -! -! where dt_obs is the interval between the updates from obs -! and tcorr is the bias time scale -! -! IN MORE DETAIL: -! -! starting from Dee & Todling, MWR, 2000, equation (9) we get -! -! b_k = (1-lambda)*b_(k-1) - lambda*innov -! -! => AR(1) time correlation exp(-dt/tcorr)=(1-lambda) -! -! use lambda = tconst*var_f/(var_f+var_o) to get -! -! tconst = (var_f+var_o)/var_f*(1-exp(-dt/tcorr)) -! -! note that (1-exp(-dt/tcorr)) = dt/tcorr for dt/tcorr<<1 - -cat_bias_param%tconst%tc1 = .2 ! .2 -cat_bias_param%tconst%tc2 = .2 ! .2 -cat_bias_param%tconst%tc4 = .2 ! .2 -cat_bias_param%tconst%qa1 = .2 -cat_bias_param%tconst%qa2 = .2 -cat_bias_param%tconst%qa4 = .2 -cat_bias_param%tconst%capac = .2 -cat_bias_param%tconst%catdef = .2 -cat_bias_param%tconst%rzexc = .2 -cat_bias_param%tconst%srfexc = .2 -cat_bias_param%tconst%ght(1) = .2 -cat_bias_param%tconst%ght(2) = .2 -cat_bias_param%tconst%ght(3) = .2 -cat_bias_param%tconst%ght(4) = .2 -cat_bias_param%tconst%ght(5) = .2 -cat_bias_param%tconst%ght(6) = .2 -cat_bias_param%tconst%wesn(1) = .2 -cat_bias_param%tconst%wesn(2) = .2 -cat_bias_param%tconst%wesn(3) = .2 -cat_bias_param%tconst%htsn(1) = .2 -cat_bias_param%tconst%htsn(2) = .2 -cat_bias_param%tconst%htsn(3) = .2 -cat_bias_param%tconst%sndz(1) = .2 -cat_bias_param%tconst%sndz(2) = .2 -cat_bias_param%tconst%sndz(3) = .2 - -! ----------------------------------------------------------------------- -! -! The underlying model for bias estimation is a constant bias -! (or constant diurnal cycle parameters). Should there be an -! extended period without observations, the bias must be relaxed -! to a reasonable estimate, so as not to get stuck at whatever -! it was when it was last updated. -! For now, the bias is relaxed to zero with a relaxation time specified -! below. (Effectively, this makes the underlying model for the bias -! an exponentially decay.) -! -! "trelax_bias" = bias relaxation time [s] -! -! DEFINITION: Bias(t+1) = exp(-dtstep/trelax_bias)*Bias(t) -! -! where dtstep is the model time step -! -! 1 day = 86400 s -! 2 days = 172800 s -! 7 days = 604800 s -! 14 days = 1209600 s -! 28 days = 2419200 s - -cat_bias_param%trelax%tc1 = 86400. -cat_bias_param%trelax%tc2 = 86400. -cat_bias_param%trelax%tc4 = 86400. -cat_bias_param%trelax%qa1 = 86400. -cat_bias_param%trelax%qa2 = 86400. -cat_bias_param%trelax%qa4 = 86400. -cat_bias_param%trelax%capac = 86400. -cat_bias_param%trelax%catdef = 86400. -cat_bias_param%trelax%rzexc = 86400. -cat_bias_param%trelax%srfexc = 86400. -cat_bias_param%trelax%ght(1) = 86400. -cat_bias_param%trelax%ght(2) = 86400. -cat_bias_param%trelax%ght(3) = 86400. -cat_bias_param%trelax%ght(4) = 86400. -cat_bias_param%trelax%ght(5) = 86400. -cat_bias_param%trelax%ght(6) = 86400. -cat_bias_param%trelax%wesn(1) = 86400. -cat_bias_param%trelax%wesn(2) = 86400. -cat_bias_param%trelax%wesn(3) = 86400. -cat_bias_param%trelax%htsn(1) = 86400. -cat_bias_param%trelax%htsn(2) = 86400. -cat_bias_param%trelax%htsn(3) = 86400. -cat_bias_param%trelax%sndz(1) = 86400. -cat_bias_param%trelax%sndz(2) = 86400. -cat_bias_param%trelax%sndz(3) = 86400. - -/ - -! =========================== EOF ======================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml deleted file mode 100644 index dbb29e84..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensprop.nml +++ /dev/null @@ -1,511 +0,0 @@ -! -! namelist of EnKF inputs -! -! reichle, 23 Mar 2004 -! reichle, 10 May 2005 -! reichle, 21 Nov 2014 - re-interpreted progn_pert as perturbation flux forcing -! - renamed force_pert_type fields for consistency w/ met_force_type -! %tmp2m --> %tair (but note lower-case!) -! %dpt2m --> %qair (but note lower-case!) -! %wnd --> %wind (but note lower-case!) -! -! -------------------------------------------------------------------- - -&ens_prop_inputs - -! -------------------------------------------------------------------- -! -! ensemble size and ID's (integer IDs: first_ens_id:1:first_ens_id+N_ens-1) - -! N_ens and first_id are from landpert_gridcomp -! N_ens= 1 -! first_ens_id= 0 - -! -------------------------------------------------------------------- -! -! FORCING AND PROGNOSTICS PERTURBATIONS -! -! Forcing and prognostics perturbations are auto-regressive, order-one (AR(1)) -! time series of spatially correlated and cross-correlated 2d fields. -! -! The AR(1) time series are generated at intervals governed by "force_pert_dtstep" -! and "progn_pert_dtstep" (typically every 3 hours) with a neutral mean value. -! -! The std-dev of the AR(1) time series ("std"), their temporal correlations -! ("tcorr"), spatial correlations ("xcorr", "ycorr") and cross-correlations among -! variables ("ccorr") are specified via this nml inputs file. -! -! The AR(1) perturbations time series are linearly interpolated to and applied -! at every model time step (typically 7.5 min). (Note that the temporal correlation -! "tcorr" is NOT valid for the temporally interpolated time series.) -! -! Perturbations can be additive or multiplicative. -! -! FORCING perturbations are applied as follows: -! -! F = F + Pert for additive perturbations -! F = F * Pert for multiplicative perturbations -! -! PROGNOSTICS perturbations are interpreted as fluxes and are applied as follows: -! -! P = P + Pert*dt for additive perturbations -! P = P * Pert**dt for multiplicative perturbations -! -! UNITS of std-dev for FORCING perturbations: -! - If perturbations are additive, units match those of the perturbed field. -! - If perturbations are multiplicative, units are dimensionless [fraction]. -! For example, std_force_pert%pcp = 0.5 means that precip is perturbed with a -! std-dev that corresponds to 50% of the magnitude of the nominal precipitation. -! -! UNITS of std-dev for PROGNOSTICS perturbations: -! Prognostics perturbations are interpreted as fluxes so that their impact for -! a given prescribed std-dev does not depend on the model time step (model_dtstep). -! In the above equations for the application of the prognostics perturbations, -! the time step "dt" is in units of HOURS. -! - If perturbations are additive, units are flux PER HOUR into the perturbed field. -! For example, std_progn_pert%catdef = 0.24 kg/m2/HOUR. -! [ In earlier versions of LDASsa, the impact of the perturbations on the perturbed -! field depended on the model_dtstep. -! For example, std_progn_pert%catdef = 0.24 kg/m2/HOUR is equivalent -! to using the following in *earlier* versions of LDASsa: -! std_progn_pert%catdef = 0.03 kg/m2 and model_dtstep= 450s, or -! std_progn_pert%catdef = 0.08 kg/m2 and model_dtstep=1200s. ] -! - If perturbations are multiplicative, units are the dimensionless "flux" PER HOUR -! [fraction/hour]. -! For example, std_progn_pert%snow = 0.0012/HOUR means that snow is perturbed with a -! std-dev that corresponds to 0.12% of the magnitude of the snow pack in one hour. -! [ In earlier versions of LDASsa, the impact of the perturbations on the perturbed -! field depended on the model_dtstep. -! For example, std_progn_pert%catdef = 0.0012/HOUR is equivalent -! to using the following in *earlier* versions of LDASsa: -! std_progn_pert%snow = 0.0004 and model_dtstep=1200s. ] -! -! -! ------------------------------------------------------------------ -! -! all time steps in *seconds* -! -! all time steps MUST obey MOD(86400,dtstep)=0 and 0<=dtstep<=86400 -! -! *_pert_dtstep inputs must also be compatible with model_dtstep, force_dtstep -! and out_dtstep (see subroutine check_pert_dtstep()) -! -! 1200 = 20 min -! 3600 = 1 h -! 7200 = 2 h -! 10800 = 3 h -! 14400 = 4 h -! 21600 = 6 h -! 43200 = 12 h -! 86400 = 24 h - -progn_pert_dtstep = 10800 ! time step for generation of AR(1) prognostics perts [s] - -force_pert_dtstep = 10800 ! time step for generation of AR(1) forcing perts [s] - -! --------------------------------------------------------------------- -! -! forcing error (or forcing perturbation) parameters -! -! the mean is computed according to "typ" for unbiased perturbations -! and not specified here - -! string that describes the kind of forcing perturbations -! (see subroutine apply_force_pert() for details) - -descr_force_pert%pcp = 'pcp' -descr_force_pert%sw = 'sw' -descr_force_pert%lw = 'lw' -descr_force_pert%tair = 'tair' -descr_force_pert%qair = 'qair' -descr_force_pert%wind = 'wind' - -! specify whether forcing perturbations are additive or multiplicative -! -! additive: typ = 0. -! multiplicative and lognormal: typ = 1. -! -! real numbers are used so that "assemble_force()" can -! be used to assemble the forcing perturbation parameters - -typ_force_pert%pcp = 1. -typ_force_pert%sw = 1. -typ_force_pert%lw = 0. -typ_force_pert%tair = 0. -typ_force_pert%qair = 0. -typ_force_pert%wind = 1. - -! The perturbation (or error) std-dev can be specified as a spatially constant -! (default) value. Alternatively, perturbation std-dev values can be read from -! a netcdf-4 input file (where they may be spatially constant or distributed). -! See subroutines get_progn_pert_param() and get_force_pert_param(). -! -! Turn off all perturbations by setting std-dev values to zero and -! "stdfromfile" to false. -! -! Default, spatially homogeneous perturbations std-dev -! (used unless std-devs are read from file, see below) - -std_force_pert%pcp = 0. ! units if additive: [kg/m2/s], if multiplicative: [fraction] -std_force_pert%sw = 0. ! units if additive: [W/m^2] , if multiplicative: [fraction] -std_force_pert%lw = 0. ! units if additive: [W/m^2] , if multiplicative: [fraction] -std_force_pert%tair = 0. ! units if additive: [K] , if multiplicative: [fraction] -std_force_pert%qair = 0. ! units if additive: [kg/kg] , if multiplicative: [fraction] -std_force_pert%wind = 0. ! units if additive: [m/s] , if multiplicative: [fraction] - -! read error std-dev from file? (if .false., default values above apply) - -stdfromfile_force_pert%pcp = .false. -stdfromfile_force_pert%sw = .false. -stdfromfile_force_pert%lw = .false. -stdfromfile_force_pert%tair = .false. -stdfromfile_force_pert%qair = .false. -stdfromfile_force_pert%wind = .false. - -! specify file name (with full path) that contains std-dev values - -stdfilename_force_pert = '' - -! enforce zero (sample) mean across ensemble? - -zeromean_force_pert%pcp = .true. -zeromean_force_pert%sw = .true. -zeromean_force_pert%lw = .true. -zeromean_force_pert%tair = .true. -zeromean_force_pert%qair = .true. -zeromean_force_pert%wind = .true. - -! allow perturbations to be computed on coarsened grid? - -coarsen_force_pert%pcp = .false. -coarsen_force_pert%sw = .false. -coarsen_force_pert%lw = .false. -coarsen_force_pert%tair = .false. -coarsen_force_pert%qair = .false. -coarsen_force_pert%wind = .false. - -! max perturbation relative to standard normal -! (limits on range of random numbers: specify max absolute value -! allowed to be drawn from a standard normal distribution) - -std_normal_max_force_pert%pcp = 2.5 -std_normal_max_force_pert%sw = 2.5 -std_normal_max_force_pert%lw = 2.5 -std_normal_max_force_pert%tair = 2.5 -std_normal_max_force_pert%qair = 2.5 -std_normal_max_force_pert%wind = 2.5 - -! spatial correlation of forcing perturbations - -xcorr_force_pert%pcp = 0. ! [deg] -xcorr_force_pert%sw = 0. ! [deg] -xcorr_force_pert%lw = 0. ! [deg] -xcorr_force_pert%tair = 0. ! [deg] -xcorr_force_pert%qair = 0. ! [deg] -xcorr_force_pert%wind = 0. ! [deg] - -ycorr_force_pert%pcp = 0. ! [deg] -ycorr_force_pert%sw = 0. ! [deg] -ycorr_force_pert%lw = 0. ! [deg] -ycorr_force_pert%tair = 0. ! [deg] -ycorr_force_pert%qair = 0. ! [deg] -ycorr_force_pert%wind = 0. ! [deg] - -! temporal correlation of forcing perturbations - -tcorr_force_pert%pcp = 86400. ! [s] -tcorr_force_pert%sw = 86400. ! [s] -tcorr_force_pert%lw = 86400. ! [s] -tcorr_force_pert%tair = 86400. ! [s] -tcorr_force_pert%qair = 86400. ! [s] -tcorr_force_pert%wind = 86400. ! [s] - -! correlation coefficients -1 <= rho <= 1 -! -! specify only essential information, the other side of off-diagonals and -! the diagonal will be filled in later (subroutines read_ens_prop_inputs -! and get_force_pert_inputs) - -ccorr_force_pert%pcp%sw = 0. !-.8 -ccorr_force_pert%pcp%lw = 0. ! .5 -ccorr_force_pert%pcp%tair = 0. -ccorr_force_pert%pcp%qair = 0. -ccorr_force_pert%pcp%wind = 0. - -ccorr_force_pert%sw%lw = 0. ! -.6 ! -.5 -ccorr_force_pert%sw%tair = 0. ! .4 ! .8 -ccorr_force_pert%sw%qair = 0. -ccorr_force_pert%sw%wind = 0. - -ccorr_force_pert%lw%tair = 0 ! .4 ! .8 -ccorr_force_pert%lw%qair = 0. -ccorr_force_pert%lw%wind = 0. - -ccorr_force_pert%tair%qair = 0. ! .9 -ccorr_force_pert%tair%wind = 0. - -ccorr_force_pert%qair%wind = 0. - - - -! --------------------------------------------------------------------- -! -! model error (or progn_pert) parameters -! -! the mean is computed according to "typ" for unbiased perturbations -! and not specified here - -! string that describes the prognostics to be perturbed -! (see subroutine apply_progn_pert() for details) - -descr_progn_pert%catdef = 'catdef' -descr_progn_pert%rzexc = 'rzexc' -descr_progn_pert%srfexc = 'srfexc' -descr_progn_pert%snow = 'snow' -descr_progn_pert%tc = 'tc' -descr_progn_pert%ght(1) = 'ght1' -descr_progn_pert%ght(2) = 'ght2' -descr_progn_pert%ght(3) = 'ght3' -descr_progn_pert%ght(4) = 'ght4' -descr_progn_pert%ght(5) = 'ght5' -descr_progn_pert%ght(6) = 'ght6' - - -! specify whether model error is additive or multiplicative -! -! additive: typ = 0. -! multiplicative and lognormal: typ = 1. -! -! real numbers are used so that "assemble_state()" can -! be used to assemble the model error parameters - -typ_progn_pert%catdef = 0. -typ_progn_pert%rzexc = 0. -typ_progn_pert%srfexc = 0. -typ_progn_pert%snow = 1. -typ_progn_pert%tc = 0. -typ_progn_pert%ght(1) = 0. -typ_progn_pert%ght(2) = 0. -typ_progn_pert%ght(3) = 0. -typ_progn_pert%ght(4) = 0. -typ_progn_pert%ght(5) = 0. -typ_progn_pert%ght(6) = 0. - - -! The perturbation (or error) std-dev can be specified as a spatially constant -! (default) value. Alternatively, perturbation std-dev values can be read from -! a netcdf-4 input file (where they may be spatially constant or distributed). -! See subroutines get_progn_pert_param() and get_force_pert_param(). -! -! Turn off all perturbations by setting std-dev values to zero and -! "stdfromfile" to false. -! -! Default, spatially homogeneous perturbations std-dev -! (used unless std-devs are read from file, see below) - -std_progn_pert%catdef = 0. ! units if additive: [kg/m2/HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%rzexc = 0. ! units if additive: [kg/m2/HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%srfexc = 0. ! units if additive: [kg/m2/HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%snow = 0. ! units if additive: [kg/m2/HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%tc = 0. ! units if additive: [K /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(1) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(2) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(3) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(4) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(5) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] -std_progn_pert%ght(6) = 0. ! units if additive: [J /HOUR], if multiplicative: [fraction/HOUR] - -! GHT perturbations: -! -! for non-frozen conditions, ght(i) ~ 2.e6*dzgt(i)*tp(i) [deg C] -! -! std_progn_pert%ght(1) = 50000. ! translates into ~0.2 K -! std_progn_pert%ght(2) = 100000. ! translates into ~0.2 K -! std_progn_pert%ght(3) = 200000. ! translates into ~0.2 K -! std_progn_pert%ght(4) = 400000. ! translates into ~0.2 K -! std_progn_pert%ght(5) = 800000. ! translates into ~0.2 K -! std_progn_pert%ght(6) = 5000000. ! translates into ~0.2 K - -! read error std-dev from file? (if .false., default values above apply) - -stdfromfile_progn_pert%catdef = .false. -stdfromfile_progn_pert%rzexc = .false. -stdfromfile_progn_pert%srfexc = .false. -stdfromfile_progn_pert%snow = .false. -stdfromfile_progn_pert%tc = .false. -stdfromfile_progn_pert%ght(1) = .false. -stdfromfile_progn_pert%ght(2) = .false. -stdfromfile_progn_pert%ght(3) = .false. -stdfromfile_progn_pert%ght(4) = .false. -stdfromfile_progn_pert%ght(5) = .false. -stdfromfile_progn_pert%ght(6) = .false. - -! specify file name (with full path) that contains std-dev values - -stdfilename_progn_pert = '' - -! enforce zero (sample) mean across ensemble? - -zeromean_progn_pert%catdef = .true. -zeromean_progn_pert%rzexc = .true. -zeromean_progn_pert%srfexc = .true. -zeromean_progn_pert%snow = .true. -zeromean_progn_pert%tc = .true. -zeromean_progn_pert%ght(1) = .true. -zeromean_progn_pert%ght(2) = .true. -zeromean_progn_pert%ght(3) = .true. -zeromean_progn_pert%ght(4) = .true. -zeromean_progn_pert%ght(5) = .true. -zeromean_progn_pert%ght(6) = .true. - - -! allow perturbations to be computed on coarsened grid? - -coarsen_progn_pert%catdef = .false. -coarsen_progn_pert%rzexc = .false. -coarsen_progn_pert%srfexc = .false. -coarsen_progn_pert%snow = .false. -coarsen_progn_pert%tc = .false. -coarsen_progn_pert%ght(1) = .false. -coarsen_progn_pert%ght(2) = .false. -coarsen_progn_pert%ght(3) = .false. -coarsen_progn_pert%ght(4) = .false. -coarsen_progn_pert%ght(5) = .false. -coarsen_progn_pert%ght(6) = .false. - - -! max perturbation relative to standard normal -! (limits on range of random numbers: specify max absolute value -! allowed to be drawn from a standard normal distribution) - -std_normal_max_progn_pert%catdef = 2.5 -std_normal_max_progn_pert%rzexc = 2.5 -std_normal_max_progn_pert%srfexc = 2.5 -std_normal_max_progn_pert%snow = 2.5 -std_normal_max_progn_pert%tc = 2.5 -std_normal_max_progn_pert%ght(1) = 2.5 -std_normal_max_progn_pert%ght(2) = 2.5 -std_normal_max_progn_pert%ght(3) = 2.5 -std_normal_max_progn_pert%ght(4) = 2.5 -std_normal_max_progn_pert%ght(5) = 2.5 -std_normal_max_progn_pert%ght(6) = 2.5 - - -! model error spatial correlation [deg] -! (x runs east-west, y runs north-south) - -xcorr_progn_pert%catdef = 0. ! [deg] -xcorr_progn_pert%rzexc = 0. ! [deg] -xcorr_progn_pert%srfexc = 0. ! [deg] -xcorr_progn_pert%snow = 0. ! [deg] -xcorr_progn_pert%tc = 0. ! [deg] -xcorr_progn_pert%ght(1) = 0. ! [deg] -xcorr_progn_pert%ght(2) = 0. ! [deg] -xcorr_progn_pert%ght(3) = 0. ! [deg] -xcorr_progn_pert%ght(4) = 0. ! [deg] -xcorr_progn_pert%ght(5) = 0. ! [deg] -xcorr_progn_pert%ght(6) = 0. ! [deg] - -ycorr_progn_pert%catdef = 0. ! [deg] -ycorr_progn_pert%rzexc = 0. ! [deg] -ycorr_progn_pert%srfexc = 0. ! [deg] -ycorr_progn_pert%snow = 0. ! [deg] -ycorr_progn_pert%tc = 0. ! [deg] -ycorr_progn_pert%ght(1) = 0. ! [deg] -ycorr_progn_pert%ght(2) = 0. ! [deg] -ycorr_progn_pert%ght(3) = 0. ! [deg] -ycorr_progn_pert%ght(4) = 0. ! [deg] -ycorr_progn_pert%ght(5) = 0. ! [deg] -ycorr_progn_pert%ght(6) = 0. ! [deg] - -! model error temporal correlation [s] - -tcorr_progn_pert%catdef = 10800. ! [s] -tcorr_progn_pert%rzexc = 10800. ! [s] -tcorr_progn_pert%srfexc = 10800. ! [s] -tcorr_progn_pert%snow = 10800. ! [s] -tcorr_progn_pert%tc = 10800. ! [s] -tcorr_progn_pert%ght(1) = 10800. ! [s] -tcorr_progn_pert%ght(2) = 10800. ! [s] -tcorr_progn_pert%ght(3) = 10800. ! [s] -tcorr_progn_pert%ght(4) = 10800. ! [s] -tcorr_progn_pert%ght(5) = 10800. ! [s] -tcorr_progn_pert%ght(6) = 10800. ! [s] - -! correlation coefficients -1 <= rho <= 1 -! -! specify only essential information, the other side of off-diagonals and -! the diagonal will be filled in later (subroutines read_ens_prop_inputs -! and get_force_pert_inputs) -! -! (the default input list below was put together with matlab -! script create_ccorr_cat_progn_default.m) - -ccorr_progn_pert%catdef%rzexc = 0. -ccorr_progn_pert%catdef%srfexc = 0. -ccorr_progn_pert%catdef%snow = 0. -ccorr_progn_pert%catdef%tc = 0. -ccorr_progn_pert%catdef%ght(1) = 0. -ccorr_progn_pert%catdef%ght(2) = 0. -ccorr_progn_pert%catdef%ght(3) = 0. -ccorr_progn_pert%catdef%ght(4) = 0. -ccorr_progn_pert%catdef%ght(5) = 0. -ccorr_progn_pert%catdef%ght(6) = 0. - -ccorr_progn_pert%rzexc%srfexc = 0. -ccorr_progn_pert%rzexc%snow = 0. -ccorr_progn_pert%rzexc%tc = 0. -ccorr_progn_pert%rzexc%ght(1) = 0. -ccorr_progn_pert%rzexc%ght(2) = 0. -ccorr_progn_pert%rzexc%ght(3) = 0. -ccorr_progn_pert%rzexc%ght(4) = 0. -ccorr_progn_pert%rzexc%ght(5) = 0. -ccorr_progn_pert%rzexc%ght(6) = 0. - -ccorr_progn_pert%srfexc%snow = 0. -ccorr_progn_pert%srfexc%tc = 0. -ccorr_progn_pert%srfexc%ght(1) = 0. -ccorr_progn_pert%srfexc%ght(2) = 0. -ccorr_progn_pert%srfexc%ght(3) = 0. -ccorr_progn_pert%srfexc%ght(4) = 0. -ccorr_progn_pert%srfexc%ght(5) = 0. -ccorr_progn_pert%srfexc%ght(6) = 0. - -ccorr_progn_pert%snow%tc = 0. -ccorr_progn_pert%snow%ght(1) = 0. -ccorr_progn_pert%snow%ght(2) = 0. -ccorr_progn_pert%snow%ght(3) = 0. -ccorr_progn_pert%snow%ght(4) = 0. -ccorr_progn_pert%snow%ght(5) = 0. -ccorr_progn_pert%snow%ght(6) = 0. - -ccorr_progn_pert%tc%ght(1) = 0. -ccorr_progn_pert%tc%ght(2) = 0. -ccorr_progn_pert%tc%ght(3) = 0. -ccorr_progn_pert%tc%ght(4) = 0. -ccorr_progn_pert%tc%ght(5) = 0. -ccorr_progn_pert%tc%ght(6) = 0. - -ccorr_progn_pert%ght(1)%ght(2) = 0. -ccorr_progn_pert%ght(1)%ght(3) = 0. -ccorr_progn_pert%ght(1)%ght(4) = 0. -ccorr_progn_pert%ght(1)%ght(5) = 0. -ccorr_progn_pert%ght(1)%ght(6) = 0. - -ccorr_progn_pert%ght(2)%ght(3) = 0. -ccorr_progn_pert%ght(2)%ght(4) = 0. -ccorr_progn_pert%ght(2)%ght(5) = 0. -ccorr_progn_pert%ght(2)%ght(6) = 0. - -ccorr_progn_pert%ght(3)%ght(4) = 0. -ccorr_progn_pert%ght(3)%ght(5) = 0. -ccorr_progn_pert%ght(3)%ght(6) = 0. - -ccorr_progn_pert%ght(4)%ght(5) = 0. -ccorr_progn_pert%ght(4)%ght(6) = 0. - -ccorr_progn_pert%ght(5)%ght(6) = 0. - -/ - -! =========================== EOF ======================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml b/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml deleted file mode 100644 index ece206c4..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/LDASsa_DEFAULT_inputs_ensupd.nml +++ /dev/null @@ -1,2361 +0,0 @@ -! -! namelist of EnKF inputs for land EnKF update -! -! reichle, 28 Jan 2005 -! reichle, 13 Jun 2011 - updated for SMOS angles and downscaling ("FOV") -! reichle, 8 Jun 2017 - added "%flistpath" and "%flistname"; updated comments -! qliu+reichle, 29 Apr 2020 - added forecast error covariance inflation -! qzhang,wjiang,reichle, -! 7 May 2021 - removed "dtstep_assim" and "centered_update"; replaced with MAPL -! resource parameters "LANDASSIM_DT" and "LANDASSIM_T0" (in LDAS.rc) -! -! -------------------------------------------------------------------- - -&ens_upd_inputs - - -! ---------------------------------------------------------------------- -! -! update type - for details see subroutine cat_enkf_update() -! (note: all 3d updates use compact support) -! -! local = "1d", regional = "3d" -! -! # = no longer supported -! -! update_type = 0: NO assimilation, NO bias correction -! # update_type = 1: 1d soil moisture analysis; sfmc obs -! # update_type = 2: 3d soil moisture analysis; sfmc obs -! update_type = 3: 1d Tskin (assim incr NOT applied, use w/ bias corr) analysis; Tskin obs -! update_type = 4: 1d Tskin/ght1 (assim incr applied, use w/ or w/o bias corr) analysis; Tskin obs -! update_type = 5: 1d Tskin/ght1 (assim incr NOT applied, use w/ bias corr) analysis; Tskin obs -! update_type = 6: 1d soil moisture/Tskin/ght(1); TB obs -! update_type = 7: 3d Tskin/ght1 update; Tskin obs -! update_type = 8: 3d soil moisture/Tskin/ght(1); TB obs -! update_type = 9: 1d Tskin/ght1 update; FT obs -! update_type = 10: 3d soil moisture/Tskin/ght(1) excl. catdef unless PEATCLSM tile; TB obs -! update_type = 13: 3d soil moisture/Tskin/ght(1) excl. catdef unless PEATCLSM tile; sfmc and TB obs - -update_type = 0 - -out_obslog = .true. -out_ObsFcstAna = .false. -out_smapL4SMaup = .false. - -! --------------------------------------------------------------------- -! -! Compact support parameters - for 3d updates -! -! All correlations vanish outside of an ellipse with semi-axes xcompact -! and ycompact - -xcompact = 0. ! [deg] longitude -ycompact = 0. ! [deg] latitude - -! --------------------------------------------------------------------- -! -! forecast error covariance inflaction factor -! -! - assigns more weight to observations in analysis by inflating forecast error covariance -! - works on std-dev, i.e., var_inflated = var * inflation_fac**2 -! - typical values: 1 <= inflation_fac <= 1.5 -! - to turn off, set to any negative real number - -fcsterr_inflation_fac = -9999. - -! --------------------------------------------------------------------- -! -! Definition of measurement species and parameters -! -! NOTE: When additional types of measurements are included here, -! at least the following parameters and subroutines must be adapted: -! -! - N_obs_species_nml in clsm_ensupd_glob_param.f90 -! [- read_ens_upd_inputs()] -! [- collect_obs()] -! - read_obs() -! - get_obs_pred() -! - cat_enkf_update() -! -! -! Definition of obs_param_nml fields (see also enkf_types.F90): -! -! %descr = description -! %species = identifier for type of measurement -! %orbit = type of (half-)orbit -! 0 = n/a [eg., in situ obs] -! 1 = ascending -! 2 = descending -! 3 = ascending or descending -! 4 = geostationary -! %pol = polarization -! 0 = n/a [eg., multi-pol. retrieval] -! 1 = horizontal -! 2 = vertical -! 3 = ... -! %N_ang = # satellite viewing angles in species (radiance obs only) -! %ang = vector of satellite viewing angles -! %freq = frequency [Hz] -! %FOV = field-of-view *radius*, see NOTES below -! (if FOV==0. equate obs footprint w/ tile) -! %FOV_units = field-of-view units ('km' or 'deg'), see NOTES below -! %assim = Should this obs type be assimilated (state update)? (logical) -! %scale = Should this obs be scaled? (logical) -! %getinnov = Should innov be computed for this obs type (logical) -! (innovations are always computed if assim==.true.) -! %RTM_ID = ID of radiative transfer model to use for Tb forward modeling -! (subroutine get_obs_pred()) -! 0 = none -! 1 = L-band tau-omega model as in De Lannoy et al. 2013 (doi:10.1175/JHM-D-12-092.1) (SMOS) -! 2 = same as 1 but without Pellarin atm corr (SMAP) -! 3 = same as 1 but with Mironov and SMAP L2_SM pol mixing (SMOS) -! 4 = same as 3 but without Pellarin atm corr (targeted for SMAP L4_SM Version 8) -! %bias_Npar = number of obs bias states tracked per day (integer) -! %bias_trel = e-folding time scale of obs bias memory [s] -! %bias_tcut = cutoff time for confident obs bias estimate [s] -! %nodata = no-data-value -! %varname = equivalent model variable name (for "Obs_pred") -! %units = units (eg., 'K' or 'm3/m3') -! %path = path to measurement files -! %name = name identifier for file containing measurements -! %maskpath = path to obs mask file -! %maskname = filename for obs mask -! %scalepath = path to file(s) with scaling parameters -! %scalename = filename for scaling parameters -! %flistpath = path to file with list of obs file names -! %flistname = name of file with list of obs file names -! %errstd = default obs error std -! %std_normal_max = maximum allowed perturbation (relative to N(0,1)) -! %zeromean = enforce zero mean across ensemble -! %coarsen_pert = generate obs perturbations on coarser grid (see pert_param_type%coarsen) -! %xcorr = correlation length (deg) in longitude direction -! %ycorr = correlation length (deg) in latitude direction -! -! For observation perturbations, always use: -! -! tcorr = 0. (never temporally correlated) -! typ = 0 (always additive) -! ccorr = 0. (never cross-correlated) -! -! (these are specified in get_obs_pert_inputs() and not here) -! -! -! NOTES: -! -! Field-of-view (FOV) can be specified in units of [km] or [deg] lat/lon. -! Note the special case of FOV=0. below. -! If FOV is specified in units of [km], the FOV in units of [deg] lat/lon that -! is used to compute observation predictions will depend on latitude. -! If FOV is specified in units of [deg] lat/lon, its value remains constant and -! is independent of latitude. -! The choice of units also determines the shape function that is used to -! compute the observation predictions. -! Units of [km] are meant for observations that are based on relatively -! coarse-scale measurements (such as microwave data). The resolution of such obs -! in units of [km] is approximately constant across the globe and independent -! of latitude. Observation predictions are computed by averaging tile-based -! model forecasts out to a distance of fac_search_FOV_km*FOV using a Gaussian kernel, -! where fac_search_FOV_km=2.0 as of 28 March 2015. -! Specifically, the normalized square distance is defined as -! -! ndist2 = dx^2/FOV_x^2 + dy^2/FOV_y^2 -! -! where FOV_x and dx are the meridional FOV and the meridional distance between the obs -! and the tile (in units of deg lat/lon), with FOV_x proportional to 1/cos(lat). -! FOV_y and dy are the corresponding zonal values. -! The weights are then proportional to -! -! exp( -0.5*ndist2 ) -! -! The averaging is therefore over an ellipse in lat/lon space, with weights -! decreasing away from the center of the observation. -! A 2.0*FOV averaging footprint encapsulates about 91% of the power. A 1.0*FOV -! averaging footprint would encapsulate about 47% of the power. These numbers -! are meant to be approximately consistent with FOV numbers for microwave radiometers -! (see 3 Dec 2014 email from Ed Kim reproduced below). -! Note that weights are further adjusted based on tile area. -! Units of [deg] lat/lon are meant for observations that are based on -! relatively high-resolution measurements (such as infrared data). Such -! observations are often available on a lat/lon grid that is much coarser than -! the footprint of the underlying observations. The assimilated data product -! therefore has a resolution that varies with latitude. Observation predictions are -! computed by averaging over a constant kernel out to a distance of FOV. -! The averaging is therefore over a circle in lat/lon space, with weights that do not -! depend on the distance from the center of the observation. -! (Note that weights are further adjusted based on tile area.) -! If FOV=0., observation predictions are computed by assigning the model forecast -! associated with the tile to which the observation is formally assigned. -! This is useful if the resolution of the assimilated observations is higher -! than that of the model tile space. This might be the case for snow-cover-fraction -! observations. FOV=0 can also be useful for tile-based synthetic observations. -! -! -! ------------------------------------------------------------------------ -! -! Date: Wed, 3 Dec 2014 11:21:30 -0600 -! From: -! To: , -! Subject: FW: [SMAP] antenna pattern question -! -! Hi Rolf & Gabrielle, -! -! First, a little terminology: the weighted integral is what Level 1 folks call -! "beam efficiency". So, apparently, Steven is assuming the "-3dB beam efficiency" -! is ~50%. The calculated [SMAP] beam efficiency within the -3dB contour is -! 53.40% (v-pol), 53.83% (h-pol). -! If you draw the -3dB contour on the Earth's surface, for h-pol, 53.83% of the energy -! comes from inside the contour, and 100-53.83 = 46.17% comes from outside the contour. -! The accuracy of the 1/10 and 1/100 digits is questionable, anyway. -! So, if you used 53% for v-pol and 54% for h-pol, you should be fine. -! I guess this means Steven was not far off, if he is using "50%." -! This -3dB beam efficiency means we have significant energy coming from outside -! the 3dB footprint, which is the footprint we use to come up with the "40 km" footprint -! size number. -! And, this is why many folks who use microwave instruments prefer to use a contour that -! encloses a higher % of the beam energy as a better measure of the footprint size. -! One such measure is the "main beam efficiency (MBE)." This beamwidth is usually taken -! to be 2.5 times the 3dB beamwidth. The corresponding footprint size is then -! 2.5x 40km = 100km. -! The last calculation put the MBE at 89.23 for V-pol and 89.33 for H-pol. -! So, for h-pol, 89.33% of the energy comes from inside a 100km footprint, -! and 100-89.33 = 10.67% from outside. -! - Ed -! -! ------------------------------------------------------------------------ -! -! IMPORTANT: The number of measurement species defined below must *match* -! global parameter "N_obs_species_nml" -! -! Multi-angular observations (eg., SMOS) are defined as a single -! species here (in the nml file) and are later split into -! multiple species, each having a unique incidence angle -! (see subroutine read_ens_upd_inputs()) -! -! -! ------------------------------------------------------------------------ - -! 1 = AMSR_E_L2_Soil_Moisture_A (A = ascending = "day") - -obs_param_nml( 1)%descr = 'ae_l2_sm_a' -obs_param_nml( 1)%orbit = 1 -obs_param_nml( 1)%pol = 0 -obs_param_nml( 1)%N_ang = 0 -obs_param_nml( 1)%freq = 10.65e9 -obs_param_nml( 1)%FOV = 20. -obs_param_nml( 1)%FOV_units = 'km' -obs_param_nml( 1)%assim = .false. -obs_param_nml( 1)%scale = .false. -obs_param_nml( 1)%getinnov = .false. -obs_param_nml( 1)%RTM_ID = 0 -obs_param_nml( 1)%bias_Npar = 0 -obs_param_nml( 1)%bias_trel = 864000 -obs_param_nml( 1)%bias_tcut = 432000 -obs_param_nml( 1)%nodata = -9999. -obs_param_nml( 1)%varname = 'sfmc' -obs_param_nml( 1)%units = 'm3/m3' -obs_param_nml( 1)%path = '/land/l_data/AMSR/data/AMSR_E_L2_Land_V001/' -obs_param_nml( 1)%name = 'AMSR_E_L2_Land_' -obs_param_nml( 1)%maskpath = '' -obs_param_nml( 1)%maskname = '' -obs_param_nml( 1)%scalepath = '' -obs_param_nml( 1)%scalename = '' -obs_param_nml( 1)%flistpath = '' -obs_param_nml( 1)%flistname = '' -obs_param_nml( 1)%errstd = .02 -obs_param_nml( 1)%std_normal_max = 2.5 -obs_param_nml( 1)%zeromean = .true. -obs_param_nml( 1)%coarsen_pert = .false. -obs_param_nml( 1)%xcorr = 0.25 -obs_param_nml( 1)%ycorr = 0.25 -obs_param_nml( 1)%adapt = 0 - -! ------------------- -! -! 2 = AMSR_E_L2_Soil_Moisture_D (D = descending = "night") - -obs_param_nml( 2)%descr = 'ae_l2_sm_d' -obs_param_nml( 2)%orbit = 2 -obs_param_nml( 2)%pol = 0 -obs_param_nml( 2)%N_ang = 0 -obs_param_nml( 2)%freq = 10.65e9 -obs_param_nml( 2)%FOV = 20. -obs_param_nml( 2)%FOV_units = 'km' -obs_param_nml( 2)%assim = .false. -obs_param_nml( 2)%scale = .false. -obs_param_nml( 2)%getinnov = .false. -obs_param_nml( 2)%RTM_ID = 0 -obs_param_nml( 2)%bias_Npar = 0 -obs_param_nml( 2)%bias_trel = 864000 -obs_param_nml( 2)%bias_tcut = 432000 -obs_param_nml( 2)%nodata = -9999. -obs_param_nml( 2)%varname = 'sfmc' -obs_param_nml( 2)%units = 'm3/m3' -obs_param_nml( 2)%path = '/land/l_data/AMSR/data/AMSR_E_L2_Land_V001/' -obs_param_nml( 2)%name = 'AMSR_E_L2_Land_' -obs_param_nml( 2)%maskpath = '' -obs_param_nml( 2)%maskname = '' -obs_param_nml( 2)%scalepath = '' -obs_param_nml( 2)%scalename = '' -obs_param_nml( 2)%flistpath = '' -obs_param_nml( 2)%flistname = '' -obs_param_nml( 2)%errstd = .02 -obs_param_nml( 2)%std_normal_max = 2.5 -obs_param_nml( 2)%zeromean = .true. -obs_param_nml( 2)%coarsen_pert = .false. -obs_param_nml( 2)%xcorr = 0.25 -obs_param_nml( 2)%ycorr = 0.25 -obs_param_nml( 2)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 3 = ISCCP_Tskin_GSWP2_grid_V1 - -obs_param_nml( 3)%descr = 'isccp_tskin_gswp2_v1' -obs_param_nml( 3)%orbit = 4 -obs_param_nml( 3)%pol = 0 -obs_param_nml( 3)%N_ang = 0 -obs_param_nml( 3)%freq = 0. -obs_param_nml( 3)%FOV = 0.6 -obs_param_nml( 3)%FOV_units = 'deg' -obs_param_nml( 3)%assim = .false. -obs_param_nml( 3)%scale = .false. -obs_param_nml( 3)%getinnov = .false. -obs_param_nml( 3)%RTM_ID = 0 -obs_param_nml( 3)%bias_Npar = 0 -obs_param_nml( 3)%bias_trel = 864000 -obs_param_nml( 3)%bias_tcut = 432000 -obs_param_nml( 3)%nodata = -9999. -obs_param_nml( 3)%varname = 'tsurf' -obs_param_nml( 3)%units = 'K' -obs_param_nml( 3)%path = '/land/l_data/ISCCP/GSWP2_1by1_V1/' -obs_param_nml( 3)%name = 'isccpdx_tskin.' -obs_param_nml( 3)%maskpath = '' -obs_param_nml( 3)%maskname = '' -obs_param_nml( 3)%scalepath = '' -obs_param_nml( 3)%scalename = '' -obs_param_nml( 3)%flistpath = '' -obs_param_nml( 3)%flistname = '' -obs_param_nml( 3)%errstd = 3. -obs_param_nml( 3)%std_normal_max = 2.5 -obs_param_nml( 3)%zeromean = .true. -obs_param_nml( 3)%coarsen_pert = .false. -obs_param_nml( 3)%xcorr = 0.6 -obs_param_nml( 3)%ycorr = 0.6 -obs_param_nml( 3)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 4 = RedArkOSSE_sm - -obs_param_nml( 4)%descr = 'RedArkOSSE_sm' -obs_param_nml( 4)%orbit = 0 -obs_param_nml( 4)%pol = 0 -obs_param_nml( 4)%N_ang = 0 -obs_param_nml( 4)%freq = 0. -obs_param_nml( 4)%FOV = 0. -obs_param_nml( 4)%FOV_units = 'deg' -obs_param_nml( 4)%assim = .false. -obs_param_nml( 4)%scale = .false. -obs_param_nml( 4)%getinnov = .false. -obs_param_nml( 4)%RTM_ID = 0 -obs_param_nml( 4)%bias_Npar = 0 -obs_param_nml( 4)%bias_trel = 864000 -obs_param_nml( 4)%bias_tcut = 432000 -obs_param_nml( 4)%nodata = -999. -obs_param_nml( 4)%varname = 'sfmc' -obs_param_nml( 4)%units = 'm3/m3' -obs_param_nml( 4)%path = '/land/l_data/RedArk/Retrievals_36km/retrievals_20060508/' -obs_param_nml( 4)%name = 'SM_retrieval.' -obs_param_nml( 4)%maskpath = '' -obs_param_nml( 4)%maskname = '' -obs_param_nml( 4)%scalepath = '.' -obs_param_nml( 4)%scalename = '.' -obs_param_nml( 4)%flistpath = '' -obs_param_nml( 4)%flistname = '' -obs_param_nml( 4)%errstd = .04 -obs_param_nml( 4)%std_normal_max = 2.5 -obs_param_nml( 4)%zeromean = .true. -obs_param_nml( 4)%coarsen_pert = .false. -obs_param_nml( 4)%xcorr = 0. -obs_param_nml( 4)%ycorr = 0. -obs_param_nml( 4)%adapt = 0 - -! ------------------- -! -! 5 = RedArkOSSE_truth_50mm - -obs_param_nml( 5)%descr = 'RedArkOSSE_truth_50mm' -obs_param_nml( 5)%orbit = 0 -obs_param_nml( 5)%pol = 0 -obs_param_nml( 5)%N_ang = 0 -obs_param_nml( 5)%freq = 0. -obs_param_nml( 5)%FOV = 0. -obs_param_nml( 5)%FOV_units = 'deg' -obs_param_nml( 5)%assim = .false. -obs_param_nml( 5)%scale = .false. -obs_param_nml( 5)%getinnov = .false. -obs_param_nml( 5)%RTM_ID = 0 -obs_param_nml( 5)%bias_Npar = 0 -obs_param_nml( 5)%bias_trel = 864000 -obs_param_nml( 5)%bias_tcut = 432000 -obs_param_nml( 5)%nodata = -999. -obs_param_nml( 5)%varname = 'sfmc' -obs_param_nml( 5)%units = 'm3/m3' -obs_param_nml( 5)%path = '/land/l_data/RedArk/Truth/50mm_Soil_Moisture_Truth/' -obs_param_nml( 5)%name = 'red_ark_50mm.sm.' -obs_param_nml( 5)%maskpath = '' -obs_param_nml( 5)%maskname = '' -obs_param_nml( 5)%scalepath = '.' -obs_param_nml( 5)%scalename = '.' -obs_param_nml( 5)%flistpath = '' -obs_param_nml( 5)%flistname = '' -obs_param_nml( 5)%errstd = .0 -obs_param_nml( 5)%std_normal_max = 2.5 -obs_param_nml( 5)%zeromean = .true. -obs_param_nml( 5)%coarsen_pert = .false. -obs_param_nml( 5)%xcorr = 0. -obs_param_nml( 5)%ycorr = 0. -obs_param_nml( 5)%adapt = 0 - -! ------------------- -! -! 6 = RedArkOSSE_truth_400mm - -obs_param_nml( 6)%descr = 'RedArkOSSE_truth_400mm' -obs_param_nml( 6)%orbit = 0 -obs_param_nml( 6)%pol = 0 -obs_param_nml( 6)%N_ang = 0 -obs_param_nml( 6)%freq = 0. -obs_param_nml( 6)%FOV = 0. -obs_param_nml( 6)%FOV_units = 'deg' -obs_param_nml( 6)%assim = .false. -obs_param_nml( 6)%scale = .false. -obs_param_nml( 6)%getinnov = .false. -obs_param_nml( 6)%RTM_ID = 0 -obs_param_nml( 6)%bias_Npar = 0 -obs_param_nml( 6)%bias_trel = 864000 -obs_param_nml( 6)%bias_tcut = 432000 -obs_param_nml( 6)%nodata = -999. -obs_param_nml( 6)%varname = 'rzmc' -obs_param_nml( 6)%units = 'm3/m3' -obs_param_nml( 6)%path = '/land/l_data/RedArk/Truth/400mm_Soil_Moisture_Truth/' -obs_param_nml( 6)%name = 'red_ark_400mm.sm.' -obs_param_nml( 6)%maskpath = '' -obs_param_nml( 6)%maskname = '' -obs_param_nml( 6)%scalepath = '.' -obs_param_nml( 6)%scalename = '.' -obs_param_nml( 6)%flistpath = '' -obs_param_nml( 6)%flistname = '' -obs_param_nml( 6)%errstd = .0 -obs_param_nml( 6)%std_normal_max = 2.5 -obs_param_nml( 6)%zeromean = .true. -obs_param_nml( 6)%coarsen_pert = .false. -obs_param_nml( 6)%xcorr = 0. -obs_param_nml( 6)%ycorr = 0. -obs_param_nml( 6)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 7 = RedArkOSSE_CLSMsynthSM - -obs_param_nml( 7)%descr = 'RedArkOSSE_CLSMsynthSM' -obs_param_nml( 7)%orbit = 0 -obs_param_nml( 7)%pol = 0 -obs_param_nml( 7)%N_ang = 0 -obs_param_nml( 7)%freq = 0. -obs_param_nml( 7)%FOV = 0. -obs_param_nml( 7)%FOV_units = 'deg' -obs_param_nml( 7)%assim = .false. -obs_param_nml( 7)%scale = .false. -obs_param_nml( 7)%getinnov = .false. -obs_param_nml( 7)%RTM_ID = 0 -obs_param_nml( 7)%bias_Npar = 0 -obs_param_nml( 7)%bias_trel = 864000 -obs_param_nml( 7)%bias_tcut = 432000 -obs_param_nml( 7)%nodata = -9999. -obs_param_nml( 7)%varname = 'sfmc' -obs_param_nml( 7)%units = 'm3/m3' -obs_param_nml( 7)%path = '/land/l_data/RedArk_OSSE/data/Retrievals_CLSM_synth/M0001_P0001_R0001_URI/std_synth_obs_0.020/' -obs_param_nml( 7)%name = 'CLSM_synth_sm.' -obs_param_nml( 7)%maskpath = '' -obs_param_nml( 7)%maskname = '' -obs_param_nml( 7)%scalepath = '.' -obs_param_nml( 7)%scalename = '.' -obs_param_nml( 7)%flistpath = '' -obs_param_nml( 7)%flistname = '' -obs_param_nml( 7)%errstd = .04 -obs_param_nml( 7)%std_normal_max = 2.5 -obs_param_nml( 7)%zeromean = .true. -obs_param_nml( 7)%coarsen_pert = .false. -obs_param_nml( 7)%xcorr = 0. -obs_param_nml( 7)%ycorr = 0. -obs_param_nml( 7)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 8 = VivianaOK_CLSMsynthSM - -obs_param_nml( 8)%descr = 'VivianaOK_CLSMsynthSM' -obs_param_nml( 8)%orbit = 0 -obs_param_nml( 8)%pol = 0 -obs_param_nml( 8)%N_ang = 0 -obs_param_nml( 8)%freq = 0. -obs_param_nml( 8)%FOV = 0. -obs_param_nml( 8)%FOV_units = 'deg' -obs_param_nml( 8)%assim = .false. -obs_param_nml( 8)%scale = .false. -obs_param_nml( 8)%getinnov = .false. -obs_param_nml( 8)%RTM_ID = 0 -obs_param_nml( 8)%bias_Npar = 0 -obs_param_nml( 8)%bias_trel = 864000 -obs_param_nml( 8)%bias_tcut = 432000 -obs_param_nml( 8)%nodata = -9999. -obs_param_nml( 8)%varname = 'sfmc' -obs_param_nml( 8)%units = 'm3/m3' -obs_param_nml( 8)%path = '/discover/nobackup/vmaggion/Synth_sfmc/radar_sim/std_synth_sfmc_0.040/' -obs_param_nml( 8)%name = 'synth_sfmc_VivianaOK_' -obs_param_nml( 8)%maskpath = '' -obs_param_nml( 8)%maskname = '' -obs_param_nml( 8)%scalepath = '.' -obs_param_nml( 8)%scalename = '.' -obs_param_nml( 8)%flistpath = '' -obs_param_nml( 8)%flistname = '' -obs_param_nml( 8)%errstd = .04 -obs_param_nml( 8)%std_normal_max = 2.5 -obs_param_nml( 8)%zeromean = .true. -obs_param_nml( 8)%coarsen_pert = .false. -obs_param_nml( 8)%xcorr = 0. -obs_param_nml( 8)%ycorr = 0. -obs_param_nml( 8)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 9 = AMSR_E_sm_LPRM_A_C (A = ascending = "day", C-band) - -obs_param_nml( 9)%descr = 'ae_sm_LPRM_a_C' -obs_param_nml( 9)%orbit = 1 -obs_param_nml( 9)%pol = 0 -obs_param_nml( 9)%N_ang = 0 -obs_param_nml( 9)%freq = 6.925e9 -obs_param_nml( 9)%FOV = 20. -obs_param_nml( 9)%FOV_units = 'km' -obs_param_nml( 9)%assim = .false. -obs_param_nml( 9)%scale = .false. -obs_param_nml( 9)%getinnov = .false. -obs_param_nml( 9)%RTM_ID = 0 -obs_param_nml( 9)%bias_Npar = 0 -obs_param_nml( 9)%bias_trel = 864000 -obs_param_nml( 9)%bias_tcut = 432000 -obs_param_nml( 9)%nodata = -9999. -obs_param_nml( 9)%varname = 'sfmc' -obs_param_nml( 9)%units = 'm3/m3' -obs_param_nml( 9)%path = '/land/l_data/AMSR/data/AMSR_E_sm_LPRM/L2_EASE/bin/' -obs_param_nml( 9)%name = 'AMSRsmUVA.EASE.v03.' -obs_param_nml( 9)%maskpath = '' -obs_param_nml( 9)%maskname = '' -obs_param_nml( 9)%scalepath = '' -obs_param_nml( 9)%scalename = '' -obs_param_nml( 9)%flistpath = '' -obs_param_nml( 9)%flistname = '' -obs_param_nml( 9)%errstd = .04 -obs_param_nml( 9)%std_normal_max = 2.5 -obs_param_nml( 9)%zeromean = .true. -obs_param_nml( 9)%coarsen_pert = .false. -obs_param_nml( 9)%xcorr = 0.25 -obs_param_nml( 9)%ycorr = 0.25 -obs_param_nml( 9)%adapt = 0 - -! ------------------- -! -! 10 = AMSR_E_sm_LPRM_D_C (D = descending = "night", C-band) - -obs_param_nml(10)%descr = 'ae_sm_LPRM_d_C' -obs_param_nml(10)%orbit = 2 -obs_param_nml(10)%pol = 0 -obs_param_nml(10)%N_ang = 0 -obs_param_nml(10)%freq = 6.925e9 -obs_param_nml(10)%FOV = 20. -obs_param_nml(10)%FOV_units = 'km' -obs_param_nml(10)%assim = .false. -obs_param_nml(10)%scale = .false. -obs_param_nml(10)%getinnov = .false. -obs_param_nml(10)%RTM_ID = 0 -obs_param_nml(10)%bias_Npar = 0 -obs_param_nml(10)%bias_trel = 864000 -obs_param_nml(10)%bias_tcut = 432000 -obs_param_nml(10)%nodata = -9999. -obs_param_nml(10)%varname = 'sfmc' -obs_param_nml(10)%units = 'm3/m3' -obs_param_nml(10)%path = '/land/l_data/AMSR/data/AMSR_E_sm_LPRM/L2_EASE/bin/' -obs_param_nml(10)%name = 'AMSRsmUVA.EASE.v03.' -obs_param_nml(10)%maskpath = '' -obs_param_nml(10)%maskname = '' -obs_param_nml(10)%scalepath = '' -obs_param_nml(10)%scalename = '' -obs_param_nml(10)%flistpath = '' -obs_param_nml(10)%flistname = '' -obs_param_nml(10)%errstd = .04 -obs_param_nml(10)%std_normal_max = 2.5 -obs_param_nml(10)%zeromean = .true. -obs_param_nml(10)%coarsen_pert = .false. -obs_param_nml(10)%xcorr = 0.25 -obs_param_nml(10)%ycorr = 0.25 -obs_param_nml(10)%adapt = 0 - -! ------------------- -! -! 11 = AMSR_E_sm_LPRM_A_X (A = ascending = "day", X-band) - -obs_param_nml(11)%descr = 'ae_sm_LPRM_a_X' -obs_param_nml(11)%orbit = 1 -obs_param_nml(11)%pol = 0 -obs_param_nml(11)%N_ang = 0 -obs_param_nml(11)%freq = 10.65e9 -obs_param_nml(11)%FOV = 20. -obs_param_nml(11)%FOV_units = 'km' -obs_param_nml(11)%assim = .false. -obs_param_nml(11)%scale = .false. -obs_param_nml(11)%getinnov = .false. -obs_param_nml(11)%RTM_ID = 0 -obs_param_nml(11)%bias_Npar = 0 -obs_param_nml(11)%bias_trel = 864000 -obs_param_nml(11)%bias_tcut = 432000 -obs_param_nml(11)%nodata = -9999. -obs_param_nml(11)%varname = 'sfmc' -obs_param_nml(11)%units = 'm3/m3' -obs_param_nml(11)%path = '/land/l_data/AMSR/data/AMSR_E_sm_LPRM/L2_EASE/bin/' -obs_param_nml(11)%name = 'AMSRsmUVA.EASE.v03.' -obs_param_nml(11)%maskpath = '' -obs_param_nml(11)%maskname = '' -obs_param_nml(11)%scalepath = '' -obs_param_nml(11)%scalename = '' -obs_param_nml(11)%flistpath = '' -obs_param_nml(11)%flistname = '' -obs_param_nml(11)%errstd = .04 -obs_param_nml(11)%std_normal_max = 2.5 -obs_param_nml(11)%zeromean = .true. -obs_param_nml(11)%coarsen_pert = .false. -obs_param_nml(11)%xcorr = 0.25 -obs_param_nml(11)%ycorr = 0.25 -obs_param_nml(11)%adapt = 0 - -! ------------------- -! -! 12 = AMSR_E_sm_LPRM_D_X (D = descending = "night", X-band) - -obs_param_nml(12)%descr = 'ae_sm_LPRM_d_X' -obs_param_nml(12)%orbit = 2 -obs_param_nml(12)%pol = 0 -obs_param_nml(12)%N_ang = 0 -obs_param_nml(12)%freq = 10.65e9 -obs_param_nml(12)%FOV = 20. -obs_param_nml(12)%FOV_units = 'km' -obs_param_nml(12)%assim = .false. -obs_param_nml(12)%scale = .false. -obs_param_nml(12)%getinnov = .false. -obs_param_nml(12)%RTM_ID = 0 -obs_param_nml(12)%bias_Npar = 0 -obs_param_nml(12)%bias_trel = 864000 -obs_param_nml(12)%bias_tcut = 432000 -obs_param_nml(12)%nodata = -9999. -obs_param_nml(12)%varname = 'sfmc' -obs_param_nml(12)%units = 'm3/m3' -obs_param_nml(12)%path = '/land/l_data/AMSR/data/AMSR_E_sm_LPRM/L2_EASE/bin/' -obs_param_nml(12)%name = 'AMSRsmUVA.EASE.v03.' -obs_param_nml(12)%maskpath = '' -obs_param_nml(12)%maskname = '' -obs_param_nml(12)%scalepath = '' -obs_param_nml(12)%scalename = '' -obs_param_nml(12)%flistpath = '' -obs_param_nml(12)%flistname = '' -obs_param_nml(12)%errstd = .04 -obs_param_nml(12)%std_normal_max = 2.5 -obs_param_nml(12)%zeromean = .true. -obs_param_nml(12)%coarsen_pert = .false. -obs_param_nml(12)%xcorr = 0.25 -obs_param_nml(12)%ycorr = 0.25 -obs_param_nml(12)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 13 = ASCAT_SM_A (ASCAT soil moisture ascending) -! -! ASCAT: VV-pol, incidence angle 25-65 deg -! for now keep N_ang=0, pol=0 -! - reichle, 30 Jun 2015 - -obs_param_nml(13)%descr = 'ASCAT_SM_A' -obs_param_nml(13)%orbit = 1 -obs_param_nml(13)%pol = 0 -obs_param_nml(13)%N_ang = 0 -obs_param_nml(13)%freq = 5.255e9 -obs_param_nml(13)%FOV = 20. -obs_param_nml(13)%FOV_units = 'km' -obs_param_nml(13)%assim = .false. -obs_param_nml(13)%scale = .false. -obs_param_nml(13)%getinnov = .false. -obs_param_nml(13)%RTM_ID = 0 -obs_param_nml(13)%bias_Npar = 0 -obs_param_nml(13)%bias_trel = 864000 -obs_param_nml(13)%bias_tcut = 432000 -obs_param_nml(13)%nodata = -9999. -obs_param_nml(13)%varname = 'sfmc' -obs_param_nml(13)%units = 'm3/m3' -obs_param_nml(13)%path = '/discover/nobackup/rreichle/l_data/ASCAT/TUW_W5.4/EASE/CONUS/bin/' -obs_param_nml(13)%name = 'SDS_' -obs_param_nml(13)%maskpath = '' -obs_param_nml(13)%maskname = '' -obs_param_nml(13)%scalepath = '' -obs_param_nml(13)%scalename = '' -obs_param_nml(13)%flistpath = '' -obs_param_nml(13)%flistname = '' -obs_param_nml(13)%errstd = .04 -obs_param_nml(13)%std_normal_max = 2.5 -obs_param_nml(13)%zeromean = .true. -obs_param_nml(13)%coarsen_pert = .false. -obs_param_nml(13)%xcorr = 0.25 -obs_param_nml(13)%ycorr = 0.25 -obs_param_nml(13)%adapt = 0 - -! ------------------- -! -! 14 = ASCAT_SM_D (ASCAT soil moisture descending) -! -! TO DO: What is pol of backscatter used in retrieval? -! TO DO: How deal w/ inc angle? -! http://oiswww.eumetsat.org/WEBOPS/eps-pg/ASCAT/ASCAT-PG-4ProdOverview.htm - -obs_param_nml(14)%descr = 'ASCAT_SM_D' -obs_param_nml(14)%orbit = 2 -obs_param_nml(14)%pol = 0 -obs_param_nml(14)%N_ang = 0 -obs_param_nml(14)%freq = 5.255e9 -obs_param_nml(14)%FOV = 20. -obs_param_nml(14)%FOV_units = 'km' -obs_param_nml(14)%assim = .false. -obs_param_nml(14)%scale = .false. -obs_param_nml(14)%getinnov = .false. -obs_param_nml(14)%RTM_ID = 0 -obs_param_nml(14)%bias_Npar = 0 -obs_param_nml(14)%bias_trel = 864000 -obs_param_nml(14)%bias_tcut = 432000 -obs_param_nml(14)%nodata = -9999. -obs_param_nml(14)%varname = 'sfmc' -obs_param_nml(14)%units = 'm3/m3' -obs_param_nml(14)%path = '/discover/nobackup/rreichle/l_data/ASCAT/TUW_W5.4/EASE/CONUS/bin/' -obs_param_nml(14)%name = 'SDS_' -obs_param_nml(14)%maskpath = '' -obs_param_nml(14)%maskname = '' -obs_param_nml(14)%scalepath = '' -obs_param_nml(14)%scalename = '' -obs_param_nml(14)%flistpath = '' -obs_param_nml(14)%flistname = '' -obs_param_nml(14)%errstd = .04 -obs_param_nml(14)%std_normal_max = 2.5 -obs_param_nml(14)%zeromean = .true. -obs_param_nml(14)%coarsen_pert = .false. -obs_param_nml(14)%xcorr = 0.25 -obs_param_nml(14)%ycorr = 0.25 -obs_param_nml(14)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 15 = SMOS_SM_A (SMOS soil moisture ascending) - -obs_param_nml(15)%descr = 'SMOS_SM_A' -obs_param_nml(15)%orbit = 1 -obs_param_nml(15)%pol = 0 -obs_param_nml(15)%N_ang = 0 -obs_param_nml(15)%freq = 1.41e9 -obs_param_nml(15)%FOV = 20. -obs_param_nml(15)%FOV_units = 'km' -obs_param_nml(15)%assim = .false. -obs_param_nml(15)%scale = .false. -obs_param_nml(15)%getinnov = .false. -obs_param_nml(15)%RTM_ID = 0 -obs_param_nml(15)%bias_Npar = 0 -obs_param_nml(15)%bias_trel = 864000 -obs_param_nml(15)%bias_tcut = 432000 -obs_param_nml(15)%nodata = -9999. -obs_param_nml(15)%varname = 'sfmc' -obs_param_nml(15)%units = 'm3/m3' -obs_param_nml(15)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SMUDP2/' -obs_param_nml(15)%name = '' -obs_param_nml(15)%maskpath = '' -obs_param_nml(15)%maskname = '' -obs_param_nml(15)%scalepath = '' -obs_param_nml(15)%scalename = '' -obs_param_nml(15)%flistpath = '' -obs_param_nml(15)%flistname = '' -obs_param_nml(15)%errstd = .04 -obs_param_nml(15)%std_normal_max = 2.5 -obs_param_nml(15)%zeromean = .true. -obs_param_nml(15)%coarsen_pert = .false. -obs_param_nml(15)%xcorr = 0.25 -obs_param_nml(15)%ycorr = 0.25 -obs_param_nml(15)%adapt = 0 - -! ------------------- -! -! 16 = SMOS_SM_D (SMOS soil moisture descending) - -obs_param_nml(16)%descr = 'SMOS_SM_D' -obs_param_nml(16)%orbit = 2 -obs_param_nml(16)%pol = 0 -obs_param_nml(16)%N_ang = 0 -obs_param_nml(16)%freq = 1.41e9 -obs_param_nml(16)%FOV = 20. -obs_param_nml(16)%FOV_units = 'km' -obs_param_nml(16)%assim = .false. -obs_param_nml(16)%scale = .false. -obs_param_nml(16)%getinnov = .false. -obs_param_nml(16)%RTM_ID = 0 -obs_param_nml(16)%bias_Npar = 0 -obs_param_nml(16)%bias_trel = 864000 -obs_param_nml(16)%bias_tcut = 432000 -obs_param_nml(16)%nodata = -9999. -obs_param_nml(16)%varname = 'sfmc' -obs_param_nml(16)%units = 'm3/m3' -obs_param_nml(16)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SMUDP2/' -obs_param_nml(16)%name = '' -obs_param_nml(16)%maskpath = '' -obs_param_nml(16)%maskname = '' -obs_param_nml(16)%scalepath = '' -obs_param_nml(16)%scalename = '' -obs_param_nml(16)%flistpath = '' -obs_param_nml(16)%flistname = '' -obs_param_nml(16)%errstd = .04 -obs_param_nml(16)%std_normal_max = 2.5 -obs_param_nml(16)%zeromean = .true. -obs_param_nml(16)%coarsen_pert = .false. -obs_param_nml(16)%xcorr = 0.25 -obs_param_nml(16)%ycorr = 0.25 -obs_param_nml(16)%adapt = 0 - -! -------------------------------------------------------------------- -! -! SMOS multi-angular brightness temperature -! -! "A" = ascending (6am *SMOS* overpass) -! "D" = descending (6pm *SMOS* overpass) -! -! "Tbh" = h-pol Tb -! "Tbv" = v-pol Tb -! -! -! "Regular" vs. "fitted" SMOS brightness temperatures: -! -! "Regular" Tb data ('SMOS_reg_Tb*'): -! Derived from SMOS SCLF1C data by Gabrielle De Lannoy. Observations within -! one-degree angular bins for a given time and location are averaged. -! Various quality controls steps are applied. -! A typical assimilation setup uses 7 angles. -! For details see De Lannoy et al (2013) doi:10.1175/JHM-D-12-092.1. -! -! "Fitted" Tb data ('SMOS_fit_Tb*'): -! Derived from "regular" SMOS Tb data by Gabrielle De Lannoy. Observations -! for a given time and location derived by fitting across available incidence -! angles. The resulting fitted observation at 40 deg incidence angle corresponds -! roughly to what the SMAP radiometer observes (a.k.a. "SMOS40"). -! A typical assimilation setup uses only one angle. -! -! -! Frequency: -! -! Date: Wed, 8 Jun 2011 02:34:40 -0500 -! From: -! To: -! -! In the ATBD it is written that the central frequency is 1.413 GHz. I -! have asked around but it seems more complicated than expected because -! the 64 antennas are working around 1.410 GHz (+-0.008 GHz) and there is -! no exact value for the frequency (mostly because the frequency of each -! antenna depends on the temperature...). Here we work with 1.413 GHz. -! - -! ------------------- -! -! 17 = SMOS_reg_Tbh_A - -obs_param_nml(17)%descr = 'SMOS_reg_Tbh_A' -obs_param_nml(17)%orbit = 1 -obs_param_nml(17)%pol = 1 -obs_param_nml(17)%N_ang = 7 -obs_param_nml(17)%ang(1) = 30. -obs_param_nml(17)%ang(2) = 35. -obs_param_nml(17)%ang(3) = 40. -obs_param_nml(17)%ang(4) = 45. -obs_param_nml(17)%ang(5) = 50. -obs_param_nml(17)%ang(6) = 55. -obs_param_nml(17)%ang(7) = 60. -obs_param_nml(17)%freq = 1.41e9 -obs_param_nml(17)%FOV = 20. -obs_param_nml(17)%FOV_units = 'km' -obs_param_nml(17)%assim = .false. -obs_param_nml(17)%scale = .false. -obs_param_nml(17)%getinnov = .false. -obs_param_nml(17)%RTM_ID = 2 -obs_param_nml(17)%bias_Npar = 0 -obs_param_nml(17)%bias_trel = 864000 -obs_param_nml(17)%bias_tcut = 432000 -obs_param_nml(17)%nodata = -9999. -obs_param_nml(17)%varname = 'Tb' -obs_param_nml(17)%units = 'K' -obs_param_nml(17)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_reg_nosky_noatm_v620_ESA_v102/' -obs_param_nml(17)%name = '' -obs_param_nml(17)%maskpath = '' -obs_param_nml(17)%maskname = '' -obs_param_nml(17)%scalepath = '' -obs_param_nml(17)%scalename = '' -obs_param_nml(17)%flistpath = '' -obs_param_nml(17)%flistname = '' -obs_param_nml(17)%errstd = 4. -obs_param_nml(17)%std_normal_max = 2.5 -obs_param_nml(17)%zeromean = .true. -obs_param_nml(17)%coarsen_pert = .false. -obs_param_nml(17)%xcorr = 0.25 -obs_param_nml(17)%ycorr = 0.25 -obs_param_nml(17)%adapt = 0 - -! ------------------- -! -! 18 = SMOS_reg_Tbh_D - -obs_param_nml(18)%descr = 'SMOS_reg_Tbh_D' -obs_param_nml(18)%orbit = 2 -obs_param_nml(18)%pol = 1 -obs_param_nml(18)%N_ang = 7 -obs_param_nml(18)%ang(1) = 30. -obs_param_nml(18)%ang(2) = 35. -obs_param_nml(18)%ang(3) = 40. -obs_param_nml(18)%ang(4) = 45. -obs_param_nml(18)%ang(5) = 50. -obs_param_nml(18)%ang(6) = 55. -obs_param_nml(18)%ang(7) = 60. -obs_param_nml(18)%freq = 1.41e9 -obs_param_nml(18)%FOV = 20. -obs_param_nml(18)%FOV_units = 'km' -obs_param_nml(18)%assim = .false. -obs_param_nml(18)%scale = .false. -obs_param_nml(18)%getinnov = .false. -obs_param_nml(18)%RTM_ID = 2 -obs_param_nml(18)%bias_Npar = 0 -obs_param_nml(18)%bias_trel = 864000 -obs_param_nml(18)%bias_tcut = 432000 -obs_param_nml(18)%nodata = -9999. -obs_param_nml(18)%varname = 'Tb' -obs_param_nml(18)%units = 'K' -obs_param_nml(18)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_reg_nosky_noatm_v620_ESA_v102/' -obs_param_nml(18)%name = '' -obs_param_nml(18)%maskpath = '' -obs_param_nml(18)%maskname = '' -obs_param_nml(18)%scalepath = '' -obs_param_nml(18)%scalename = '' -obs_param_nml(18)%flistpath = '' -obs_param_nml(18)%flistname = '' -obs_param_nml(18)%errstd = 4. -obs_param_nml(18)%std_normal_max = 2.5 -obs_param_nml(18)%zeromean = .true. -obs_param_nml(18)%coarsen_pert = .false. -obs_param_nml(18)%xcorr = 0.25 -obs_param_nml(18)%ycorr = 0.25 -obs_param_nml(18)%adapt = 0 - -! ------------------- -! -! 19 = SMOS_reg_Tbv_A - -obs_param_nml(19)%descr = 'SMOS_reg_Tbv_A' -obs_param_nml(19)%orbit = 1 -obs_param_nml(19)%pol = 2 -obs_param_nml(19)%N_ang = 7 -obs_param_nml(19)%ang(1) = 30. -obs_param_nml(19)%ang(2) = 35. -obs_param_nml(19)%ang(3) = 40. -obs_param_nml(19)%ang(4) = 45. -obs_param_nml(19)%ang(5) = 50. -obs_param_nml(19)%ang(6) = 55. -obs_param_nml(19)%ang(7) = 60. -obs_param_nml(19)%freq = 1.41e9 -obs_param_nml(19)%FOV = 20. -obs_param_nml(19)%FOV_units = 'km' -obs_param_nml(19)%assim = .false. -obs_param_nml(19)%scale = .false. -obs_param_nml(19)%getinnov = .false. -obs_param_nml(19)%RTM_ID = 2 -obs_param_nml(19)%bias_Npar = 0 -obs_param_nml(19)%bias_trel = 864000 -obs_param_nml(19)%bias_tcut = 432000 -obs_param_nml(19)%nodata = -9999. -obs_param_nml(19)%varname = 'Tb' -obs_param_nml(19)%units = 'K' -obs_param_nml(19)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_reg_nosky_noatm_v620_ESA_v102/' -obs_param_nml(19)%name = '' -obs_param_nml(19)%maskpath = '' -obs_param_nml(19)%maskname = '' -obs_param_nml(19)%scalepath = '' -obs_param_nml(19)%scalename = '' -obs_param_nml(19)%flistpath = '' -obs_param_nml(19)%flistname = '' -obs_param_nml(19)%errstd = 4. -obs_param_nml(19)%std_normal_max = 2.5 -obs_param_nml(19)%zeromean = .true. -obs_param_nml(19)%coarsen_pert = .false. -obs_param_nml(19)%xcorr = 0.25 -obs_param_nml(19)%ycorr = 0.25 -obs_param_nml(19)%adapt = 0 - -! ------------------- -! -! 20 = SMOS_reg_Tbv_D - -obs_param_nml(20)%descr = 'SMOS_reg_Tbv_D' -obs_param_nml(20)%orbit = 2 -obs_param_nml(20)%pol = 2 -obs_param_nml(20)%N_ang = 7 -obs_param_nml(20)%ang(1) = 30. -obs_param_nml(20)%ang(2) = 35. -obs_param_nml(20)%ang(3) = 40. -obs_param_nml(20)%ang(4) = 45. -obs_param_nml(20)%ang(5) = 50. -obs_param_nml(20)%ang(6) = 55. -obs_param_nml(20)%ang(7) = 60. -obs_param_nml(20)%freq = 1.41e9 -obs_param_nml(20)%FOV = 20. -obs_param_nml(20)%FOV_units = 'km' -obs_param_nml(20)%assim = .false. -obs_param_nml(20)%scale = .false. -obs_param_nml(20)%getinnov = .false. -obs_param_nml(20)%RTM_ID = 2 -obs_param_nml(20)%bias_Npar = 0 -obs_param_nml(20)%bias_trel = 864000 -obs_param_nml(20)%bias_tcut = 432000 -obs_param_nml(20)%nodata = -9999. -obs_param_nml(20)%varname = 'Tb' -obs_param_nml(20)%units = 'K' -obs_param_nml(20)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_reg_nosky_noatm_v620_ESA_v102/' -obs_param_nml(20)%name = '' -obs_param_nml(20)%maskpath = '' -obs_param_nml(20)%maskname = '' -obs_param_nml(20)%scalepath = '' -obs_param_nml(20)%scalename = '' -obs_param_nml(20)%flistpath = '' -obs_param_nml(20)%flistname = '' -obs_param_nml(20)%errstd = 4. -obs_param_nml(20)%std_normal_max = 2.5 -obs_param_nml(20)%zeromean = .true. -obs_param_nml(20)%coarsen_pert = .false. -obs_param_nml(20)%xcorr = 0.25 -obs_param_nml(20)%ycorr = 0.25 -obs_param_nml(20)%adapt = 0 - -! -------------------------------------------------- -! -! 21 = SMOS_fit_Tbh_A - -obs_param_nml(21)%descr = 'SMOS_fit_Tbh_A' -obs_param_nml(21)%orbit = 1 -obs_param_nml(21)%pol = 1 -obs_param_nml(21)%N_ang = 1 -obs_param_nml(21)%ang(1) = 40. -obs_param_nml(21)%freq = 1.41e9 -obs_param_nml(21)%FOV = 20. -obs_param_nml(21)%FOV_units = 'km' -obs_param_nml(21)%assim = .false. -obs_param_nml(21)%scale = .false. -obs_param_nml(21)%getinnov = .false. -obs_param_nml(21)%RTM_ID = 2 -obs_param_nml(21)%bias_Npar = 0 -obs_param_nml(21)%bias_trel = 864000 -obs_param_nml(21)%bias_tcut = 432000 -obs_param_nml(21)%nodata = -9999. -obs_param_nml(21)%varname = 'Tb' -obs_param_nml(21)%units = 'K' -obs_param_nml(21)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_fit_nosky_noatm_v620_ESA_v102/SMOS_fit_poly2/' -obs_param_nml(21)%name = '' -obs_param_nml(21)%maskpath = '' -obs_param_nml(21)%maskname = '' -obs_param_nml(21)%scalepath = '' -obs_param_nml(21)%scalename = '' -obs_param_nml(21)%flistpath = '' -obs_param_nml(21)%flistname = '' -obs_param_nml(21)%errstd = 1.5 -obs_param_nml(21)%std_normal_max = 2.5 -obs_param_nml(21)%zeromean = .true. -obs_param_nml(21)%coarsen_pert = .false. -obs_param_nml(21)%xcorr = 0.25 -obs_param_nml(21)%ycorr = 0.25 -obs_param_nml(21)%adapt = 0 - -! ------------------- -! -! 22 = SMOS_fit_Tbh_D - -obs_param_nml(22)%descr = 'SMOS_fit_Tbh_D' -obs_param_nml(22)%orbit = 2 -obs_param_nml(22)%pol = 1 -obs_param_nml(22)%N_ang = 1 -obs_param_nml(22)%ang(1) = 40. -obs_param_nml(22)%freq = 1.41e9 -obs_param_nml(22)%FOV = 20. -obs_param_nml(22)%FOV_units = 'km' -obs_param_nml(22)%assim = .false. -obs_param_nml(22)%scale = .false. -obs_param_nml(22)%getinnov = .false. -obs_param_nml(22)%RTM_ID = 2 -obs_param_nml(22)%bias_Npar = 0 -obs_param_nml(22)%bias_trel = 864000 -obs_param_nml(22)%bias_tcut = 432000 -obs_param_nml(22)%nodata = -9999. -obs_param_nml(22)%varname = 'Tb' -obs_param_nml(22)%units = 'K' -obs_param_nml(22)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_fit_nosky_noatm_v620_ESA_v102/SMOS_fit_poly2/' -obs_param_nml(22)%name = '' -obs_param_nml(22)%maskpath = '' -obs_param_nml(22)%maskname = '' -obs_param_nml(22)%scalepath = '' -obs_param_nml(22)%scalename = '' -obs_param_nml(22)%flistpath = '' -obs_param_nml(22)%flistname = '' -obs_param_nml(22)%errstd = 1.5 -obs_param_nml(22)%std_normal_max = 2.5 -obs_param_nml(22)%zeromean = .true. -obs_param_nml(22)%coarsen_pert = .false. -obs_param_nml(22)%xcorr = 0.25 -obs_param_nml(22)%ycorr = 0.25 -obs_param_nml(22)%adapt = 0 - -! ------------------- -! -! 23 = SMOS_fit_Tbv_A - -obs_param_nml(23)%descr = 'SMOS_fit_Tbv_A' -obs_param_nml(23)%orbit = 1 -obs_param_nml(23)%pol = 2 -obs_param_nml(23)%N_ang = 1 -obs_param_nml(23)%ang(1) = 40. -obs_param_nml(23)%freq = 1.41e9 -obs_param_nml(23)%FOV = 20. -obs_param_nml(23)%FOV_units = 'km' -obs_param_nml(23)%assim = .false. -obs_param_nml(23)%scale = .false. -obs_param_nml(23)%getinnov = .false. -obs_param_nml(23)%RTM_ID = 2 -obs_param_nml(23)%bias_Npar = 0 -obs_param_nml(23)%bias_trel = 864000 -obs_param_nml(23)%bias_tcut = 432000 -obs_param_nml(23)%nodata = -9999. -obs_param_nml(23)%varname = 'Tb' -obs_param_nml(23)%units = 'K' -obs_param_nml(23)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_fit_nosky_noatm_v620_ESA_v102/SMOS_fit_poly2/' -obs_param_nml(23)%name = '' -obs_param_nml(23)%maskpath = '' -obs_param_nml(23)%maskname = '' -obs_param_nml(23)%scalepath = '' -obs_param_nml(23)%scalename = '' -obs_param_nml(23)%flistpath = '' -obs_param_nml(23)%flistname = '' -obs_param_nml(23)%errstd = 1.5 -obs_param_nml(23)%std_normal_max = 2.5 -obs_param_nml(23)%zeromean = .true. -obs_param_nml(23)%coarsen_pert = .false. -obs_param_nml(23)%xcorr = 0.25 -obs_param_nml(23)%ycorr = 0.25 -obs_param_nml(23)%adapt = 0 - -! ------------------- -! -! 24 = SMOS_fit_Tbv_D - -obs_param_nml(24)%descr = 'SMOS_fit_Tbv_D' -obs_param_nml(24)%orbit = 2 -obs_param_nml(24)%pol = 2 -obs_param_nml(24)%N_ang = 1 -obs_param_nml(24)%ang(1) = 40. -obs_param_nml(24)%freq = 1.41e9 -obs_param_nml(24)%FOV = 20. -obs_param_nml(24)%FOV_units = 'km' -obs_param_nml(24)%assim = .false. -obs_param_nml(24)%scale = .false. -obs_param_nml(24)%getinnov = .false. -obs_param_nml(24)%RTM_ID = 2 -obs_param_nml(24)%bias_Npar = 0 -obs_param_nml(24)%bias_trel = 864000 -obs_param_nml(24)%bias_tcut = 432000 -obs_param_nml(24)%nodata = -9999. -obs_param_nml(24)%varname = 'Tb' -obs_param_nml(24)%units = 'K' -obs_param_nml(24)%path = '/discover/nobackup/projects/gmao/ssd/land/l_data/SMOS/EASEv2/ESA_REPR/SMOS_M36_SCLF1C_fit_nosky_noatm_v620_ESA_v102/SMOS_fit_poly2/' -obs_param_nml(24)%name = '' -obs_param_nml(24)%maskpath = '' -obs_param_nml(24)%maskname = '' -obs_param_nml(24)%scalepath = '' -obs_param_nml(24)%scalename = '' -obs_param_nml(24)%flistpath = '' -obs_param_nml(24)%flistname = '' -obs_param_nml(24)%errstd = 1.5 -obs_param_nml(24)%std_normal_max = 2.5 -obs_param_nml(24)%zeromean = .true. -obs_param_nml(24)%coarsen_pert = .false. -obs_param_nml(24)%xcorr = 0.25 -obs_param_nml(24)%ycorr = 0.25 -obs_param_nml(24)%adapt = 0 - - -! -------------------------------------------------------------------- -! -! 25 = [empty] - -obs_param_nml(25)%descr = 'NULL' -obs_param_nml(25)%orbit = -9999 -obs_param_nml(25)%pol = -9999 -obs_param_nml(25)%N_ang = -9999 -obs_param_nml(25)%freq = -9999. -obs_param_nml(25)%FOV = -9999. -obs_param_nml(25)%FOV_units = 'NULL' -obs_param_nml(25)%assim = .false. -obs_param_nml(25)%scale = .false. -obs_param_nml(25)%getinnov = .false. -obs_param_nml(25)%RTM_ID = -9999 -obs_param_nml(25)%bias_Npar = -9999 -obs_param_nml(25)%bias_trel = -9999 -obs_param_nml(25)%bias_tcut = -9999 -obs_param_nml(25)%nodata = -9999. -obs_param_nml(25)%varname = 'NULL' -obs_param_nml(25)%units = 'NULL' -obs_param_nml(25)%path = 'NULL' -obs_param_nml(25)%name = 'NULL' -obs_param_nml(25)%maskpath = 'NULL' -obs_param_nml(25)%maskname = 'NULL' -obs_param_nml(25)%scalepath = 'NULL' -obs_param_nml(25)%scalename = 'NULL' -obs_param_nml(25)%flistpath = 'NULL' -obs_param_nml(25)%flistname = 'NULL' -obs_param_nml(25)%errstd = -9999. -obs_param_nml(25)%std_normal_max = -9999. -obs_param_nml(25)%zeromean = .false. -obs_param_nml(25)%coarsen_pert = .false. -obs_param_nml(25)%xcorr = -9999. -obs_param_nml(25)%ycorr = -9999. -obs_param_nml(25)%adapt = -9999 - -! -------------------------------------------------------------------- -! -! 26 = LaRC Tskin GEOS-WEST -! - -obs_param_nml(26)%descr = 'LaRC_tskin-GOESW' -obs_param_nml(26)%orbit = 4 -obs_param_nml(26)%pol = 0 -obs_param_nml(26)%N_ang = 0 -obs_param_nml(26)%freq = 0. -obs_param_nml(26)%FOV = 0.17 -obs_param_nml(26)%FOV_units = 'deg' -obs_param_nml(26)%assim = .false. -obs_param_nml(26)%scale = .false. -obs_param_nml(26)%getinnov = .false. -obs_param_nml(26)%RTM_ID = 0 -obs_param_nml(26)%bias_Npar = 0 -obs_param_nml(26)%bias_trel = 864000 -obs_param_nml(26)%bias_tcut = 432000 -obs_param_nml(26)%nodata = -9999. -obs_param_nml(26)%varname = 'tsurf' -obs_param_nml(26)%units = 'K' -obs_param_nml(26)%path = '/discover/nobackup/csdraper/LaRC_float/GOES-WEST/' -obs_param_nml(26)%name = 'larc-v3.inst3_g15_Nch.' -obs_param_nml(26)%maskpath = '' -obs_param_nml(26)%maskname = '' -obs_param_nml(26)%scalepath = '' -obs_param_nml(26)%scalename = '' -obs_param_nml(26)%flistpath = '' -obs_param_nml(26)%flistname = '' -obs_param_nml(26)%errstd = 2. -obs_param_nml(26)%std_normal_max = 2.5 -obs_param_nml(26)%zeromean = .true. -obs_param_nml(26)%coarsen_pert = .false. -obs_param_nml(26)%xcorr = 0.17 -obs_param_nml(26)%ycorr = 0.17 -obs_param_nml(26)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 27 = LaRC Tskin GEOS-EAST -! - -obs_param_nml(27)%descr = 'LaRC_tskin-GOESE' -obs_param_nml(27)%orbit = 4 -obs_param_nml(27)%pol = 0 -obs_param_nml(27)%N_ang = 0 -obs_param_nml(27)%freq = 0. -obs_param_nml(27)%FOV = 0.17 -obs_param_nml(27)%FOV_units = 'deg' -obs_param_nml(27)%assim = .false. -obs_param_nml(27)%scale = .false. -obs_param_nml(27)%getinnov = .false. -obs_param_nml(27)%RTM_ID = 0 -obs_param_nml(27)%bias_Npar = 0 -obs_param_nml(27)%bias_trel = 864000 -obs_param_nml(27)%bias_tcut = 432000 -obs_param_nml(27)%nodata = -9999. -obs_param_nml(27)%varname = 'tsurf' -obs_param_nml(27)%units = 'K' -obs_param_nml(27)%path = '/discover/nobackup/csdraper/LaRC_float/v4/GOES-EAST/' -obs_param_nml(27)%name = 'larc-v3.inst3_g13_Nch.' -obs_param_nml(27)%maskpath = '' -obs_param_nml(27)%maskname = '' -obs_param_nml(27)%scalepath = '' -obs_param_nml(27)%scalename = '' -obs_param_nml(27)%flistpath = '' -obs_param_nml(27)%flistname = '' -obs_param_nml(27)%errstd = 2. -obs_param_nml(27)%std_normal_max = 2.5 -obs_param_nml(27)%zeromean = .true. -obs_param_nml(27)%coarsen_pert = .false. -obs_param_nml(27)%xcorr = 0.17 -obs_param_nml(27)%ycorr = 0.17 -obs_param_nml(27)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 28 = LaRC Tskin GEOS-MET09 -! - -obs_param_nml(28)%descr = 'LaRC_tskin-MET09' -obs_param_nml(28)%orbit = 4 -obs_param_nml(28)%pol = 0 -obs_param_nml(28)%N_ang = 0 -obs_param_nml(28)%freq = 0. -obs_param_nml(28)%FOV = 0.17 -obs_param_nml(28)%FOV_units = 'deg' -obs_param_nml(28)%assim = .false. -obs_param_nml(28)%scale = .false. -obs_param_nml(28)%getinnov = .false. -obs_param_nml(28)%RTM_ID = 0 -obs_param_nml(28)%bias_Npar = 0 -obs_param_nml(28)%bias_trel = 864000 -obs_param_nml(28)%bias_tcut = 432000 -obs_param_nml(28)%nodata = -9999. -obs_param_nml(28)%varname = 'tsurf' -obs_param_nml(28)%units = 'K' -obs_param_nml(28)%path = '/discover/nobackup/csdraper/LaRC_float/MET09/' -obs_param_nml(28)%name = 'larc-v3.inst3_mt9_Nch.' -obs_param_nml(28)%maskpath = '' -obs_param_nml(28)%maskname = '' -obs_param_nml(28)%scalepath = '' -obs_param_nml(28)%scalename = '' -obs_param_nml(28)%flistpath = '' -obs_param_nml(28)%flistname = '' -obs_param_nml(28)%errstd = 2. -obs_param_nml(28)%std_normal_max = 2.5 -obs_param_nml(28)%zeromean = .true. -obs_param_nml(28)%coarsen_pert = .false. -obs_param_nml(28)%xcorr = 0.17 -obs_param_nml(28)%ycorr = 0.17 -obs_param_nml(28)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 25 = LaRC Tskin GEOS-FY2E -! - -obs_param_nml(29)%descr = 'LaRC_tskin-FY2E-' -obs_param_nml(29)%orbit = 4 -obs_param_nml(29)%pol = 0 -obs_param_nml(29)%N_ang = 0 -obs_param_nml(29)%freq = 0. -obs_param_nml(29)%FOV = 0.17 -obs_param_nml(29)%FOV_units = 'deg' -obs_param_nml(29)%assim = .false. -obs_param_nml(29)%scale = .false. -obs_param_nml(29)%getinnov = .false. -obs_param_nml(29)%RTM_ID = 0 -obs_param_nml(29)%bias_Npar = 0 -obs_param_nml(29)%bias_trel = 864000 -obs_param_nml(29)%bias_tcut = 432000 -obs_param_nml(29)%nodata = -9999. -obs_param_nml(29)%varname = 'tsurf' -obs_param_nml(29)%units = 'K' -obs_param_nml(29)%path = '/discover/nobackup/csdraper/LaRC_float/FY2E/' -obs_param_nml(29)%name = 'larc-v3.inst3_fye_Nch.' -obs_param_nml(29)%maskpath = '' -obs_param_nml(29)%maskname = '' -obs_param_nml(29)%scalepath = '' -obs_param_nml(29)%scalename = '' -obs_param_nml(29)%flistpath = '' -obs_param_nml(29)%flistname = '' -obs_param_nml(29)%errstd = 2. -obs_param_nml(29)%std_normal_max = 2.5 -obs_param_nml(29)%zeromean = .true. -obs_param_nml(29)%coarsen_pert = .false. -obs_param_nml(29)%xcorr = 0.17 -obs_param_nml(29)%ycorr = 0.17 -obs_param_nml(29)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 30 = LaRC Tskin GEOS-MTSAT-2 -! - -obs_param_nml(30)%descr = 'LaRC_tskin-MTST2' -obs_param_nml(30)%orbit = 4 -obs_param_nml(30)%pol = 0 -obs_param_nml(30)%N_ang = 0 -obs_param_nml(30)%freq = 0. -obs_param_nml(30)%FOV = 0.17 -obs_param_nml(30)%FOV_units = 'deg' -obs_param_nml(30)%assim = .false. -obs_param_nml(30)%scale = .false. -obs_param_nml(30)%getinnov = .false. -obs_param_nml(30)%RTM_ID = 0 -obs_param_nml(30)%bias_Npar = 0 -obs_param_nml(30)%bias_trel = 864000 -obs_param_nml(30)%bias_tcut = 432000 -obs_param_nml(30)%nodata = -9999. -obs_param_nml(30)%varname = 'tsurf' -obs_param_nml(30)%units = 'K' -obs_param_nml(30)%path = '/discover/nobackup/csdraper/LaRC_float/MTSAT-2/' -obs_param_nml(30)%name = 'larc-v3.inst3_mt2_Nch.' -obs_param_nml(30)%maskpath = '' -obs_param_nml(30)%maskname = '' -obs_param_nml(30)%scalepath = '' -obs_param_nml(30)%scalename = '' -obs_param_nml(30)%flistpath = '' -obs_param_nml(30)%flistname = '' -obs_param_nml(30)%errstd = 2. -obs_param_nml(30)%std_normal_max = 2.5 -obs_param_nml(30)%zeromean = .true. -obs_param_nml(30)%coarsen_pert = .false. -obs_param_nml(30)%xcorr = 0.17 -obs_param_nml(30)%ycorr = 0.17 -obs_param_nml(30)%adapt = 0 - -! -------------------------------------------------------------------- -! -! SMAP L1C_TB brightness temperature (36 km EASE grid) -! -! "A" = ascending (6pm *SMAP* overpass) -! "D" = descending (6am *SMAP* overpass) -! -! "Tbh" = h-pol Tb -! "Tbv" = v-pol Tb -! -! ------------------- -! -! 31 = SMAP_L1C_Tbh_A - -obs_param_nml(31)%descr = 'SMAP_L1C_Tbh_A' -obs_param_nml(31)%orbit = 1 -obs_param_nml(31)%pol = 1 -obs_param_nml(31)%N_ang = 1 -obs_param_nml(31)%ang(1) = 40. -obs_param_nml(31)%freq = 1.41e9 -obs_param_nml(31)%FOV = 20. -obs_param_nml(31)%FOV_units = 'km' -obs_param_nml(31)%assim = .false. -obs_param_nml(31)%scale = .false. -obs_param_nml(31)%getinnov = .false. -obs_param_nml(31)%RTM_ID = 2 -obs_param_nml(31)%bias_Npar = 0 -obs_param_nml(31)%bias_trel = 864000 -obs_param_nml(31)%bias_tcut = 432000 -obs_param_nml(31)%nodata = -9999. -obs_param_nml(31)%varname = 'Tb' -obs_param_nml(31)%units = 'K' -obs_param_nml(31)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB/' -obs_param_nml(31)%name = '' -obs_param_nml(31)%maskpath = '' -obs_param_nml(31)%maskname = '' -obs_param_nml(31)%scalepath = '' -obs_param_nml(31)%scalename = '' -obs_param_nml(31)%flistpath = '' -obs_param_nml(31)%flistname = '' -obs_param_nml(31)%errstd = 4. -obs_param_nml(31)%std_normal_max = 2.5 -obs_param_nml(31)%zeromean = .true. -obs_param_nml(31)%coarsen_pert = .false. -obs_param_nml(31)%xcorr = 0.25 -obs_param_nml(31)%ycorr = 0.25 -obs_param_nml(31)%adapt = 0 - -! ------------------- -! -! 32 = SMAP_L1C_Tbh_D - -obs_param_nml(32)%descr = 'SMAP_L1C_Tbh_D' -obs_param_nml(32)%orbit = 2 -obs_param_nml(32)%pol = 1 -obs_param_nml(32)%N_ang = 1 -obs_param_nml(32)%ang(1) = 40. -obs_param_nml(32)%freq = 1.41e9 -obs_param_nml(32)%FOV = 20. -obs_param_nml(32)%FOV_units = 'km' -obs_param_nml(32)%assim = .false. -obs_param_nml(32)%scale = .false. -obs_param_nml(32)%getinnov = .false. -obs_param_nml(32)%RTM_ID = 2 -obs_param_nml(32)%bias_Npar = 0 -obs_param_nml(32)%bias_trel = 864000 -obs_param_nml(32)%bias_tcut = 432000 -obs_param_nml(32)%nodata = -9999. -obs_param_nml(32)%varname = 'Tb' -obs_param_nml(32)%units = 'K' -obs_param_nml(32)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB/' -obs_param_nml(32)%name = '' -obs_param_nml(32)%maskpath = '' -obs_param_nml(32)%maskname = '' -obs_param_nml(32)%scalepath = '' -obs_param_nml(32)%scalename = '' -obs_param_nml(32)%flistpath = '' -obs_param_nml(32)%flistname = '' -obs_param_nml(32)%errstd = 4. -obs_param_nml(32)%std_normal_max = 2.5 -obs_param_nml(32)%zeromean = .true. -obs_param_nml(32)%coarsen_pert = .false. -obs_param_nml(32)%xcorr = 0.25 -obs_param_nml(32)%ycorr = 0.25 -obs_param_nml(32)%adapt = 0 - -! ------------------- -! -! 33 = SMAP_L1C_Tbv_A - -obs_param_nml(33)%descr = 'SMAP_L1C_Tbv_A' -obs_param_nml(33)%orbit = 1 -obs_param_nml(33)%pol = 2 -obs_param_nml(33)%N_ang = 1 -obs_param_nml(33)%ang(1) = 40. -obs_param_nml(33)%freq = 1.41e9 -obs_param_nml(33)%FOV = 20. -obs_param_nml(33)%FOV_units = 'km' -obs_param_nml(33)%assim = .false. -obs_param_nml(33)%scale = .false. -obs_param_nml(33)%getinnov = .false. -obs_param_nml(33)%RTM_ID = 2 -obs_param_nml(33)%bias_Npar = 0 -obs_param_nml(33)%bias_trel = 864000 -obs_param_nml(33)%bias_tcut = 432000 -obs_param_nml(33)%nodata = -9999. -obs_param_nml(33)%varname = 'Tb' -obs_param_nml(33)%units = 'K' -obs_param_nml(33)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB/' -obs_param_nml(33)%name = '' -obs_param_nml(33)%maskpath = '' -obs_param_nml(33)%maskname = '' -obs_param_nml(33)%scalepath = '' -obs_param_nml(33)%scalename = '' -obs_param_nml(33)%flistpath = '' -obs_param_nml(33)%flistname = '' -obs_param_nml(33)%errstd = 4. -obs_param_nml(33)%std_normal_max = 2.5 -obs_param_nml(33)%zeromean = .true. -obs_param_nml(33)%coarsen_pert = .false. -obs_param_nml(33)%xcorr = 0.25 -obs_param_nml(33)%ycorr = 0.25 -obs_param_nml(33)%adapt = 0 - -! ------------------- -! -! 34 = SMAP_L1C_Tbv_D - -obs_param_nml(34)%descr = 'SMAP_L1C_Tbv_D' -obs_param_nml(34)%orbit = 2 -obs_param_nml(34)%pol = 2 -obs_param_nml(34)%N_ang = 1 -obs_param_nml(34)%ang(1) = 40. -obs_param_nml(34)%freq = 1.41e9 -obs_param_nml(34)%FOV = 20. -obs_param_nml(34)%FOV_units = 'km' -obs_param_nml(34)%assim = .false. -obs_param_nml(34)%scale = .false. -obs_param_nml(34)%getinnov = .false. -obs_param_nml(34)%RTM_ID = 2 -obs_param_nml(34)%bias_Npar = 0 -obs_param_nml(34)%bias_trel = 864000 -obs_param_nml(34)%bias_tcut = 432000 -obs_param_nml(34)%nodata = -9999. -obs_param_nml(34)%varname = 'Tb' -obs_param_nml(34)%units = 'K' -obs_param_nml(34)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB/' -obs_param_nml(34)%name = '' -obs_param_nml(34)%maskpath = '' -obs_param_nml(34)%maskname = '' -obs_param_nml(34)%scalepath = '' -obs_param_nml(34)%scalename = '' -obs_param_nml(34)%flistpath = '' -obs_param_nml(34)%flistname = '' -obs_param_nml(34)%errstd = 4. -obs_param_nml(34)%std_normal_max = 2.5 -obs_param_nml(34)%zeromean = .true. -obs_param_nml(34)%coarsen_pert = .false. -obs_param_nml(34)%xcorr = 0.25 -obs_param_nml(34)%ycorr = 0.25 -obs_param_nml(34)%adapt = 0 - -! -------------------------------------------------------------------- -! -! SMAP L2_SM_AP *downscaled* brightness temperature (9 km EASE grid) -! -! "A" = descending (6pm overpass) -! "D" = descending (6am overpass) -! -! "Tbh" = h-pol Tb -! "Tbv" = v-pol Tb -! - -! ------------------- -! -! 35 = SMAP_L2AP_Tbh_A - -obs_param_nml(35)%descr = 'SMAP_L2AP_Tbh_A' -obs_param_nml(35)%orbit = 1 -obs_param_nml(35)%pol = 1 -obs_param_nml(35)%N_ang = 1 -obs_param_nml(35)%ang(1) = 40. -obs_param_nml(35)%freq = 1.41e9 -obs_param_nml(35)%FOV = 5. -obs_param_nml(35)%FOV_units = 'km' -obs_param_nml(35)%assim = .false. -obs_param_nml(35)%scale = .false. -obs_param_nml(35)%getinnov = .false. -obs_param_nml(35)%RTM_ID = 2 -obs_param_nml(35)%bias_Npar = 0 -obs_param_nml(35)%bias_trel = 864000 -obs_param_nml(35)%bias_tcut = 432000 -obs_param_nml(35)%nodata = -9999. -obs_param_nml(35)%varname = 'Tb' -obs_param_nml(35)%units = 'K' -obs_param_nml(35)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(35)%name = '' -obs_param_nml(35)%maskpath = '' -obs_param_nml(35)%maskname = '' -obs_param_nml(35)%scalepath = '' -obs_param_nml(35)%scalename = '' -obs_param_nml(35)%flistpath = '' -obs_param_nml(35)%flistname = '' -obs_param_nml(35)%errstd = 5. -obs_param_nml(35)%std_normal_max = 2.5 -obs_param_nml(35)%zeromean = .true. -obs_param_nml(35)%coarsen_pert = .false. -obs_param_nml(35)%xcorr = 0.0625 -obs_param_nml(35)%ycorr = 0.0625 -obs_param_nml(35)%adapt = 0 - -! ------------------- -! -! 36 = SMAP_L2AP_Tbh_D - -obs_param_nml(36)%descr = 'SMAP_L2AP_Tbh_D' -obs_param_nml(36)%orbit = 2 -obs_param_nml(36)%pol = 1 -obs_param_nml(36)%N_ang = 1 -obs_param_nml(36)%ang(1) = 40. -obs_param_nml(36)%freq = 1.41e9 -obs_param_nml(36)%FOV = 5. -obs_param_nml(36)%FOV_units = 'km' -obs_param_nml(36)%assim = .false. -obs_param_nml(36)%scale = .false. -obs_param_nml(36)%getinnov = .false. -obs_param_nml(36)%RTM_ID = 2 -obs_param_nml(36)%bias_Npar = 0 -obs_param_nml(36)%bias_trel = 864000 -obs_param_nml(36)%bias_tcut = 432000 -obs_param_nml(36)%nodata = -9999. -obs_param_nml(36)%varname = 'Tb' -obs_param_nml(36)%units = 'K' -obs_param_nml(36)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(36)%name = '' -obs_param_nml(36)%maskpath = '' -obs_param_nml(36)%maskname = '' -obs_param_nml(36)%scalepath = '' -obs_param_nml(36)%scalename = '' -obs_param_nml(36)%flistpath = '' -obs_param_nml(36)%flistname = '' -obs_param_nml(36)%errstd = 5. -obs_param_nml(36)%std_normal_max = 2.5 -obs_param_nml(36)%zeromean = .true. -obs_param_nml(36)%coarsen_pert = .false. -obs_param_nml(36)%xcorr = 0.0625 -obs_param_nml(36)%ycorr = 0.0625 -obs_param_nml(36)%adapt = 0 - -! ------------------- -! -! 37 = SMAP_L2AP_Tbv_A - -obs_param_nml(37)%descr = 'SMAP_L2AP_Tbv_A' -obs_param_nml(37)%orbit = 1 -obs_param_nml(37)%pol = 2 -obs_param_nml(37)%N_ang = 1 -obs_param_nml(37)%ang(1) = 40. -obs_param_nml(37)%freq = 1.41e9 -obs_param_nml(37)%FOV = 5. -obs_param_nml(37)%FOV_units = 'km' -obs_param_nml(37)%assim = .false. -obs_param_nml(37)%scale = .false. -obs_param_nml(37)%getinnov = .false. -obs_param_nml(37)%RTM_ID = 2 -obs_param_nml(37)%bias_Npar = 0 -obs_param_nml(37)%bias_trel = 864000 -obs_param_nml(37)%bias_tcut = 432000 -obs_param_nml(37)%nodata = -9999. -obs_param_nml(37)%varname = 'Tb' -obs_param_nml(37)%units = 'K' -obs_param_nml(37)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(37)%name = '' -obs_param_nml(37)%maskpath = '' -obs_param_nml(37)%maskname = '' -obs_param_nml(37)%scalepath = '' -obs_param_nml(37)%scalename = '' -obs_param_nml(37)%flistpath = '' -obs_param_nml(37)%flistname = '' -obs_param_nml(37)%errstd = 5. -obs_param_nml(37)%std_normal_max = 2.5 -obs_param_nml(37)%zeromean = .true. -obs_param_nml(37)%coarsen_pert = .false. -obs_param_nml(37)%xcorr = 0.0625 -obs_param_nml(37)%ycorr = 0.0625 -obs_param_nml(37)%adapt = 0 - -! ------------------- -! -! 38 = SMAP_L2AP_Tbv_D - -obs_param_nml(38)%descr = 'SMAP_L2AP_Tbv_D' -obs_param_nml(38)%orbit = 2 -obs_param_nml(38)%pol = 2 -obs_param_nml(38)%N_ang = 1 -obs_param_nml(38)%ang(1) = 40. -obs_param_nml(38)%freq = 1.41e9 -obs_param_nml(38)%FOV = 5. -obs_param_nml(38)%FOV_units = 'km' -obs_param_nml(38)%assim = .false. -obs_param_nml(38)%scale = .false. -obs_param_nml(38)%getinnov = .false. -obs_param_nml(38)%RTM_ID = 2 -obs_param_nml(38)%bias_Npar = 0 -obs_param_nml(38)%bias_trel = 864000 -obs_param_nml(38)%bias_tcut = 432000 -obs_param_nml(38)%nodata = -9999. -obs_param_nml(38)%varname = 'Tb' -obs_param_nml(38)%units = 'K' -obs_param_nml(38)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(38)%name = '' -obs_param_nml(38)%maskpath = '' -obs_param_nml(38)%maskname = '' -obs_param_nml(38)%scalepath = '' -obs_param_nml(38)%scalename = '' -obs_param_nml(38)%flistpath = '' -obs_param_nml(38)%flistname = '' -obs_param_nml(38)%errstd = 5. -obs_param_nml(38)%std_normal_max = 2.5 -obs_param_nml(38)%zeromean = .true. -obs_param_nml(38)%coarsen_pert = .false. -obs_param_nml(38)%xcorr = 0.0625 -obs_param_nml(38)%ycorr = 0.0625 -obs_param_nml(38)%adapt = 0 - -! ------------------- -! -! 39 = SMAP_L2AP_FT_A - -obs_param_nml(39)%descr = 'SMAP_L2AP_FT_A' -obs_param_nml(39)%orbit = 1 -obs_param_nml(39)%pol = 0 -obs_param_nml(39)%N_ang = 0 -obs_param_nml(39)%freq = 1.26e9 -obs_param_nml(39)%FOV = 5. -obs_param_nml(39)%FOV_units = 'km' -obs_param_nml(39)%assim = .false. -obs_param_nml(39)%scale = .false. -obs_param_nml(39)%getinnov = .false. -obs_param_nml(39)%RTM_ID = 0 -obs_param_nml(39)%bias_Npar = 0 -obs_param_nml(39)%bias_trel = 864000 -obs_param_nml(39)%bias_tcut = 432000 -obs_param_nml(39)%nodata = -9999. -obs_param_nml(39)%varname = 'FT' -obs_param_nml(39)%units = '-' -obs_param_nml(39)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(39)%name = '' -obs_param_nml(39)%maskpath = '' -obs_param_nml(39)%maskname = '' -obs_param_nml(39)%scalepath = '' -obs_param_nml(39)%scalename = '' -obs_param_nml(39)%flistpath = '' -obs_param_nml(39)%flistname = '' -obs_param_nml(39)%errstd = .0 -obs_param_nml(39)%std_normal_max = 2.5 -obs_param_nml(39)%zeromean = .true. -obs_param_nml(39)%coarsen_pert = .false. -obs_param_nml(39)%xcorr = 0.0625 -obs_param_nml(39)%ycorr = 0.0625 -obs_param_nml(39)%adapt = 0 - -! ------------------- -! -! 40 = SMAP_L2AP_FT_D - -obs_param_nml(40)%descr = 'SMAP_L2AP_FT_D' -obs_param_nml(40)%orbit = 2 -obs_param_nml(40)%pol = 0 -obs_param_nml(40)%N_ang = 0 -obs_param_nml(40)%freq = 1.26e9 -obs_param_nml(40)%FOV = 5. -obs_param_nml(40)%FOV_units = 'km' -obs_param_nml(40)%assim = .false. -obs_param_nml(40)%scale = .false. -obs_param_nml(40)%getinnov = .false. -obs_param_nml(40)%RTM_ID = 0 -obs_param_nml(40)%bias_Npar = 0 -obs_param_nml(40)%bias_trel = 864000 -obs_param_nml(40)%bias_tcut = 432000 -obs_param_nml(40)%nodata = -9999. -obs_param_nml(40)%varname = 'FT' -obs_param_nml(40)%units = '-' -obs_param_nml(40)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L2_SM_AP/' -obs_param_nml(40)%name = '' -obs_param_nml(40)%maskpath = '' -obs_param_nml(40)%maskname = '' -obs_param_nml(40)%scalepath = '' -obs_param_nml(40)%scalename = '' -obs_param_nml(40)%flistpath = '' -obs_param_nml(40)%flistname = '' -obs_param_nml(40)%errstd = .0 -obs_param_nml(40)%std_normal_max = 2.5 -obs_param_nml(40)%zeromean = .true. -obs_param_nml(40)%coarsen_pert = .false. -obs_param_nml(40)%xcorr = 0.0625 -obs_param_nml(40)%ycorr = 0.0625 -obs_param_nml(40)%adapt = 0 - -! -------------------------------------------------------------------- -! -! SMAP L1C_TB_E *enhanced* brightness temperature (9 km EASE grid) -! -! "A" = ascending (6pm *SMAP* overpass) -! "D" = descending (6am *SMAP* overpass) -! -! "Tbh" = h-pol Tb -! "Tbv" = v-pol Tb -! -! IMPORTANT NOTE ON RESOLUTION AND THINNING: -! -! L1C_TB_E observations have ~27-km resolution, which is "enhanced" compared to -! the ~36-km resolution of the standard L1C TB data. Accordingly, -! - FOV is set to 15 km (vs. 20 km for standard L1C Tbs), and -! - xcorr and ycorr are set to 0.1875 deg (vs. 0.25 deg for standard L1C Tbs). -! -! There are two sets of four species defined for L1C_TB_E observations: -! - species 41-44, %descr = 'SMAP_L1C_Tb?_E09_?': *not* thinned (all obs on 9-km EASEv2 grid are kept) -! - species 45-48, %descr = 'SMAP_L1C_Tb?_E27_?': thinned to ~27-km spacing -! Thinning is implemented in subroutine read_obs_SMAP_halforbit_Tb(). -! -! ------------------- -! -! 41 = SMAP_L1C_Tbh_E09_A - -obs_param_nml(41)%descr = 'SMAP_L1C_Tbh_E09_A' -obs_param_nml(41)%orbit = 1 -obs_param_nml(41)%pol = 1 -obs_param_nml(41)%N_ang = 1 -obs_param_nml(41)%ang(1) = 40. -obs_param_nml(41)%freq = 1.41e9 -obs_param_nml(41)%FOV = 15. -obs_param_nml(41)%FOV_units = 'km' -obs_param_nml(41)%assim = .false. -obs_param_nml(41)%scale = .false. -obs_param_nml(41)%getinnov = .false. -obs_param_nml(41)%RTM_ID = 2 -obs_param_nml(41)%bias_Npar = 0 -obs_param_nml(41)%bias_trel = 864000 -obs_param_nml(41)%bias_tcut = 432000 -obs_param_nml(41)%nodata = -9999. -obs_param_nml(41)%varname = 'Tb' -obs_param_nml(41)%units = 'K' -obs_param_nml(41)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(41)%name = '' -obs_param_nml(41)%maskpath = '' -obs_param_nml(41)%maskname = '' -obs_param_nml(41)%scalepath = '' -obs_param_nml(41)%scalename = '' -obs_param_nml(41)%flistpath = '' -obs_param_nml(41)%flistname = '' -obs_param_nml(41)%errstd = 4. -obs_param_nml(41)%std_normal_max = 2.5 -obs_param_nml(41)%zeromean = .true. -obs_param_nml(41)%coarsen_pert = .false. -obs_param_nml(41)%xcorr = 0.1875 -obs_param_nml(41)%ycorr = 0.1875 -obs_param_nml(41)%adapt = 0 - -! ------------------- -! -! 42 = SMAP_L1C_Tbh_E09_D - -obs_param_nml(42)%descr = 'SMAP_L1C_Tbh_E09_D' -obs_param_nml(42)%orbit = 2 -obs_param_nml(42)%pol = 1 -obs_param_nml(42)%N_ang = 1 -obs_param_nml(42)%ang(1) = 40. -obs_param_nml(42)%freq = 1.41e9 -obs_param_nml(42)%FOV = 15. -obs_param_nml(42)%FOV_units = 'km' -obs_param_nml(42)%assim = .false. -obs_param_nml(42)%scale = .false. -obs_param_nml(42)%getinnov = .false. -obs_param_nml(42)%RTM_ID = 2 -obs_param_nml(42)%bias_Npar = 0 -obs_param_nml(42)%bias_trel = 864000 -obs_param_nml(42)%bias_tcut = 432000 -obs_param_nml(42)%nodata = -9999. -obs_param_nml(42)%varname = 'Tb' -obs_param_nml(42)%units = 'K' -obs_param_nml(42)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(42)%name = '' -obs_param_nml(42)%maskpath = '' -obs_param_nml(42)%maskname = '' -obs_param_nml(42)%scalepath = '' -obs_param_nml(42)%scalename = '' -obs_param_nml(42)%flistpath = '' -obs_param_nml(42)%flistname = '' -obs_param_nml(42)%errstd = 4. -obs_param_nml(42)%std_normal_max = 2.5 -obs_param_nml(42)%zeromean = .true. -obs_param_nml(42)%coarsen_pert = .false. -obs_param_nml(42)%xcorr = 0.1875 -obs_param_nml(42)%ycorr = 0.1875 -obs_param_nml(42)%adapt = 0 - -! ------------------- -! -! 43 = SMAP_L1C_Tbv_E09_A - -obs_param_nml(43)%descr = 'SMAP_L1C_Tbv_E09_A' -obs_param_nml(43)%orbit = 1 -obs_param_nml(43)%pol = 2 -obs_param_nml(43)%N_ang = 1 -obs_param_nml(43)%ang(1) = 40. -obs_param_nml(43)%freq = 1.41e9 -obs_param_nml(43)%FOV = 15. -obs_param_nml(43)%FOV_units = 'km' -obs_param_nml(43)%assim = .false. -obs_param_nml(43)%scale = .false. -obs_param_nml(43)%getinnov = .false. -obs_param_nml(43)%RTM_ID = 2 -obs_param_nml(43)%bias_Npar = 0 -obs_param_nml(43)%bias_trel = 864000 -obs_param_nml(43)%bias_tcut = 432000 -obs_param_nml(43)%nodata = -9999. -obs_param_nml(43)%varname = 'Tb' -obs_param_nml(43)%units = 'K' -obs_param_nml(43)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(43)%name = '' -obs_param_nml(43)%maskpath = '' -obs_param_nml(43)%maskname = '' -obs_param_nml(43)%scalepath = '' -obs_param_nml(43)%scalename = '' -obs_param_nml(43)%flistpath = '' -obs_param_nml(43)%flistname = '' -obs_param_nml(43)%errstd = 4. -obs_param_nml(43)%std_normal_max = 2.5 -obs_param_nml(43)%zeromean = .true. -obs_param_nml(43)%coarsen_pert = .false. -obs_param_nml(43)%xcorr = 0.1875 -obs_param_nml(43)%ycorr = 0.1875 -obs_param_nml(43)%adapt = 0 - -! ------------------- -! -! 44 = SMAP_L1C_Tbv_E09_D - -obs_param_nml(44)%descr = 'SMAP_L1C_Tbv_E09_D' -obs_param_nml(44)%orbit = 2 -obs_param_nml(44)%pol = 2 -obs_param_nml(44)%N_ang = 1 -obs_param_nml(44)%ang(1) = 40. -obs_param_nml(44)%freq = 1.41e9 -obs_param_nml(44)%FOV = 15. -obs_param_nml(44)%FOV_units = 'km' -obs_param_nml(44)%assim = .false. -obs_param_nml(44)%scale = .false. -obs_param_nml(44)%getinnov = .false. -obs_param_nml(44)%RTM_ID = 2 -obs_param_nml(44)%bias_Npar = 0 -obs_param_nml(44)%bias_trel = 864000 -obs_param_nml(44)%bias_tcut = 432000 -obs_param_nml(44)%nodata = -9999. -obs_param_nml(44)%varname = 'Tb' -obs_param_nml(44)%units = 'K' -obs_param_nml(44)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(44)%name = '' -obs_param_nml(44)%maskpath = '' -obs_param_nml(44)%maskname = '' -obs_param_nml(44)%scalepath = '' -obs_param_nml(44)%scalename = '' -obs_param_nml(44)%flistpath = '' -obs_param_nml(44)%flistname = '' -obs_param_nml(44)%errstd = 4. -obs_param_nml(44)%std_normal_max = 2.5 -obs_param_nml(44)%zeromean = .true. -obs_param_nml(44)%coarsen_pert = .false. -obs_param_nml(44)%xcorr = 0.1875 -obs_param_nml(44)%ycorr = 0.1875 -obs_param_nml(44)%adapt = 0 - -! ------------------- -! -! 45 = SMAP_L1C_Tbh_E27_A - -obs_param_nml(45)%descr = 'SMAP_L1C_Tbh_E27_A' -obs_param_nml(45)%orbit = 1 -obs_param_nml(45)%pol = 1 -obs_param_nml(45)%N_ang = 1 -obs_param_nml(45)%ang(1) = 40. -obs_param_nml(45)%freq = 1.41e9 -obs_param_nml(45)%FOV = 15. -obs_param_nml(45)%FOV_units = 'km' -obs_param_nml(45)%assim = .false. -obs_param_nml(45)%scale = .false. -obs_param_nml(45)%getinnov = .false. -obs_param_nml(45)%RTM_ID = 2 -obs_param_nml(45)%bias_Npar = 0 -obs_param_nml(45)%bias_trel = 864000 -obs_param_nml(45)%bias_tcut = 432000 -obs_param_nml(45)%nodata = -9999. -obs_param_nml(45)%varname = 'Tb' -obs_param_nml(45)%units = 'K' -obs_param_nml(45)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(45)%name = '' -obs_param_nml(45)%maskpath = '' -obs_param_nml(45)%maskname = '' -obs_param_nml(45)%scalepath = '' -obs_param_nml(45)%scalename = '' -obs_param_nml(45)%flistpath = '' -obs_param_nml(45)%flistname = '' -obs_param_nml(45)%errstd = 4. -obs_param_nml(45)%std_normal_max = 2.5 -obs_param_nml(45)%zeromean = .true. -obs_param_nml(45)%coarsen_pert = .false. -obs_param_nml(45)%xcorr = 0.1875 -obs_param_nml(45)%ycorr = 0.1875 -obs_param_nml(45)%adapt = 0 - -! ------------------- -! -! 46 = SMAP_L1C_Tbh_E27_D - -obs_param_nml(46)%descr = 'SMAP_L1C_Tbh_E27_D' -obs_param_nml(46)%orbit = 2 -obs_param_nml(46)%pol = 1 -obs_param_nml(46)%N_ang = 1 -obs_param_nml(46)%ang(1) = 40. -obs_param_nml(46)%freq = 1.41e9 -obs_param_nml(46)%FOV = 15. -obs_param_nml(46)%FOV_units = 'km' -obs_param_nml(46)%assim = .false. -obs_param_nml(46)%scale = .false. -obs_param_nml(46)%getinnov = .false. -obs_param_nml(46)%RTM_ID = 2 -obs_param_nml(46)%bias_Npar = 0 -obs_param_nml(46)%bias_trel = 864000 -obs_param_nml(46)%bias_tcut = 432000 -obs_param_nml(46)%nodata = -9999. -obs_param_nml(46)%varname = 'Tb' -obs_param_nml(46)%units = 'K' -obs_param_nml(46)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(46)%name = '' -obs_param_nml(46)%maskpath = '' -obs_param_nml(46)%maskname = '' -obs_param_nml(46)%scalepath = '' -obs_param_nml(46)%scalename = '' -obs_param_nml(46)%flistpath = '' -obs_param_nml(46)%flistname = '' -obs_param_nml(46)%errstd = 4. -obs_param_nml(46)%std_normal_max = 2.5 -obs_param_nml(46)%zeromean = .true. -obs_param_nml(46)%coarsen_pert = .false. -obs_param_nml(46)%xcorr = 0.1875 -obs_param_nml(46)%ycorr = 0.1875 -obs_param_nml(46)%adapt = 0 - -! ------------------- -! -! 47 = SMAP_L1C_Tbv_E27_A - -obs_param_nml(47)%descr = 'SMAP_L1C_Tbv_E27_A' -obs_param_nml(47)%orbit = 1 -obs_param_nml(47)%pol = 2 -obs_param_nml(47)%N_ang = 1 -obs_param_nml(47)%ang(1) = 40. -obs_param_nml(47)%freq = 1.41e9 -obs_param_nml(47)%FOV = 15. -obs_param_nml(47)%FOV_units = 'km' -obs_param_nml(47)%assim = .false. -obs_param_nml(47)%scale = .false. -obs_param_nml(47)%getinnov = .false. -obs_param_nml(47)%RTM_ID = 2 -obs_param_nml(47)%bias_Npar = 0 -obs_param_nml(47)%bias_trel = 864000 -obs_param_nml(47)%bias_tcut = 432000 -obs_param_nml(47)%nodata = -9999. -obs_param_nml(47)%varname = 'Tb' -obs_param_nml(47)%units = 'K' -obs_param_nml(47)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(47)%name = '' -obs_param_nml(47)%maskpath = '' -obs_param_nml(47)%maskname = '' -obs_param_nml(47)%scalepath = '' -obs_param_nml(47)%scalename = '' -obs_param_nml(47)%flistpath = '' -obs_param_nml(47)%flistname = '' -obs_param_nml(47)%errstd = 4. -obs_param_nml(47)%std_normal_max = 2.5 -obs_param_nml(47)%zeromean = .true. -obs_param_nml(47)%coarsen_pert = .false. -obs_param_nml(47)%xcorr = 0.1875 -obs_param_nml(47)%ycorr = 0.1875 -obs_param_nml(47)%adapt = 0 - -! ------------------- -! -! 48 = SMAP_L1C_Tbv_E27_D - -obs_param_nml(48)%descr = 'SMAP_L1C_Tbv_E27_D' -obs_param_nml(48)%orbit = 2 -obs_param_nml(48)%pol = 2 -obs_param_nml(48)%N_ang = 1 -obs_param_nml(48)%ang(1) = 40. -obs_param_nml(48)%freq = 1.41e9 -obs_param_nml(48)%FOV = 15. -obs_param_nml(48)%FOV_units = 'km' -obs_param_nml(48)%assim = .false. -obs_param_nml(48)%scale = .false. -obs_param_nml(48)%getinnov = .false. -obs_param_nml(48)%RTM_ID = 2 -obs_param_nml(48)%bias_Npar = 0 -obs_param_nml(48)%bias_trel = 864000 -obs_param_nml(48)%bias_tcut = 432000 -obs_param_nml(48)%nodata = -9999. -obs_param_nml(48)%varname = 'Tb' -obs_param_nml(48)%units = 'K' -obs_param_nml(48)%path = '/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/L1C_TB_E/' -obs_param_nml(48)%name = '' -obs_param_nml(48)%maskpath = '' -obs_param_nml(48)%maskname = '' -obs_param_nml(48)%scalepath = '' -obs_param_nml(48)%scalename = '' -obs_param_nml(48)%flistpath = '' -obs_param_nml(48)%flistname = '' -obs_param_nml(48)%errstd = 4. -obs_param_nml(48)%std_normal_max = 2.5 -obs_param_nml(48)%zeromean = .true. -obs_param_nml(48)%coarsen_pert = .false. -obs_param_nml(48)%xcorr = 0.1875 -obs_param_nml(48)%ycorr = 0.1875 -obs_param_nml(48)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 49 = ASCAT_META_SM (ASCAT soil moisture ascending and descending orbits) -! -! https://navigator.eumetsat.int/product/EO:EUM:DAT:METOP:SOMO25 - -obs_param_nml(49)%descr = 'ASCAT_META_SM' -obs_param_nml(49)%orbit = 3 -obs_param_nml(49)%pol = 0 -obs_param_nml(49)%N_ang = 0 -obs_param_nml(49)%freq = 0 -obs_param_nml(49)%FOV = 20. -obs_param_nml(49)%FOV_units = 'km' -obs_param_nml(49)%assim = .false. -obs_param_nml(49)%scale = .false. -obs_param_nml(49)%getinnov = .false. -obs_param_nml(49)%RTM_ID = 0 -obs_param_nml(49)%bias_Npar = 0 -obs_param_nml(49)%bias_trel = 864000 -obs_param_nml(49)%bias_tcut = 432000 -obs_param_nml(49)%nodata = -9999. -obs_param_nml(49)%varname = 'sfds' -obs_param_nml(49)%units = '%' -obs_param_nml(49)%path = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/ASCAT_EUMETSAT/Metop_A/' -obs_param_nml(49)%name = 'M02-ASCA-ASCSMO02' -obs_param_nml(49)%maskpath = '' -obs_param_nml(49)%maskname = '' -obs_param_nml(49)%scalepath = '' -obs_param_nml(49)%scalename = '' -obs_param_nml(49)%flistpath = '' -obs_param_nml(49)%flistname = '' -obs_param_nml(49)%errstd = 9. -obs_param_nml(49)%std_normal_max = 2.5 -obs_param_nml(49)%zeromean = .true. -obs_param_nml(49)%coarsen_pert = .false. -obs_param_nml(49)%xcorr = 0.25 -obs_param_nml(49)%ycorr = 0.25 -obs_param_nml(49)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 50 = ASCAT_METB_SM (ASCAT soil moisture ascending and descending orbits) -! -! https://navigator.eumetsat.int/product/EO:EUM:DAT:METOP:SOMO25 - -obs_param_nml(50)%descr = 'ASCAT_METB_SM' -obs_param_nml(50)%orbit = 3 -obs_param_nml(50)%pol = 0 -obs_param_nml(50)%N_ang = 0 -obs_param_nml(50)%freq = 0 -obs_param_nml(50)%FOV = 20. -obs_param_nml(50)%FOV_units = 'km' -obs_param_nml(50)%assim = .false. -obs_param_nml(50)%scale = .false. -obs_param_nml(50)%getinnov = .false. -obs_param_nml(50)%RTM_ID = 0 -obs_param_nml(50)%bias_Npar = 0 -obs_param_nml(50)%bias_trel = 864000 -obs_param_nml(50)%bias_tcut = 432000 -obs_param_nml(50)%nodata = -9999. -obs_param_nml(50)%varname = 'sfds' -obs_param_nml(50)%units = '%' -obs_param_nml(50)%path = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/ASCAT_EUMETSAT/Metop_B/' -obs_param_nml(50)%name = 'M01-ASCA-ASCSMO02' -obs_param_nml(50)%maskpath = '' -obs_param_nml(50)%maskname = '' -obs_param_nml(50)%scalepath = '' -obs_param_nml(50)%scalename = '' -obs_param_nml(50)%flistpath = '' -obs_param_nml(50)%flistname = '' -obs_param_nml(50)%errstd = 9. -obs_param_nml(50)%std_normal_max = 2.5 -obs_param_nml(50)%zeromean = .true. -obs_param_nml(50)%coarsen_pert = .false. -obs_param_nml(50)%xcorr = 0.25 -obs_param_nml(50)%ycorr = 0.25 -obs_param_nml(50)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 51 = ASCAT_METC_SM (ASCAT soil moisture ascending and descending orbits) -! -! https://navigator.eumetsat.int/product/EO:EUM:DAT:METOP:SOMO25 - -obs_param_nml(51)%descr = 'ASCAT_METC_SM' -obs_param_nml(51)%orbit = 3 -obs_param_nml(51)%pol = 0 -obs_param_nml(51)%N_ang = 0 -obs_param_nml(51)%freq = 0 -obs_param_nml(51)%FOV = 20. -obs_param_nml(51)%FOV_units = 'km' -obs_param_nml(51)%assim = .false. -obs_param_nml(51)%scale = .false. -obs_param_nml(51)%getinnov = .false. -obs_param_nml(51)%RTM_ID = 0 -obs_param_nml(51)%bias_Npar = 0 -obs_param_nml(51)%bias_trel = 864000 -obs_param_nml(51)%bias_tcut = 432000 -obs_param_nml(51)%nodata = -9999. -obs_param_nml(51)%varname = 'sfds' -obs_param_nml(51)%units = '%' -obs_param_nml(51)%path = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/ASCAT_EUMETSAT/Metop_C/' -obs_param_nml(51)%name = 'M03-ASCA-ASCSMO02' -obs_param_nml(51)%maskpath = '' -obs_param_nml(51)%maskname = '' -obs_param_nml(51)%scalepath = '' -obs_param_nml(51)%scalename = '' -obs_param_nml(51)%flistpath = '' -obs_param_nml(51)%flistname = '' -obs_param_nml(51)%errstd = 9. -obs_param_nml(51)%std_normal_max = 2.5 -obs_param_nml(51)%zeromean = .true. -obs_param_nml(51)%coarsen_pert = .false. -obs_param_nml(51)%xcorr = 0.25 -obs_param_nml(51)%ycorr = 0.25 -obs_param_nml(51)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 52 = MODIS Aqua snow cover area fraction (SCF) -! -! MOD10C1.*.061: MODIS Aqua SCF, 0.05deg CMG, daytime (01:30pm local) ascending overpass, version V61 -! -! for rule-based snow cover analysis (no obs error/pert specs) - -obs_param_nml(52)%descr = 'MYD10C1' -obs_param_nml(52)%orbit = 1 -obs_param_nml(52)%pol = 0 -obs_param_nml(52)%N_ang = 0 -obs_param_nml(52)%freq = 0. -obs_param_nml(52)%FOV = 0. -obs_param_nml(52)%FOV_units = 'deg' -obs_param_nml(52)%assim = .false. -obs_param_nml(52)%scale = .false. -obs_param_nml(52)%getinnov = .false. -obs_param_nml(52)%RTM_ID = 0 -obs_param_nml(52)%bias_Npar = 0 -obs_param_nml(52)%bias_trel = 864000 -obs_param_nml(52)%bias_tcut = 432000 -obs_param_nml(52)%nodata = -9999. -obs_param_nml(52)%varname = 'asnow' -obs_param_nml(52)%units = 'm2/m2' -obs_param_nml(52)%path = '/discover/nobackup/projects/S2SHMA/MODIS/MYD10C1_V61/' -obs_param_nml(52)%name = 'MYD10C1.Ayyyyddd.061.hdf' -obs_param_nml(52)%maskpath = '' -obs_param_nml(52)%maskname = '' -obs_param_nml(52)%scalepath = '' -obs_param_nml(52)%scalename = '' -obs_param_nml(52)%flistpath = '' -obs_param_nml(52)%flistname = '' -obs_param_nml(52)%errstd = -9999. -obs_param_nml(52)%std_normal_max = -9999. -obs_param_nml(52)%zeromean = .false. -obs_param_nml(52)%coarsen_pert = .false. -obs_param_nml(52)%xcorr = 0. -obs_param_nml(52)%ycorr = 0. -obs_param_nml(52)%adapt = 0 - -! -------------------------------------------------------------------- -! -! 53 = MODIS Terra snow cover area fraction (SCF) -! -! MOD10C1.*.061: MODIS Terra SCF, 0.05deg CMG, daytime (10:30am local) descending overpass, version V61 -! -! for rule-based snow cover analysis (no obs error/pert specs) - -obs_param_nml(53)%descr = 'MOD10C1' -obs_param_nml(53)%orbit = 2 -obs_param_nml(53)%pol = 0 -obs_param_nml(53)%N_ang = 0 -obs_param_nml(53)%freq = 0. -obs_param_nml(53)%FOV = 0. -obs_param_nml(53)%FOV_units = 'deg' -obs_param_nml(53)%assim = .false. -obs_param_nml(53)%scale = .false. -obs_param_nml(53)%getinnov = .false. -obs_param_nml(53)%RTM_ID = 0 -obs_param_nml(53)%bias_Npar = 0 -obs_param_nml(53)%bias_trel = 864000 -obs_param_nml(53)%bias_tcut = 432000 -obs_param_nml(53)%nodata = -9999. -obs_param_nml(53)%varname = 'asnow' -obs_param_nml(53)%units = 'm2/m2' -obs_param_nml(53)%path = '/discover/nobackup/projects/S2SHMA/MODIS/MOD10C1_V61/' -obs_param_nml(53)%name = 'MOD10C1.Ayyyyddd.061.hdf' -obs_param_nml(53)%maskpath = '' -obs_param_nml(53)%maskname = '' -obs_param_nml(53)%scalepath = '' -obs_param_nml(53)%scalename = '' -obs_param_nml(53)%flistpath = '' -obs_param_nml(53)%flistname = '' -obs_param_nml(53)%errstd = -9999. -obs_param_nml(53)%std_normal_max = -9999. -obs_param_nml(53)%zeromean = .false. -obs_param_nml(53)%coarsen_pert = .false. -obs_param_nml(53)%xcorr = 0. -obs_param_nml(53)%ycorr = 0. -obs_param_nml(53)%adapt = 0 - - -! -------------------------------------------------------------------- - -/ - -! =========================== EOF ======================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App b/src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App deleted file mode 100644 index 3cc60e01..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/README_LDAS_App +++ /dev/null @@ -1,36 +0,0 @@ -README_GEOSldas_App: README file for GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App - -rreichle, 8 July 2022: Initial version - -This directory contains a collection of programs, scripts, and config files, specifically: - -[..]/GEOSldas_App/ - -- Config files and programs/scripts needed by ldas_setup or lenkf.j (GEOSldas job script). - -[..]/GEOSldas_App/ens_forcing/ - -- Scripts needed by lenkf.j to process ensemble-based forcing (primarily for LADAS). - -[..]/GEOSldas_App/sample_config_files/ - -- Sample config files for ldas_setup and HISTORY. - -[..]/GEOSldas_App/util/config/ - -- Miscellaneous scripts to (manually) create/modify config files. - -[..]/GEOSldas_App/util/inputs/ - -- Miscellaneous scripts to (manually) create/modify input files. - -[..]/GEOSldas_App/util/postproc/ - -- Miscellaneous scripts for post-processing GEOSldas output. - -[..]/GEOSldas_App/util/shared/ - -- Miscellaneous shared reader and helper scripts (primarily matlab). - - -=============== EOF =============================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py deleted file mode 100644 index 6c3c8581..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/average_ensemble_forcing.py +++ /dev/null @@ -1,71 +0,0 @@ -#!/usr/bin/env python -# -# module load python/GEOSpyD/Ana2019.03_py3.7 -# module load nco/4.8.1 -# -# Script for creating ensemble-average land forcing (lfo) files. -# -# Usage: average_ensemble_forcing.py [in_path] [out_path] [nens] -# -# where -# -# in_path : path to ensemble of lfo files -# out_path : path to output ensemble-average lfo files -# nens : number of lfo ensemble members -# -# The ensemble of input lfo files must be staged as follows: -# -# [in_path]/mem[NNN]/[EXPID].[HISTSPECa]_lfo_[HISTSPECb].[YYYYMMDD_HHMM]z.nc4 -# -# where -# -# [in_path] = command-line argument that specifies the path to the ensemble of lfo files -# [NNN] = three-digit ensemble ID (number from 1 to nens) -# [EXPID] = experiment ID -# [HISTSPECa/b] = other specs from HISTORY.rc (e.g., "tavg1_2d", "inst1_2d", "Nx+-") -# [YYYYMMDD_HHMM] = time stamp -# -# This convention matches the directory/file structure generated by the ensemble component -# of the GEOS atmospheric data assimilation system (ADAS). -# The ensemble-average files are created *separately* for each time, for each experiment ID, -# and for each distinct HISTORY spec. -# The ensemble-average files are placed in "out_path" (command-line argument) -# and will have the same name as the corresponding input files. - -import sys -import os -import glob -import subprocess as sp - -def averaging_forcing(in_path, out_path, nens): - """ The ensemble number will be appended to in_path starting from 001. - The out_path will be created if it does not exist. """ - if not os.path.exists(out_path): - os.makedirs(out_path) - files_list=[] - for i in range(1,nens+1): - sfx = '%03d'%(i) - folder = in_path+'/atmens/ensdiag/mem'+sfx - fs = sorted(glob.glob(folder+'/*lfo*.nc4')) - files_list.append(fs) - for fs in zip(*files_list): - k = 1 - # verify filenames are the same. - for f in fs: - n = f.rindex('/') - if (k==1): - f0 = f[n+1:] - k = k+1 - f1 = f[n+1:] - assert f0 == f1, "averaging different files. Each folder should have same files" - fnames = " ".join(fs) - cmd = 'ncea ' + fnames + ' ' + out_path +'/' + f0 - sp.call(cmd, shell=True) - -if __name__ == '__main__' : - - in_path = sys.argv[1] - out_path = sys.argv[2] - nens = int(sys.argv[3]) - - averaging_forcing(in_path, out_path, nens) diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh deleted file mode 100755 index 6372a1d5..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/enpert_forc.csh +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/csh -f - -# Script to create re-centered ensemble land forcing files (*inst1_2d_lfo*, *tavg1_2d_lfo*), -# typically used in LADAS: -# -# 1. Regrid coarse-resolution lfo files from the ADAS atmospheric ensemble to the higher -# resolution of the single-member central (or deterministic) simulation. -# -# 2. Compute perturbations from regridded lfo files. -# -# 3. Apply perturbations to lfo files from central simulation. -# -# Requires environment variables: -# ADAS_EXPDIR - path the ADAS experiment directory (ensemble of lfo files) -# GRID - target grid of forcing files (typically that of deterministic ADAS simulation) -# NENS - number of (LDAS) ensemble members (<= number of ADAS ensemble members) -# GEOSBIN - GEOSldas "ROOT" directory (typically GEOSldas/install/bin) -# -# Input data sets: -# 1. lfo files from coarse-resolution ADAS ensemble -# 2. lfo files from higher-resolution deterministic ADAS simulation -# -# Output data set: -# 1. ensemble of lfo files at resolution of deterministic ADAS simulation -# -# ------------------------------------------------------------------------------------ - -set force_cntr = "${ADAS_EXPDIR}/recycle/holdforc" -set force_orig = "${ADAS_EXPDIR}/atmens" -set force_rgd = "${ADAS_EXPDIR}/atmens/rgdlfo" -set outgrid = "${GRID}" - -mkdir $force_rgd - -$GEOSBIN/regrid_forc.csh $force_orig $force_rgd $outgrid - -rm -rf $force_orig/tmp* - -python $GEOSBIN/ensemble_forc.py $force_rgd $force_cntr $NENS - -cd $force_rgd -@ inens = 0 -while ($inens < $NENS) - @ inens ++ - if ($inens <10) then - set ENSDIR = `echo mem00${inens}` - else if($inens<100) then - set ENSDIR=`echo mem0${inens}` - endif - cd ${ENSDIR} - /bin/rm -rf *lfo*nc4 - $GEOSBIN/stripname nc4.Cpert nc4 - cd $force_rgd -end - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py deleted file mode 100755 index 413c5700..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/ensemble_forc.py +++ /dev/null @@ -1,192 +0,0 @@ -#!/usr/bin/env python -# -# module load python/GEOSpyD/Ana2019.03_py3.7 -# module load nco/4.8.1 -# -# Script for creating ensemble-perturbed land forcing (lfo) files. -# Usage: ensemble_forc.py [in_path] [cntr_path] [nens] -# -# where -# -# in_path : path to ensemble lfo files -# cntr_path : path to deterministic lfo files -# nens : number of ensemble members -#=========================================== - -import sys -import os -import glob -import subprocess as sp -import numpy as np -from netCDF4 import Dataset - - -def averaging_forcing(in_path, avg_path, nens): - """ The ensemble number will be appended to in_path starting from 001. - The out_path will be created if it does not exist. """ - print ( " average ensemble " ) - if not os.path.exists(avg_path): - os.makedirs(avg_path) - files_list=[] - for i in range(1,nens+1): - sfx = '%03d'%(i) - folder = in_path+'/mem'+sfx - fs = sorted(glob.glob(folder+'/*lfo*.nc4')) - files_list.append(fs) - for fs in zip(*files_list): - k = 1 - # verify filenames are the same. - for f in fs: - n = f.rindex('/') - if (k==1): - f0 = f[n+1:] - k = k+1 - f1 = f[n+1:] - assert f0 == f1, "averaging different files. Each folder should have same files" - fnames = " ".join(fs) - cmd = 'ncea ' + fnames + ' ' + avg_path +'/' + f0 - sp.call(cmd, shell=True) - -def mean_diff(ensm_path, cntr_path): - print ( " prepare central - ensmean for recentering ") - files_list=[] - folder = ensm_path - fs = sorted(glob.glob(folder+'/*lfo*.nc4')) - files_list.append(fs) - for fs in zip(*files_list): - k = 1 - for f in fs: - n = f.rindex('/') - if (k==1): - f0 = f[n+1:] - k = k+1 - f1 = f[n+1:] - assert f0 == f1, "central and ensmean should have same filenames" - cmd = 'ncbo --op_typ=sbt ' + cntr_path + '/' + f1 + ' ' + f + ' ' + f +'.dif' - #print ( cmd ) - sp.call(cmd, shell=True) - -def recenter_forc(in_path, avg_path, cntr_path, nens): - print ( "recenter ens forcing to central forcing " ) - Varlist = ["PRECCU", "PRECLS", "PRECSNO", "SWGDN" ] - print ( "Varlist for multipl-recentering: ", Varlist) - - mean_diff(avg_path, cntr_path) - - files_list1=[] - for i in range(1,nens+1): - sfx = '%03d'%(i) - folder = in_path+'/mem'+sfx - fs1 = sorted(glob.glob(folder+'/*lfo*.nc4')) - files_list1.append(fs1) - for fs in zip(*files_list1): - k = 1 - for f in fs: - n = f.rindex('/') - if (k==1): - f0 = f[n+1:] - k = k+1 - f1 = f[n+1:] - assert f0 == f1, "memeber and ensmean should have same filenames" - cmd = 'ncbo --op_typ=add ' + f + ' ' + avg_path +'/' + f1 + '.dif' + ' ' + f +'.Cpert' - sp.call(cmd, shell=True) - - files_list=[] - for i in range(1,nens+1): - sfx = '%03d'%(i) - folder = in_path+'/mem'+sfx - fs = sorted(glob.glob(folder+'/*tavg*lfo*.nc4')) - files_list.append(fs) - for fs in zip(*files_list): - k = 1 - for f in fs: - n = f.rindex('/') - if (k==1): - f0 = f[n+1:] - m_file = avg_path+'/'+f0 - Var_m = readlfo(m_file, Varlist) - c_file = cntr_path+'/'+f0 - Var_c = readlfo(c_file, Varlist) - k = k+1 - f1 = f[n+1:] - fout = f + '.Cpert' - Var_e = readlfo(f, Varlist) - Var_ux = fact_multpl(Var_m,Var_e,Var_c) - upd_vars(fout, Var_ux, Varlist) - -def readlfo(ncfile, Varlist): - wkfile = Dataset(ncfile, "r") - nydim = len(wkfile.dimensions["Ydim"]) - nxdim = len(wkfile.dimensions["Xdim"]) - nfdim = len(wkfile.dimensions["nf"]) - dim3 = [nfdim, nydim, nxdim] - nvar = len(Varlist) - vardata = np.zeros((nvar, dim3[0], dim3[1], dim3[2]), dtype=float) - for rdvar in iter(range(nvar)): - vardata[rdvar] = wkfile.variables[Varlist[rdvar]][0] - - wkfile.close() - return vardata - -def upd_vars(ncfile, Dataupd, Varupd): - - wkfile = Dataset(ncfile,'r+') - nvar = len(Varupd) - for rdvar in iter(range(nvar)) : - wkfile.variables[Varupd[rdvar]][0] = Dataupd[rdvar] - - wkfile.close() - -def fact_multpl(Var_dn,Var_up,Var_cn): - - dim = np.shape(Var_dn) - ndim = len(dim) - dim3 = [ dim[1], dim[2],dim[3] ] - ndim3 = len(dim3) - - #sum precip [0, 1, 2 from Varlist(4) ) - Var_3pup = np.zeros(dim3, dtype=float) - Var_3pdn = np.zeros(dim3, dtype=float) - Var_3pup[:,:,:] = Var_up[0,:,:,:] + Var_up[1,:,:,:] + Var_up[2,:,:,:] - Var_3pdn[:,:,:] = Var_dn[0,:,:,:] + Var_dn[1,:,:,:] + Var_dn[2,:,:,:] - nvec = 1 - for id in iter(range(ndim3)): - nvec = dim3[id]*nvec - - vecdn = np.reshape(Var_3pdn,nvec) - vecup = np.reshape(Var_3pup,nvec) - vecnew = np.zeros(nvec,dtype=float) - - ind = np.argwhere(vecdn>1.0e-10) - vecnew [ind] = vecup[ind] / vecdn[ind] - - Var_uu = np.zeros((dim3), dtype=float) - Var_uu = np.reshape(vecnew,(dim3)) - # apply the same factor to 3 precip - Var_upx = np.zeros((dim), dtype=float) - Var_upx[0,:,:,:] = Var_uu[:,:,:] * Var_cn[0,:,:,:] - Var_upx[1,:,:,:] = Var_uu[:,:,:] * Var_cn[1,:,:,:] - Var_upx[2,:,:,:] = Var_uu[:,:,:] * Var_cn[2,:,:,:] - # deal with swgdn - Var_3pup[:,:,:] = Var_up[3,:,:,:] - Var_3pdn[:,:,:] = Var_dn[3,:,:,:] - vecdn = np.reshape(Var_3pdn,nvec) - vecup = np.reshape(Var_3pup,nvec) - vecnew = np.zeros(nvec,dtype=float) - ind = np.argwhere(vecdn!=0) - vecnew [ind] = vecup[ind] / vecdn[ind] - Var_uu = np.zeros((dim3), dtype=float) - Var_uu = np.reshape(vecnew,(dim3)) - Var_upx[3,:,:,:] = Var_uu[:,:,:] * Var_cn[3,:,:,:] - - return Var_upx - - -if __name__ == '__main__' : - - in_path = sys.argv[1] - cntr_path = sys.argv[2] - nens = int(sys.argv[3]) - mean_path = in_path + '/lfomean' - averaging_forcing(in_path,mean_path, nens) - recenter_forc(in_path, mean_path, cntr_path, nens) diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh deleted file mode 100755 index d6b80f34..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/regrid_forc.csh +++ /dev/null @@ -1,63 +0,0 @@ -#!/usr/bin/csh -f - -set echo -setenv MYNAME regrid_forc.csh - -if ( $#argv < 3 ) then - echo " " - echo " SYNOPSIS " - echo " " - echo " $MYNAME force_in force_rgd outgrid" - echo " " - echo " where" - echo " force_in - path to orginal forcing, e.g., $ADAS_EXPDIR/atmens/" - echo " force_rgd - path to regrid forcing, e.g., $ADAS_EXPDIR/atmens/rgdlfo" - echo " outgrid - output grid , e.g., PE180x1080-CF ") - echo " NENS ensemble number , e.g., 24 should be env var ") - exit(0) -endif - -set ogdir = $1 -set rgdir = $2 -set outgrid = $3 - -set NENSin = $NENS -echo "check NENS, $NENSin " - -mkdir $ogdir/tmpd - -@ inens = 0 -while ($inens < $NENSin) - @ inens ++ - if ($inens <10) then - set ENSDIR = `echo mem00${inens}` - else if($inens<100) then - set ENSDIR=`echo mem0${inens}` - endif - /bin/ln -s $ogdir/ensdiag/${ENSDIR} $ogdir/tmpd/${ENSDIR} - mkdir $rgdir/${ENSDIR} -end - -cd $ogdir -/bin/ls -1 tmpd/mem*/*inst*lfo*nc4| awk 'NR == 1 {printf $0} NR > 1 {printf ", %s",$0} END {printf "\n"}' > tmpf -cat tmpf | sed 's/, /,/g' > tmpff -set ininst1 = (`cat tmpff `) -set outinst1 = (`cat tmpff | sed 's/tmpd/rgdlfo/g' `) - -/bin/ls -1 tmpd/mem*/*tavg*lfo*nc4| awk 'NR == 1 {printf $0} NR > 1 {printf ", %s",$0} END {printf "\n"}' > tmpf -cat tmpf | sed 's/, /,/g' > tmpff -set intavg1 = (`cat tmpff `) -set outtavg1 = (`cat tmpff | sed 's/tmpd/rgdlfo/g' `) - -set mympi = "mpirun" - - $mympi -np 24 $GEOSBIN/Regrid_Util.x -i $ininst1 \ - -o $outinst1 \ - -nx 4 -ny 6 \ - -ogrid $outgrid - - $mympi -np 24 $GEOSBIN/Regrid_Util.x -i $intavg1 \ - -o $outtavg1 \ - -nx 4 -ny 6 \ - -ogrid $outgrid - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j b/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j deleted file mode 100755 index 820027fb..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ens_forcing/test_enpert_forc.j +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/csh - -# sample script for testing "enpert_forc.csh" -# -# must edit paths before submitting this script -# -# ----------------------------------------------------------- - -#SBATCH --ntasks=1 -#SBATCH --time=1:00:00 -#SBATCH --job-name=test_enpert_forc -#SBATCH --output=/discover/nobackup/[USER]/test_enpert_forc.o%j.txt -#SBATCH --export=NONE -#SBATCH --qos=debug - -# set environment variables needed by enpert_forc.csh - -setenv GEOSBIN /discover/nobackup/[USER]/GEOSldas/install/bin -setenv ADAS_EXPDIR /discover/nobackup/[USER]/[ADAS_EXPID]/ -setenv NENS 24 -setenv GRID PE180x1080-CF - -# load modules - -source $GEOSBIN/g5_modules - -# python should come with ESMA_env g5_modules -# module load python/GEOSpyD/Ana2019.03_py3.7 - -if ( -e /etc/os-release ) then - module load nco/4.8.1 -else - module load other/nco-4.6.8-gcc-5.3-sp3 -endif - -# execute test - -$GEOSBIN/enpert_forc.csh - -# ====================== EOF =================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup b/src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup deleted file mode 100755 index 6cf1c5ae..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/ldas_setup +++ /dev/null @@ -1,1763 +0,0 @@ -#!/usr/bin/env python3 - -import os -import sys -import glob -import copy -import linecache -import shutil -import argparse -import fileinput -import time -import resource -import subprocess as sp -import shlex -import tempfile -from dateutil import rrule -from datetime import datetime -from datetime import timedelta -from collections import OrderedDict -from dateutil.relativedelta import relativedelta -from remap_utils import * -from remap_catchANDcn import * -from remap_config_ldas import * - -""" -This script is intended to be run from any installed directory with GEOSldas.x and ldas_setup -(The default setup is ../install/bin) -""" - - -class LDASsetup: - - def __init__(self, cmdLineArgs): - """ - """ - # ------ - # Required exe input fields - # These fields are needed to pre-compute exp dir structure - # ------ - rqdExeInpKeys = ['EXP_ID', 'EXP_DOMAIN', 'NUM_LDAS_ENSEMBLE', - 'BEG_DATE', 'END_DATE','RESTART_PATH', - 'RESTART_DOMAIN','RESTART_ID','MET_TAG','MET_PATH','FORCE_DTSTEP','BCS_PATH', 'BCS_RESOLUTION'] - rqdExeInpKeys_rst = ['EXP_ID', 'EXP_DOMAIN', 'NUM_LDAS_ENSEMBLE', - 'BEG_DATE', 'END_DATE','MET_TAG','MET_PATH','FORCE_DTSTEP','BCS_PATH', 'BCS_RESOLUTION'] - - # These keywords are excluded from LDAS.rc (i.e., only needed in pre- or post-processing) - self.NoneLDASrcKeys=['EXP_ID', 'EXP_DOMAIN', - 'BEG_DATE', 'END_DATE','RESTART','RESTART_PATH', - 'RESTART_DOMAIN','RESTART_ID','BCS_PATH','TILING_FILE','GRN_FILE','LAI_FILE','LNFM_FILE','NIRDF_FILE', - 'VISDF_FILE','CATCH_DEF_FILE','NDVI_FILE', - 'NML_INPUT_PATH','HISTRC_FILE','RST_FROM_GLOBAL','JOB_SGMT','NUM_SGMT','POSTPROC_HIST', - 'MINLON','MAXLON','MINLAT','MAXLAT','EXCLUDE_FILE','INCLUDE_FILE','MWRTM_PATH','GRIDNAME', - 'ADAS_EXPDIR', 'BCS_RESOLUTION' ] - - # if built on sles15, BUILT_ON_SLES15 is "TRUE", else empty "" - BUILT_ON_SLES15 = "@BUILT_ON_SLES15@" - if BUILT_ON_SLES15 == "TRUE": - self.BUILT_ON_SLES15 = True - else: - self.BUILT_ON_SLES15 = False - - self.GEOS_SITE = "@GEOS_SITE@" - - # ------ - # Required resource manager input fields - # ------ - rqdRmInpKeys = ['account', 'walltime', 'ntasks_model', 'ntasks-per-node'] - # ------ - # Optional resource manager input fields - # ------ - optSlurmInpKeys = ['job_name', 'qos', 'oserver_nodes', 'writers-per-node'] - - # ------ - # ./ldsetup.py sample ... - # ------ - if 'exeinp' in cmdLineArgs: - # sample sub-command - # by construction, we can have - # either: {'exeinp': False, 'batinp': 'lasgh'} <-- 'lasgh'??? - # or: {'exeinp': True, 'batinp': None} - if cmdLineArgs['exeinp']: - _printExeInputKeys(rqdExeInpKeys) - elif cmdLineArgs['batinp'] : - _printRmInputKeys(rqdRmInpKeys, optSlurmInpKeys) - else: - raise Exception('not recognized option') - sys.exit(0) - - # ------ - # ./ldsetup.py setup ... - # ------ - # Instance variables - self.exeinpfile = cmdLineArgs['exeinpfile'] - self.batinpfile = cmdLineArgs['batinpfile'] - self.exphome = cmdLineArgs['exphome'].rstrip('/') - assert os.path.isdir(self.exphome) # exphome should exist - self.verbose = cmdLineArgs['verbose'] - self.runmodel = cmdLineArgs['runmodel'] - if self.runmodel : - print('\n The option "--runmodel" is out of date, not necessary anymore. \n') - self.daysperjob = cmdLineArgs['daysperjob'] - self.monthsperjob = cmdLineArgs['monthsperjob'] - self.rqdExeInp = OrderedDict() - self.rqdRmInp = OrderedDict() - self.optRmInp = OrderedDict() - self.rundir = None - self.blddir = None - self.blddirLn = None - self.outdir = None - self.out_path = None - self.inpdir = None - self.exefyl = None - self.islocal = False - self.catch = '' - self.has_mwrtm = False - self.has_vegopacity = False - self.assim = False - self.has_landassim_seed = False - self.has_geos_pert = False - self.nSegments = 1 - self.perturb = 0 - self.first_ens_id = 0 - self.ladas_coupling = 0 - self.in_rstfile = None - self.in_tilefile = 'None' # default string - self.ens_id_width = 6 # _eXXXX - self.bcs_land = '' - self.bcs_geom = '' - self.bcs_landshared = '' - - # ------ - # Read exe input file which is required to set up the dir - # ------ - self.rqdExeInp = self._parseInputFile(cmdLineArgs['exeinpfile']) - # verifing the required input - if 'RESTART' not in self.rqdExeInp : - self.rqdExeInp['RESTART'] = 1 - - if self.rqdExeInp['RESTART'].isdigit() : - if int(self.rqdExeInp['RESTART']) ==0 : - rqdExeInpKeys = rqdExeInpKeys_rst - self.rqdExeInp['RESTART_ID'] = "none" - self.rqdExeInp['RESTART_DOMAIN'] = "none" - self.rqdExeInp['RESTART_PATH'] = "none" - else: - if self.rqdExeInp['RESTART'] =='G' : - rqdExeInpKeys = rqdExeInpKeys_rst - self.rqdExeInp['RESTART_DOMAIN'] = "none" - else: - self.rqdExeInp['RESTART_ID'] = "none" - self.rqdExeInp['RESTART_DOMAIN'] = "none" - self.rqdExeInp['RESTART_PATH'] = "none" - - for key in rqdExeInpKeys : - assert key in self.rqdExeInp,' "%s" is required in the input file %s' % (key,self.exeinpfile) - - # print rqd exe inputs - if self.verbose: - print ('\nInputs from execfile:\n') - _printdict(self.rqdExeInp) - - # nens is an integer and =1 for model run - self.nens = int(self.rqdExeInp['NUM_LDAS_ENSEMBLE']) # fail if Nens's val is not int - assert self.nens>0, 'NUM_LDAS_ENSEMBLE [%d] <= 0' % self.nens - _mydir = self.exphome + '/' + self.rqdExeInp['EXP_ID'] - assert not os.path.isdir(_mydir), 'Dir [%s] already exists!' % _mydir - _mydir = None - self.ladas_coupling = int(self.rqdExeInp.get('LADAS_COUPLING',0)) - if self.ladas_coupling > 0: - assert 'ADAS_EXPDIR' in self.rqdExeInp, " need ADAS_EXPDIR in the input file %s" %(self.exeinpfile) - - self.first_ens_id = int(self.rqdExeInp.get('FIRST_ENS_ID',0)) - self.perturb = int(self.rqdExeInp.get('PERTURBATIONS',0)) - if self.nens > 1: - self.perturb = 1 - self.ensdirs = ['ens%04d'%iens for iens in range(self.first_ens_id, self.nens + self.first_ens_id)] - # if self.ens_id_width = 4, _width = '_e%04d' - _width = '_e%0{}d'.format(self.ens_id_width-2) - # self.ensids will be a list of [_e0000, _e0001, ...] - self.ensids = [ _width%iens for iens in range(self.first_ens_id, self.nens + self.first_ens_id)] - if (self.nens == 1) : - self.ensdirs_avg = self.ensdirs - self.ensids=[''] - else : - self.ensdirs_avg = self.ensdirs + ['ens_avg'] - - ## convert date-time strings to datetime object - ## start/end_time are converted to lists - ## ensure end>start - - self.begDates=[] - self.endDates=[] - self.begDates.append( - datetime.strptime( - self.rqdExeInp['BEG_DATE'], - '%Y%m%d %H%M%S' - ) - ) - self.endDates.append( - datetime.strptime( - self.rqdExeInp['END_DATE'], - '%Y%m%d %H%M%S' - ) - ) - if self.rqdExeInp['RESTART'].isdigit() : - if int(self.rqdExeInp['RESTART']) == 0 : - print ("No restart file (cold restart): Forcing start date to January 1, 0z") - year = self.begDates[0].year - self.begDates[0]=datetime(year =year,month=1,day =1,hour =0, minute= 0,second= 0) - - assert self.endDates[0]>self.begDates[0], \ - 'END_DATE <= BEG_DATE' - - self.job_sgmt = [] - if 'JOB_SGMT' in self.rqdExeInp: - self.job_sgmt.append("JOB_SGMT: "+self.rqdExeInp['JOB_SGMT']) - else: - _datediff = relativedelta(self.endDates[0],self.begDates[0]) - self.rqdExeInp['JOB_SGMT'] = "%04d%02d%02d %02d%02d%02d" %(_datediff.years, - _datediff.months, - _datediff.days, - _datediff.hours, - _datediff.minutes, - _datediff.seconds) - self.job_sgmt.append("JOB_SGMT: "+self.rqdExeInp['JOB_SGMT']) - - if 'NUM_SGMT' not in self.rqdExeInp: - self.rqdExeInp['NUM_SGMT'] = 1 - # hard set NUM_SGMT and NUM_SGMT - if (self.ladas_coupling > 0) : - if int(self.rqdExeInp['NUM_SGMT']) != 1 : - sys.exit("'NUM_SGMT' should be set to 1 with LADAS_COUPLING") - if self.rqdExeInp['JOB_SGMT'] != "00000000 060000" : - sys.exit("'JOB_SGMT' should be set to 00000000 060000 with LADAS_COUPLING") - - _years = int(self.rqdExeInp['JOB_SGMT'][0:4]) - _months = int(self.rqdExeInp['JOB_SGMT'][4:6]) - _days = int(self.rqdExeInp['JOB_SGMT'][6:8]) - assert self.rqdExeInp['JOB_SGMT'][8] == ' ' and self.rqdExeInp['JOB_SGMT'][9] != ' ', "JOB_SGMT format is not right" - _hours = int(self.rqdExeInp['JOB_SGMT'][9:11]) - _mins = int(self.rqdExeInp['JOB_SGMT'][11:13]) - _seconds= int(self.rqdExeInp['JOB_SGMT'][13:15]) - - - _difftime =timedelta(days = _years*365+_months*30+_days,hours = _hours,minutes=_mins,seconds=_seconds) - _difftime = int(self.rqdExeInp['NUM_SGMT'])*_difftime - print (int(self.rqdExeInp['NUM_SGMT'])) - _d = self.begDates[0] - _endDate = self.endDates[0] - _d = _d + _difftime - while _d < _endDate : - print (_difftime.days) - self.nSegments +=1 - print (_d.year, _d.month, _d.day) - self.begDates.append(_d) - self.endDates.insert(-1,_d) - _d = _d+ _difftime - - # make sure path is path - self.bcs_land = self.rqdExeInp['BCS_PATH']+ '/land/' + self.rqdExeInp['BCS_RESOLUTION']+'/' - self.bcs_geom = self.rqdExeInp['BCS_PATH']+ '/geometry/' + self.rqdExeInp['BCS_RESOLUTION']+'/' - self.bcs_landshared = self.rqdExeInp['BCS_PATH']+ '/land/shared/' - - if self.rqdExeInp['MET_PATH'][-1] != '/': - self.rqdExeInp['MET_PATH'] = self.rqdExeInp['MET_PATH']+'/' - if self.rqdExeInp['RESTART_PATH'][-1] != '/': - self.rqdExeInp['RESTART_PATH'] = self.rqdExeInp['RESTART_PATH']+'/' - - # make sure catchment and vegdyn restart files ( at least one for each) exist - if 'CATCH_DEF_FILE' not in self.rqdExeInp: - self.rqdExeInp['CATCH_DEF_FILE']= self.bcs_land + 'clsm/catchment.def' - assert os.path.isfile(self.rqdExeInp['CATCH_DEF_FILE']),"[%s] file does not exist " % self.rqdExeInp['CATCH_DEF_FILE'] - - self.rqdExeInp['RST_FROM_GLOBAL'] = 1 - if self.rqdExeInp['RESTART'].isdigit() : - if int(self.rqdExeInp['RESTART']) == 1 : - _numg = int(linecache.getline(self.rqdExeInp['CATCH_DEF_FILE'], 1).strip()) - _numd = _numg - ldas_domain = self.rqdExeInp['RESTART_PATH']+ \ - self.rqdExeInp['RESTART_ID'] + \ - '/output/'+self.rqdExeInp['RESTART_DOMAIN']+'/rc_out/'+self.rqdExeInp['RESTART_ID']+'.ldas_domain.txt' - if os.path.isfile(ldas_domain) : - _numd = int(linecache.getline(ldas_domain, 1).strip()) - - if _numg != _numd : - self.rqdExeInp['RST_FROM_GLOBAL'] = 0 - - self.rqdExeInp['LNFM_FILE'] = '' - if int(self.rqdExeInp['RST_FROM_GLOBAL']) == 1 : - self.rqdExeInp['TILING_FILE'] =glob.glob(self.bcs_geom + '*.til')[0] - self.rqdExeInp['GRN_FILE']= glob.glob(self.bcs_land + 'green_clim_*.data')[0] - self.rqdExeInp['LAI_FILE']= glob.glob(self.bcs_land + 'lai_clim_*.data')[0] - tmp_ = glob.glob(self.bcs_land + 'lnfm_clim_*.data') - if (len(tmp_) ==1) : - self.rqdExeInp['LNFM_FILE'] = tmp_[0] - self.rqdExeInp['NDVI_FILE'] = glob.glob(self.bcs_land + 'ndvi_clim_*.data')[0] - self.rqdExeInp['NIRDF_FILE']= glob.glob(self.bcs_land + 'nirdf_*.dat')[0] - self.rqdExeInp['VISDF_FILE']= glob.glob(self.bcs_land + 'visdf_*.dat')[0] - else : - inpdir=self.rqdExeInp['RESTART_PATH']+self.rqdExeInp['RESTART_ID']+'/input/' - self.rqdExeInp['TILING_FILE'] =os.path.realpath(glob.glob(inpdir+'*tile.data')[0]) - self.rqdExeInp['GRN_FILE']= os.path.realpath(glob.glob(inpdir+'green*data')[0]) - self.rqdExeInp['LAI_FILE']= os.path.realpath(glob.glob(inpdir+'lai*data')[0]) - tmp_ = glob.glob(self.bcs_land + 'lnfm_clim_*.data') - if (len(tmp_) == 1) : - self.rqdExeInp['LNFM_FILE'] = tmp_[0] - self.rqdExeInp['NDVI_FILE']= os.path.realpath(glob.glob(inpdir+'ndvi*data')[0]) - self.rqdExeInp['NIRDF_FILE']= os.path.realpath(glob.glob(inpdir+'nirdf*data')[0]) - self.rqdExeInp['VISDF_FILE']= os.path.realpath(glob.glob(inpdir+'visdf*data')[0]) - - if self.rqdExeInp['RESTART'].isdigit() : - if int(self.rqdExeInp['RESTART']) == 2 : - self.rqdExeInp['RST_FROM_GLOBAL'] = 1 - ldas_domain = self.rqdExeInp['RESTART_PATH']+ \ - self.rqdExeInp['RESTART_ID'] + \ - '/output/'+self.rqdExeInp['RESTART_DOMAIN']+'/rc_out/'+self.rqdExeInp['RESTART_ID']+'.ldas_domain.txt' - inpdir=self.rqdExeInp['RESTART_PATH']+self.rqdExeInp['RESTART_ID']+'/input/' - in_tilefiles_ = glob.glob(inpdir+'*tile.data') - if len(in_tilefiles_) == 0 : - inpdir=self.rqdExeInp['RESTART_PATH']+self.rqdExeInp['RESTART_ID']+'/output/'+self.rqdExeInp['RESTART_DOMAIN']+'/rc_out/' - in_tilefiles_ = glob.glob(inpdir+'MAPL_*.til') - if len(in_tilefiles_) == 0 : - in_tilefiles_ = glob.glob(inpdir+'/*.til') - self.in_tilefile =os.path.realpath(in_tilefiles_[0]) - - if os.path.isfile(ldas_domain) : - _numd = int(linecache.getline(ldas_domain, 1).strip()) - self.rqdExeInp['TILING_FILE'] =glob.glob(self.bcs_geom + '*.til')[0] - self.rqdExeInp['GRN_FILE']= glob.glob(self.bcs_land + 'green_clim_*.data')[0] - self.rqdExeInp['LAI_FILE']= glob.glob(self.bcs_land + 'lai_clim_*.data')[0] - tmp_ = glob.glob(self.bcs_land + 'lnfm_clim_*.data') - if (len(tmp_) == 1) : - self.rqdExeInp['LNFM_FILE'] = tmp_[0] - self.rqdExeInp['LNFM_FILE'] = glob.glob(self.bcs_land + 'lnfm_clim_*.data')[0] - self.rqdExeInp['NDVI_FILE'] = glob.glob(self.bcs_land + 'ndvi_clim_*.data')[0] - self.rqdExeInp['NIRDF_FILE']= glob.glob(self.bcs_land + 'nirdf_*.dat')[0] - self.rqdExeInp['VISDF_FILE']= glob.glob(self.bcs_land + 'visdf_*.dat')[0] - - if 'GRIDNAME' not in self.rqdExeInp : - tmptile =self.rqdExeInp['TILING_FILE'] - self.rqdExeInp['GRIDNAME'] = linecache.getline(tmptile, 3).strip() - - if 'LSM_CHOICE' not in self.rqdExeInp: - self.rqdExeInp['LSM_CHOICE'] = 1 - - if int(self.rqdExeInp['LSM_CHOICE']) == 1 : - self.catch = 'catch' - if int(self.rqdExeInp['LSM_CHOICE']) == 2 : - self.catch = 'catchcnclm40' - - assert int(self.rqdExeInp['LSM_CHOICE']) <= 2, "\nLSM_CHOICE=3 (Catchment-CN4.5) is no longer supported. Please set LSM_CHOICE to 1 (Catchment) or 2 (Catchment-CN4.0)" - - if 'POSTPROC_HIST' not in self.rqdExeInp: - self.rqdExeInp['POSTPROC_HIST'] = 0 - - if 'LADAS_COUPLING' not in self.rqdExeInp: - self.rqdExeInp['LADAS_COUPLING'] = 0 - - if 'RUN_IRRIG' not in self.rqdExeInp: - self.rqdExeInp['RUN_IRRIG'] = 0 - - if 'AEROSOL_DEPOSITION' not in self.rqdExeInp: - self.rqdExeInp['AEROSOL_DEPOSITION'] = 0 - # default is global - _domain_dic=OrderedDict() - _domain_dic['MINLON']=-180. - _domain_dic['MAXLON']= 180. - _domain_dic['MINLAT']= -90. - _domain_dic['MAXLAT']= 90. - _domain_dic['EXCLUDE_FILE']= "''" - _domain_dic['INCLUDE_FILE']= "''" - - for key,val in _domain_dic.items() : - if key in self.rqdExeInp : - _domain_dic[key]= self.rqdExeInp[key] - self.domain_def = tempfile.NamedTemporaryFile(mode='w', delete=False) - self.domain_def.write('&domain_inputs\n') - for key,val in _domain_dic.items() : - keyn=(key+" = ").ljust(16) - valn = str(val) - if '_FILE' in key: - self.domain_def.write(keyn+ "'"+valn+"'"+'\n') - else : - self.domain_def.write(keyn+ valn +'\n') - self.domain_def.write('/\n') - self.domain_def.close() - - # make sure bcs files exist - if self.rqdExeInp['RESTART'].isdigit() : - if int(self.rqdExeInp['RESTART']) >= 1 : - y4m2='Y%4d/M%02d' % (self.begDates[0].year, self.begDates[0].month) - y4m2d2_h2m2='%4d%02d%02d_%02d%02d' % (self.begDates[0].year, self.begDates[0].month, - self.begDates[0].day,self.begDates[0].hour,self.begDates[0].minute) - tmpFile=self.rqdExeInp['RESTART_ID']+'.'+self.catch+'_internal_rst.'+y4m2d2_h2m2 - tmpRstDir=self.rqdExeInp['RESTART_PATH']+'/'.join([self.rqdExeInp['RESTART_ID'],'output', - self.rqdExeInp['RESTART_DOMAIN'],'rs',self.ensdirs[0],y4m2]) - catchRstFile=tmpRstDir+'/'+tmpFile - - assert os.path.isfile(catchRstFile), self.catch+'_internal_rst file [%s] does not exist!' %(catchRstFile) - self.in_rstfile = catchRstFile - - if int(self.rqdExeInp['RESTART']) == 1 : - tmpFile=self.rqdExeInp['RESTART_ID']+'.vegdyn_internal_rst' - tmpRstDir=self.rqdExeInp['RESTART_PATH']+'/'.join([self.rqdExeInp['RESTART_ID'],'output', - self.rqdExeInp['RESTART_DOMAIN'],'rs',self.ensdirs[0]]) - vegdynRstFile=tmpRstDir+'/'+tmpFile - if not os.path.isfile(vegdynRstFile): - assert int(self.rqdExeInp['RST_FROM_GLOBAL']) == 1, 'restart from LDASsa should be global' - - tmpFile=self.rqdExeInp['RESTART_ID']+'.landpert_internal_rst.'+y4m2d2_h2m2 - tmpRstDir=self.rqdExeInp['RESTART_PATH']+'/'.join([self.rqdExeInp['RESTART_ID'],'output', - self.rqdExeInp['RESTART_DOMAIN'],'rs',self.ensdirs[0],y4m2]) - landpertRstFile=tmpRstDir+'/'+tmpFile - if ( os.path.isfile(landpertRstFile)) : - self.has_geos_pert = True - - elif (int(self.rqdExeInp['RESTART']) == 0) : - if (self.catch == 'catch'): - self.in_rstfile = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding' \ - '/Catch/M09/20170101/catch_internal_rst' - self.in_tilefile = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params' \ - '/mkCatchParam_SMAP_L4SM_v002/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - elif (self.catch == 'catchcnclm40'): - self.in_rstfile = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding' \ - '/CatchCN/M36/20150301_0000/catchcnclm40_internal_dummy' - self.in_tilefile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M36/SMAP_EASEv2_M36_964x406.til' - elif (self.catch == 'catchcnclm45'): - self.in_rstfile = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding' \ - '/CatchCN/M36/19800101_0000/catchcnclm45_internal_dummy' - self.in_tilefile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M36/SMAP_EASEv2_M36_964x406.til' - else: - sys.exit('need to provide at least dummy files') - self.in_rstfile = None - self.in_tilefile = None - - # DEAL WITH mwRTM input from exec - self.assim = True if self.rqdExeInp.get('LAND_ASSIM', 'NO').upper() == 'YES' else False - # verify mwrtm file - if 'MWRTM_PATH' in self.rqdExeInp : - self.rqdExeInp['MWRTM_PATH'] = self.rqdExeInp['MWRTM_PATH']+'/'+ self.rqdExeInp['BCS_RESOLUTION']+'/' - mwrtm_param_file_ = self.rqdExeInp['MWRTM_PATH']+'mwRTM_param.nc4' - vegopacity_file_ = self.rqdExeInp['MWRTM_PATH']+'vegopacity.bin' - if os.path.isfile(mwrtm_param_file_) : - self.has_mwrtm = True - self.mwrtm_file = mwrtm_param_file_ - else : - assert not mwrtm_param_file_.strip(), ' MWRTM_PATH: %s should contain mwRTM_param.nc4'% self.rqdExeInp['MWRTM_PATH'] - del self.rqdExeInp['MWRTM_PATH'] - if os.path.isfile(vegopacity_file_) : - self.has_vegopacity = True - self.rqdExeInp['VEGOPACITY_FILE'] = vegopacity_file_ - - # DEAL WITH optional input from exec - - # ------ - # Read rm input file - # Read (and pop from inpfile) the input required fields in to - # self.rqdRmInp. Fields left in inpDictFromFile are then - # read in to self.optRmInp - # ------ - # re-using inpDictFromFile - - inpDictFromFile = self._parseInputFile(cmdLineArgs['batinpfile']) - - # REQUIRED inputs - for key in rqdRmInpKeys: - self.rqdRmInp[key] = inpDictFromFile.pop(key) - - # checks on rqd rm inputs - ## account and walltime should exist - assert self.rqdRmInp['account'] - if cmdLineArgs['account'] != 'None': - self.rqdRmInp['account'] = cmdLineArgs['account'] - assert self.rqdRmInp['walltime'] - ## ntasks_model is a +ve integer - _ntasks = int(self.rqdRmInp['ntasks_model']) - assert _ntasks>0 - self.rqdRmInp['ntasks_model'] = _ntasks - _ntasks = None - - # print rqd rm inputs - if self.verbose: - print ('\n\nRequired inputs for resource manager:') - _printdict(self.rqdRmInp) - - # OPTIONAL inputs - for key in inpDictFromFile: - assert key in optSlurmInpKeys, \ - 'unknown resource manager key [%s]' % key - self.optRmInp[key] = inpDictFromFile[key] - - # print opt rm inputs - if self.verbose: - print ('\n\nOptional inputs for resource manager:') - _printdict(self.optRmInp) - - # ------ - # set top level directories - # rundir, inpdir, outdir, blddir - # executable - # exefyl - # ------ - - self.bindir = os.path.dirname(os.path.realpath(__file__)) - self.blddir = self.bindir.rsplit('/',1)[0] - exefyl = '/bin/GEOSldas.x' - tmp_execfyl= self.blddir+exefyl - assert os.path.isfile(tmp_execfyl),\ - 'Executable [%s] does not exist!' % tmp_execfyl - tmp_expid = self.rqdExeInp['EXP_ID'] - tmp_expdir = os.path.abspath(self.exphome + '/' + self.rqdExeInp['EXP_ID']) - self.rundir = tmp_expdir + '/run' - self.inpdir = tmp_expdir + '/input' - self.outdir = tmp_expdir + '/output' - self.scratchdir = tmp_expdir + '/scratch' - self.blddirLn = tmp_expdir + '/build' - self.out_path = self.outdir+'/'+self.rqdExeInp['EXP_DOMAIN'] - self.bcsdir = self.outdir+'/'+self.rqdExeInp['EXP_DOMAIN']+'/rc_out/' - self.rstdir = self.outdir+'/'+self.rqdExeInp['EXP_DOMAIN']+'/rs/' - self.exefyl = self.blddirLn+exefyl - - tmp_expid = None - tmp_expdir = None - - my_ntasks_per_node = int(self.rqdRmInp['ntasks-per-node']) - - # default number of nodes - my_nodes = self.rqdRmInp['ntasks_model'] // my_ntasks_per_node - if self.rqdRmInp['ntasks_model'] % my_ntasks_per_node > 0 : - my_nodes = my_nodes + 1 - - # default is set to 0 ( no output server) - if 'oserver_nodes' not in self.optRmInp : - self.optRmInp['oserver_nodes'] = 0 - - self.optRmInp['nodes'] = my_nodes + int(self.optRmInp['oserver_nodes']) - - if (int(self.optRmInp['oserver_nodes']) >=1) : - self.rqdExeInp['WRITE_RESTART_BY_OSERVER'] = "YES" - # set default for now - if 'writers-per-node' not in self.optRmInp: - self.optRmInp['writers-per-node'] = 5 - else: - self.optRmInp['writers-per-node'] = 0 - - - def _parseInputFile(self, inpfile): - """ - Private method: parse input file and return a dict of options - Input: input file - Output: dict - """ - - inpdict = OrderedDict() - errstr = "line [%d] of [%s] is not in the form 'key: value'" - - fin = open(inpfile, 'r') - linenum = 0 - for line in fin: - linenum += 1 - line = line.strip() - # blank line - if not line: - continue - if '"GEOSldas=>"' in line: - continue - # get "GEOSldas=>" default in GEOS_LandGrid.rc - if 'GEOSldas=>' in line: - line = line.split('GEOSldas=>')[1] - # handle comments - position = line.find('#') - if position==0: # comment line - continue - if position>0: # strip out comment - line = line[:position] - # we expect a line to be of the form - # key = value - assert ':' in line, errstr % (linenum, inpfile) - - key, val = line.split(':',1) - key = key.strip() - val = val.strip() - if not key or not val: - print ("WARNING: " + errstr % (linenum, inpfile)) - continue - #raise Exception(errstr % (linenum, inpfile)) - if key in inpdict: - raise Exception('Duplicate key [%s] in [%s]' % (key, inpfile)) - inpdict[key] = val.strip() - fin.close() - - return inpdict - - - def _mkdir_p(self,path): - """ - Private method: implement 'mkdir -p' functionality - """ - - if os.path.isdir(path): - return - else: - os.makedirs(path) - - def createDirStructure(self): - """ - Create required dir structure - """ - - status = False - - # shorthands - _nens = self.nens - - # run/inp/wrk dirs - self._mkdir_p(self.exphome+'/'+self.rqdExeInp['EXP_ID']) - self._mkdir_p(self.rundir) - self._mkdir_p(self.inpdir) - self._mkdir_p(self.outdir) - self._mkdir_p(self.scratchdir) - - #-start-shorthand-function- - def _getDirName(outtyp, ensdir, yyyymm): - return '/'.join([ - self.outdir, - self.rqdExeInp['EXP_DOMAIN'], - outtyp, # ana/cat/rs/rc_out - ensdir, - yyyymm - ]) - #-end-shorthand-function- - - # met forcing dir - myMetDir = self.inpdir + '/met_forcing' - self._mkdir_p(myMetDir) - - # ensxxxx directories - nSegments = self.nSegments - for iseg in range(nSegments): - _start = self.begDates[iseg] - _end = self.endDates[iseg] - - # Yyyyy/Mmm between StartDateTime and EndDateTime - newDate = _start - y4m2_list = [('Y%4d/M%02d' % (newDate.year, newDate.month))] - while newDate<_end: - newDate += relativedelta(months=1) - y4m2_list.append('Y%4d/M%02d' % (newDate.year, newDate.month)) - - # ExpDomain/ana/, /cat/ directories - for ensdir in self.ensdirs_avg: - for y4m2 in y4m2_list: - self._mkdir_p(_getDirName('ana', ensdir, y4m2)) - self._mkdir_p(_getDirName('cat', ensdir, y4m2)) - - # ExpDomain/rs/ directories - for ensdir in self.ensdirs: - for y4m2 in y4m2_list: - self._mkdir_p(_getDirName('rs', ensdir, y4m2)) - - # ExpDomain/rc_out/ - only for _start - self._mkdir_p(_getDirName('rc_out', '', y4m2_list[0])) - - # restart dir - self._mkdir_p(self.inpdir + '/restart') - - status = True - return status - - # create link, BCs , restarts - def createLnRstBc(self) : - # link bld dir - status = False - - _nens = self.nens - - os.symlink(self.blddir, self.blddirLn) - - # met forcing dir - self.ensemble_forcing = True if self.rqdExeInp.get('ENSEMBLE_FORCING', 'NO').upper() == 'YES' else False - - myMetPath ='' - for _i in range(self.first_ens_id, _nens + self.first_ens_id) : - str_ens = '' - if ( _nens != 1 and self.ensemble_forcing): - str_ens = '%03d'%(_i) - metpath = self.rqdExeInp['MET_PATH'].rstrip('/')+str_ens - myMetDir = self.inpdir + '/met_forcing' - myMetPath = myMetDir + '/' + metpath.split('/')[-1] - os.symlink(metpath, myMetPath) - # update 'met_path' to use relative path from outdir - if ( not self.ensemble_forcing): - break - if ( _nens !=1 and self.ensemble_forcing) : - # replace last three character with '%s" - self.rqdExeInp['MET_PATH'] = os.path.relpath(myMetPath, self.rundir)[:-3]+'%s' - else: - self.rqdExeInp['MET_PATH'] = os.path.relpath(myMetPath, self.rundir) - - # update tile file - tile= self.rqdExeInp['TILING_FILE'] - short_tile= os.path.basename(self.rqdExeInp['TILING_FILE']) - newtile = self.bcsdir+'/'+short_tile - shutil.copy(tile, newtile) - tile=newtile - # if three extra lines exist, remove them and save it to inputdir - - print ('\nCorrect the tile file if it is an old EASE tile format... \n') - EASEtile=self.bcsdir+'/MAPL_'+short_tile - cmd = self.bindir + '/preprocess_ldas.x correctease '+ tile + ' '+ EASEtile - if self.BUILT_ON_SLES15 : - print ("Executables were built on SLES15 and must be run on SLES15: " + cmd) - else: - print ("cmd: " + cmd) - - sp.call(shlex.split(cmd)) - - if os.path.isfile(EASEtile) : - #update tile file name - short_tile ='MAPL_'+short_tile - tile=EASEtile - # setup BC files - - catchment_def = self.rqdExeInp['CATCH_DEF_FILE'] - exp_id = self.rqdExeInp['EXP_ID'] - - _start = self.begDates[0] - _y4m2d2h2m2 ='%4d%02d%02d%02d%02d' % (_start.year, _start.month,_start.day,_start.hour,_start.minute) - - dzsf = '50.0' - if 'SURFLAY' in self.rqdExeInp : - dzsf = self.rqdExeInp['SURFLAY'] - - # These are dummy values for *cold* restart: - wemin_in = '13' # WEmin input/output for scale_catch(cn), - wemin_out = '13' # - if 'WEMIN_IN' in self.rqdExeInp : - wemin_in = self.rqdExeInp['WEMIN_IN'] - if 'WEMIN_OUT' in self.rqdExeInp : - wemin_out = self.rqdExeInp['WEMIN_OUT'] - - - tmp_f2g_file = tempfile.NamedTemporaryFile(delete=False) - cmd = self.bindir +'/preprocess_ldas.x c_f2g ' + tile + ' ' + self.domain_def.name + ' '+ self.out_path + ' ' + catchment_def + ' ' + exp_id + ' ' + _y4m2d2h2m2 + ' '+ dzsf + ' ' + tmp_f2g_file.name - - print ('Creating f2g file: '+ tmp_f2g_file.name +'....\n') - print ("cmd: " + cmd) - sp.call(shlex.split(cmd)) - # check if it is local or global - with open(tmp_f2g_file.name) as f2gfile : - head=[next(f2gfile) for x in range(2)] - if(head[0].strip() != head[1].strip()) : - self.islocal= True - #os.remove(self.domain_def.name) - - # update tile domain - if self.islocal: - newlocalTile = tile+'.domain' - print ("\nCreating local tile file :"+ newlocalTile) - print ("\n by excluding land type MAPL_Land_ExcludeFromDomain=1100...\n") - cmd = self.bindir +'/preprocess_ldas.x c_localtile ' + tile + ' ' + newlocalTile + ' '+ tmp_f2g_file.name - print ("cmd: " + cmd) - sp.call(shlex.split(cmd)) - short_tile=short_tile +'.domain' - tile = newlocalTile - - myTile=self.inpdir+'/tile.data' - os.symlink(tile,myTile) - - - bcs=[self.rqdExeInp['GRN_FILE'], - self.rqdExeInp['LAI_FILE'], - self.rqdExeInp['NDVI_FILE'], - self.rqdExeInp['NIRDF_FILE'], - self.rqdExeInp['VISDF_FILE'] ] - if (self.rqdExeInp['LNFM_FILE'] != ''): - bcs += [self.rqdExeInp['LNFM_FILE']] - if (self.has_vegopacity): - bcs += [self.rqdExeInp['VEGOPACITY_FILE']] - bcstmp=[] - for bcf in bcs : - shutil.copy(bcf, self.bcsdir+'/') - bcstmp=bcstmp+[self.bcsdir+'/'+os.path.basename(bcf)] - bcs=bcstmp - - if self.islocal: - print ("Creating the boundary files for the simulation domain...\n") - bcs_tmp=[] - for bcf in bcs : - cmd = self.bindir +'/preprocess_ldas.x c_localbc ' + bcf + ' '+ bcf+'.domain' + ' '+ tmp_f2g_file.name - print ("cmd: " + cmd) - sp.call(shlex.split(cmd)) - bcs_tmp=bcs_tmp+[bcf+'.domain'] - bcs=bcs_tmp - - - # link BC - print ("linking bcs...") - bcnames=['green','lai','ndvi','nirdf','visdf'] - if (self.rqdExeInp['LNFM_FILE'] != ''): - bcnames += ['lnfm'] - if (self.has_vegopacity): - bcnames += ['vegopacity'] - for bcln,bc in zip(bcnames,bcs) : - myBC=self.inpdir+'/'+bcln+'.data' - os.symlink(bc,myBC) - - if ("catchcn" in self.catch): - os.symlink(self.bcs_landshared + 'CO2_MonthlyMean_DiurnalCycle.nc4', \ - self.inpdir+'/CO2_MonthlyMean_DiurnalCycle.nc4') - - # create and link restart - print ("Creating and linking restart...") - _start = self.begDates[0] - - y4m2='Y%4d/M%02d'%(_start.year, _start.month) - y4m2d2_h2m2 ='%4d%02d%02d_%02d%02d' % (_start.year, _start.month,_start.day,_start.hour,_start.minute) - - myRstDir = self.inpdir + '/restart/' - - rstpath = self.rqdExeInp['RESTART_PATH']+ \ - self.rqdExeInp['RESTART_ID'] + \ - '/output/'+self.rqdExeInp['RESTART_DOMAIN']+'/rs/' - rcoutpath = self.rqdExeInp['RESTART_PATH']+ \ - self.rqdExeInp['RESTART_ID'] + \ - '/output/'+self.rqdExeInp['RESTART_DOMAIN']+'/rc_out/' - - # pass into remap_config_ldas - sponsorid = self.rqdRmInp['account'] - exp_id = self.rqdExeInp['EXP_ID'] - exp_dir = self.exphome - out_bcdir = self.rqdExeInp['BCS_PATH'] - out_tilefile = self.rqdExeInp['TILING_FILE'] - RESTART_str = str(self.rqdExeInp['RESTART']) - YYYYMMDD = '%4d%02d%02d' % (_start.year, _start.month,_start.day) - YYYYMMDDHH= '%4d%02d%02d%02d' % (_start.year, _start.month,_start.day, _start.hour) - rstid = self.rqdExeInp['RESTART_ID'] - rstdomain = self.rqdExeInp['RESTART_DOMAIN'] - rstpath0 = self.rqdExeInp['RESTART_PATH'] - - # just copy the landassim pert seed if it exists - for iens in range(self.nens) : - _ensdir = self.ensdirs[iens] - _ensid = self.ensids[iens] - landassim_seeds = rstpath + _ensdir + '/' + y4m2+'/' + rstid + '.landassim_obspertrseed_rst.'+y4m2d2_h2m2 - if os.path.isfile(landassim_seeds) and self.assim : - _seeds = self.rstdir + _ensdir + '/' + y4m2+'/' + exp_id + '.landassim_obspertrseed_rst.'+y4m2d2_h2m2 - shutil.copy(landassim_seeds, _seeds) - os.symlink(_seeds, myRstDir+ '/landassim_obspertrseed'+ _ensid +'_rst') - self.has_landassim_seed = True - mk_outdir = self.exphome+'/'+exp_id+'/mk_restarts/' - - if (RESTART_str != '1'): - bcs_path = self.rqdExeInp['BCS_PATH'] - while bcs_path[-1] == '/' : bcs_path = bcs_path[0:-1] - bc_base = os.path.dirname(bcs_path) - bc_version = os.path.basename(bcs_path) - - remap_tpl = os.path.dirname(os.path.realpath(__file__)) + '/remap_params.tpl' - config = yaml_to_config(remap_tpl) - - config['slurm']['account'] = self.rqdRmInp['account'] - config['slurm']['qos'] = 'debug' - - config['input']['surface']['catch_tilefile'] = self.in_tilefile - config['input']['shared']['expid'] = self.rqdExeInp['RESTART_ID'] - config['input']['shared']['yyyymmddhh'] = YYYYMMDDHH - config['input']['shared']['rst_dir'] = os.path.dirname(self.in_rstfile)+'/' - config['input']['surface']['wemin'] = wemin_in - config['input']['surface']['catch_model'] = self.catch - - config['output']['shared']['out_dir'] = mk_outdir - config['output']['surface']['catch_remap'] = True - config['output']['surface']['catch_tilefile'] = self.rqdExeInp['TILING_FILE'] - config['output']['shared']['bc_base'] = bc_base - config['output']['shared']['bc_version'] = bc_version - config['output']['surface']['EASE_grid'] = self.rqdExeInp['BCS_RESOLUTION'] - - config['output']['shared']['expid'] = self.rqdExeInp['EXP_ID'] - config['output']['surface']['surflay'] = dzsf - config['output']['surface']['wemin'] = wemin_out - - config = remap_config_ldas( config, RESTART_str, self.rqdExeInp['RESTART_PATH'], self.rqdExeInp['RESTART_ID']) - - catch_obj = catchANDcn(config_obj = config) - catch_obj.remap() - - #for ens in self.ensdirs : - catchRstFile0 = '' - vegdynRstFile0 = '' - for iens in range(self.nens) : - ensdir = self.ensdirs[iens] - ensid = self.ensids[iens] - myCatchRst = myRstDir+'/'+self.catch +ensid +'_internal_rst' - myVegRst = myRstDir+'/'+'vegdyn'+ensid +'_internal_rst' - myPertRst = myRstDir+'/'+ 'landpert' +ensid +'_internal_rst' - - catchRstFile = '' - vegdynRstFile = '' - pertRstFile = '' - print ("restart: " + self.rqdExeInp['RESTART']) - - if self.rqdExeInp['RESTART'].isdigit() : - - if int(self.rqdExeInp['RESTART']) == 0 or int(self.rqdExeInp['RESTART']) == 2 : - vegdynRstFile = glob.glob(self.bcs_land + 'vegdyn_*.dat')[0] - catchRstFile = glob.glob(self.exphome+'/'+exp_id+'/mk_restarts/*'+self.catch+'_internal_rst.'+YYYYMMDD+'*')[0] - else : # RESTART == 1 - catchRstFile = rstpath+ensdir +'/'+ y4m2+'/'+self.rqdExeInp['RESTART_ID']+'.'+self.catch+'_internal_rst.'+y4m2d2_h2m2 - vegdynRstFile= rstpath+ensdir +'/'+self.rqdExeInp['RESTART_ID']+ '.vegdyn_internal_rst' - if not os.path.isfile(vegdynRstFile): # no vegdyn restart from LDASsa - if not os.path.isfile(vegdynRstFile0): - vegdynRstFile = glob.glob(self.bcs_land + 'vegdyn_*.dat')[0] - else : - vegdynRstFile = glob.glob(self.bcs_land + 'vegdyn_*.dat')[0] - catchRstFile = glob.glob(self.exphome+'/'+exp_id+'/mk_restarts/*'+self.catch+'_internal_rst.'+YYYYMMDD+'*')[0] - - # catchment restart file - if os.path.isfile(catchRstFile) : - catchLocal = self.rstdir+ensdir +'/'+ y4m2+'/'+self.rqdExeInp['EXP_ID']+'.'+self.catch+'_internal_rst.'+y4m2d2_h2m2 - if self.islocal : - print( "Creating local catchment restart file... \n") - cmd=self.bindir +'/preprocess_ldas.x c_localcatchrst '+ catchRstFile +' ' + catchLocal + ' '+ tmp_f2g_file.name - print ("cmd: "+cmd) - sp.call(shlex.split(cmd)) - else : - shutil.copy(catchRstFile,catchLocal) - - catchRstFile = catchLocal - - if '0000' in ensdir : - catchRstFile0 = catchRstFile - else : # re-use 0000 catch file - catchRstFile = catchRstFile0 - - # vegdyn restart file - if os.path.isfile(vegdynRstFile) : - vegdynLocal = self.rstdir+ensdir +'/'+self.rqdExeInp['EXP_ID']+'.vegdyn_internal_rst' - if self.islocal : - print ("Creating the local veg restart file... \n") - cmd=self.bindir + '/preprocess_ldas.x c_localvegrst '+ vegdynRstFile +' ' + vegdynLocal + ' '+ tmp_f2g_file.name - print ("cmd: " + cmd) - sp.call(shlex.split(cmd)) - else : - shutil.copy(vegdynRstFile,vegdynLocal) - - vegdynRstFile = vegdynLocal - - if '0000' in ensdir : - vegdynRstFile0 = vegdynRstFile - else : - vegdynRstFile = vegdynRstFile0 - - if (self.has_geos_pert and self.perturb == 1) : - pertRstFile = rstpath+ensdir +'/'+ y4m2+'/'+self.rqdExeInp['RESTART_ID']+'.landpert_internal_rst.'+y4m2d2_h2m2 - pertLocal = self.rstdir+ensdir +'/'+ y4m2+'/'+self.rqdExeInp['EXP_ID']+'.landpert_internal_rst.'+y4m2d2_h2m2 - shutil.copy(pertRstFile,pertLocal) - pertRstFile = pertLocal - - print ('catchRstFile: ' + catchRstFile) - print ('vegdynRstFile: ' + vegdynRstFile) - os.symlink(catchRstFile, myCatchRst) - os.symlink(vegdynRstFile, myVegRst) - if ( self.has_geos_pert and self.perturb == 1 ): - os.symlink(pertRstFile, myPertRst) - - # catch_param restar file - catch_param_file = self.bcsdir+'/'+ y4m2+'/'+self.rqdExeInp['EXP_ID']+'.ldas_catparam.'+y4m2d2_h2m2+'z.bin' - assert os.path.isfile(catch_param_file), "need catch_param file %s" % catch_param_file - - if self.has_mwrtm : - mwRTMRstFile = self.mwrtm_file - mwRTMLocal = self.bcsdir+'/'+ y4m2+'/'+self.rqdExeInp['EXP_ID']+'.ldas_mwRTMparam.'+y4m2d2_h2m2+'z.nc4' - if self.islocal : - print ("Creating the local mwRTM restart file... \n") - cmd= self.bindir +'/preprocess_ldas.x c_localmwrtmrst '+ mwRTMRstFile +' ' + mwRTMLocal + ' '+ tmp_f2g_file.name - - print ("cmd: " + cmd) - sp.call(shlex.split(cmd)) - else : - shutil.copy(mwRTMRstFile,mwRTMLocal) - - mwRTMRstFile = mwRTMLocal - mymwRTMRst = myRstDir+'/mwrtm_param_rst' - os.symlink(mwRTMRstFile, mymwRTMRst) - - # update 'restart_path' to use relative path from outdir - print ("Updating restart path...") - self.rqdExeInp['RESTART_PATH'] = myRstDir - #if os.path.isfile(tmp_f2g_file.name): - # os.remove(tmp_f2g_file.name) - status = True - return status - - def createRCFiles(self): - """ - (1) get resource files form DEFAULT rc files from /etc - (2) update from customed rc files - (2) write rc files to the run directory - """ - - status = False - - for mydir in [self.blddirLn, self.rundir]: - assert os.path.isdir(mydir), \ - 'dir [%s] does not exist!' % mydir - - # first copy ldsetup input files to rundir - # if a file w/ the same name already exists at rundir - # append 1,2,3 etc, to the filename - ## exe inp file - exefilename = self.exeinpfile.rstrip('/').split('/')[-1] - newfilename = exefilename - _nens = self.nens - ctr = 0 - while os.path.isfile(self.rundir+'/'+newfilename): - ctr += 1 - newfilename = exefilename + '.%d' % ctr - shutil.copy(self.exeinpfile, self.rundir+'/'+newfilename) - ## bat inp file - batfilename = self.batinpfile.rstrip('/').split('/')[-1] - newfilename = batfilename - ctr = 0 - while os.path.isfile(self.rundir+'/'+newfilename): - ctr += 1 - newfilename = batfilename + '.%d' % ctr - shutil.copy(self.batinpfile, self.rundir+'/'+newfilename) - - etcdir = self.blddirLn + '/etc' - - #defalt nml - default_nml = glob.glob(etcdir+'/LDASsa_DEFAULT_inputs_*.nml') - for nmlfile in default_nml: - shortfile=self.rundir+'/'+nmlfile.split('/')[-1] - shutil.copy2(nmlfile, shortfile) - # special nml - special_nml=[] - if 'NML_INPUT_PATH' in self.rqdExeInp : - special_nml = glob.glob(self.rqdExeInp['NML_INPUT_PATH']+'/LDASsa_SPECIAL_inputs_*.nml') - for nmlfile in special_nml: - shortfile=nmlfile.split('/')[-1] - shutil.copy2(nmlfile, self.rundir+'/'+shortfile) - - # get optimzed NX and IMS - optimized_distribution_file = tempfile.NamedTemporaryFile(delete=False) - print ("Optimizing... decomposition of processes.... \n") - cmd = self.bindir + '/preprocess_ldas.x optimize '+ self.inpdir+'/tile.data '+ str(self.rqdRmInp['ntasks_model']) + ' ' + optimized_distribution_file.name + ' ' + self.rundir - print ("cmd: " + cmd) - print ("IMS.rc or JMS.rc would be generated on " + self.rundir) - sp.call(shlex.split(cmd)) - optinxny=self._parseInputFile(optimized_distribution_file.name) - if (int(optinxny['NX']) == 1): - if int(optinxny['NY']) != int(self.rqdRmInp['ntasks_model']): - self.rqdRmInp['ntasks_model']=optinxny['NY'] - print ('adjust ntasks_model %d for cubed-sphere grid' % int(self.rqdRmInp['ntasks_model'])) - - - #os.remove(optimized_distribution_file.name) - - # DEFAULT rc files - default_rc = glob.glob(etcdir+'/GEOSldas_*.rc') - assert len(default_rc)==4 - print (default_rc) - for rcfile in default_rc: - shortfile=rcfile.rsplit('GEOSldas_',1)[1] - print (shortfile + ' ' + etcdir + ' ' + self.rundir) - if shortfile =='HIST.rc': - tmprcfile=self.rundir+'/HISTORY.rc' - histrc_file=rcfile - - _file_found = False - if 'HISTRC_FILE' in self.rqdExeInp : - _tmpfile = self.rqdExeInp['HISTRC_FILE'].replace("'",'').replace('"','') - if(os.path.isfile(_tmpfile)) : - _file_found = True - else : - assert not _tmpfile.strip(), "HISTRC_FILE: %s is NOT a file. " %_tmpfile - - if _file_found : - histrc_file = self.rqdExeInp['HISTRC_FILE'] - shutil.copy2(histrc_file,tmprcfile) - else : - shutil.copy2(histrc_file,tmprcfile) - GRID='EASE ' + self.rqdExeInp['GRIDNAME'] + ' ' +tmprcfile - if '-CF' in self.rqdExeInp['GRIDNAME'] : - GRID ='CUBE ' + self.rqdExeInp['GRIDNAME'] + ' ' +tmprcfile - _assim = '1' if self.assim else '0' - cmd =self.bindir +'/process_hist.csh '+ str(self.rqdExeInp['LSM_CHOICE']) + ' ' + str(self.rqdExeInp['AEROSOL_DEPOSITION']) + \ - ' ' + GRID + ' ' + str(self.rqdExeInp['RUN_IRRIG']) + ' ' + _assim + ' '+ str(self.nens) - print(cmd) - #os.system(cmd) - sp.call(shlex.split(cmd)) - for line in fileinput.input(tmprcfile,inplace=True): - print (line.rstrip().replace('GEOSldas_expid',self.rqdExeInp['EXP_ID'])) - # just copy an empty ExtData.rc - if shortfile=='ExtData.rc' : - shutil.copy2(rcfile, self.rundir+'/'+shortfile) - - if shortfile == 'CAP.rc': - tmprcfile = self.rundir+'/CAP.rc' - shutil.copy2(rcfile,tmprcfile) - - _num_sgmt = int(self.rqdExeInp['NUM_SGMT']) - - for line in fileinput.input(tmprcfile,inplace=True): - print (line.rstrip().replace('JOB_SGMT:',self.job_sgmt[0])) - for line in fileinput.input(tmprcfile,inplace=True): - print (line.rstrip().replace('NUM_SGMT:','NUM_SGMT: %d'% _num_sgmt)) - for line in fileinput.input(tmprcfile,inplace=True): - print (line.rstrip().replace('BEG_DATE:',self.begDates[0].strftime('BEG_DATE: %Y%m%d %H%M%S'))) - for line in fileinput.input(tmprcfile,inplace=True): - print (line.rstrip().replace('END_DATE:',self.endDates[-1].strftime('END_DATE: %Y%m%d %H%M%S'))) - - if shortfile == 'LDAS.rc' : - ldasrcInp = OrderedDict() - # land default - default_surfrcInp = self._parseInputFile(etcdir+'/GEOS_SurfaceGridComp.rc') - for key,val in default_surfrcInp.items() : - ldasrcInp[key] = val - - # ldas default, may overwrite land default - default_ldasrcInp = self._parseInputFile(rcfile) - for key,val in default_ldasrcInp.items() : - ldasrcInp[key] = val - - # exeinp, may overwrite ldas default - for key,val in self.rqdExeInp.items(): - if key not in self.NoneLDASrcKeys: - ldasrcInp[key]= val - - # overide by optimized distribution - #for key,val in optinxny.items(): - # ldasrcInp[key]= val - - # create BC in rc file - tmpl_ = '' - if self.nens >1 : - tmpl_='%s' - if self.perturb == 1: - ldasrcInp['PERTURBATIONS'] ='1' - bcval=['../input/green','../input/lai','../input/lnfm','../input/ndvi','../input/nirdf','../input/visdf'] - bckey=['GREEN','LAI','LNFM','NDVI','NIRDF','VISDF'] - for key, val in zip(bckey,bcval): - keyn = key+'_FILE' - valn = val+'.data' - ldasrcInp[keyn]= valn - if('catchcn' in self.catch): - ldasrcInp['CO2_MonthlyMean_DiurnalCycle_FILE']= '../input/CO2_MonthlyMean_DiurnalCycle.nc4' - - # create restart item in RC - catch_ = self.catch.upper() - - if catch_+'_INTERNAL_RESTART_TYPE' in ldasrcInp : - # avoid duplicate - del ldasrcInp[ catch_ +'_INTERNAL_RESTART_TYPE'] - if catch_+'_INTERNAL_CHECKPOINT_TYPE' in ldasrcInp : - # avoid duplicate - del ldasrcInp[ catch_ +'_INTERNAL_CHECKPOINT_TYPE'] - if 'VEGDYN_INTERNAL_RESTART_TYPE' in ldasrcInp : - # avoid duplicate - del ldasrcInp['VEGDYN_INTERNAL_RESTART_TYPE'] - - rstkey=[catch_,'VEGDYN'] - rstval=[self.catch,'vegdyn'] - - if self.has_mwrtm : - keyn='LANDASSIM_INTERNAL_RESTART_FILE' - valn='../input/restart/mwrtm_param_rst' - ldasrcInp[keyn]= valn - if self.has_vegopacity : - keyn='VEGOPACITY_FILE' - valn='../input/vegopacity.data' - ldasrcInp[keyn]= valn - - if self.nens > 1 : - keyn='ENS_ID_WIDTH' - valn=str(self.ens_id_width) - ldasrcInp[keyn]= valn - - if self.has_landassim_seed and self.assim : - keyn='LANDASSIM_OBSPERTRSEED_RESTART_FILE' - valn='../input/restart/landassim_obspertrseed'+tmpl_+'_rst' - ldasrcInp[keyn]= valn - - if self.assim: - keyn='LANDASSIM_OBSPERTRSEED_CHECKPOINT_FILE' - valn='landassim_obspertrseed'+tmpl_+'_checkpoint' - ldasrcInp[keyn]= valn - - for key,val in zip(rstkey,rstval) : - keyn = key+ '_INTERNAL_RESTART_FILE' - valn = '../input/restart/'+val+tmpl_+'_internal_rst' - ldasrcInp[keyn]= valn - - # checkpoint file and its type - keyn = catch_ + '_INTERNAL_CHECKPOINT_FILE' - valn = self.catch+tmpl_+'_internal_checkpoint' - ldasrcInp[keyn]= valn - - # specify LANDPERT restart file - if (self.perturb == 1): - keyn = 'LANDPERT_INTERNAL_RESTART_FILE' - valn = '../input/restart/landpert'+tmpl_+'_internal_rst' - ldasrcInp[keyn]= valn - # for lat/lon and EASE tile space, specify LANDPERT checkpoint file here (via MAPL); - # for cube-sphere tile space, Landpert GC will set up LANDPERT checkpoint file - if ('-CF' not in self.rqdExeInp['GRIDNAME']): - keyn = 'LANDPERT_INTERNAL_CHECKPOINT_FILE' - valn = 'landpert'+tmpl_+'_internal_checkpoint' - ldasrcInp[keyn]= valn - - # write LDAS.rc - fout =open(self.rundir+'/'+shortfile,'w') - # ldasrcInp['NUM_LDAS_ENSEMBLE']=ldasrcInp.pop('NUM_ENSEMBLE') - for key,val in optinxny.items(): - keyn=(key+":").ljust(36) - fout.write(keyn+str(val)+'\n') - for key,val in ldasrcInp.items() : - keyn=(key+":").ljust(36) - fout.write(keyn+str(val)+'\n') - fout.write("OUT_PATH:".ljust(36)+self.out_path+'\n') - fout.write("EXP_ID:".ljust(36)+self.rqdExeInp['EXP_ID']+'\n') - fout.write("TILING_FILE:".ljust(36)+"../input/tile.data\n") - - fout.close() - - fout=open(self.rundir+'/'+'cap_restart','w') - #fout.write(self.rqdExeInp['BEG_DATE']) - fout.write(self.begDates[0].strftime('%Y%m%d %H%M%S')) - fout.close() - status=True - return status - - def createBatchRun(self): - """ - """ - - status = False - - os.chdir(self.rundir) - fout =open(self.rundir+'/ldas_batchrun.j','w') - fout.write("#!/bin/bash -f\n") - jobid = None - SBATCHQSUB = 'sbatch' - expid = self.rqdExeInp['EXP_ID'] - if self.GEOS_SITE == 'NAS': - SBATCHQSUB = 'qsub' - fout.write("\nsed -i 's/if($capdate<$enddate) "+SBATCHQSUB+"/#if($capdate<$enddate) "+SBATCHQSUB+"/g' lenkf.j\n\n") - nSegments = self.nSegments - for iseg in range(nSegments): - if iseg ==0 : - fout.write("jobid%d=$(echo $(sbatch lenkf.j) | cut -d' ' -f 4)\n"%(iseg)) - fout.write("echo $jobid%d\n"%iseg ) - else : - _start = self.begDates[iseg] - myDateTime = '%04d%02d%02d_%02d%02dz' % \ - (_start.year, _start.month, _start.day,_start.hour,_start.minute) - _logfile = os.path.relpath( - '/'.join([ - self.outdir, - self.rqdExeInp['EXP_DOMAIN'], - 'rc_out', - 'Y%04d' % _start.year, - 'M%02d' % _start.month, - '.'.join([expid, 'ldas_log', myDateTime, 'txt']), - ]), - self.rundir) - _errfile = os.path.relpath( - '/'.join([ - self.outdir, - self.rqdExeInp['EXP_DOMAIN'], - 'rc_out', - 'Y%04d' % _start.year, - 'M%02d' % _start.month, - '.'.join([expid, 'ldas_err', myDateTime, 'txt']), - ]), - self.rundir) - - #fout.write("jobid%d=$(echo $(sbatch --dependency=afterany:$jobid%d --output=%s --error=%s lenkf.j) | cut -d' ' -f 4)\n"%(iseg,iseg-1,_logfile, _errfile)) - fout.write("jobid%d=$(echo $(sbatch --dependency=afterok:$jobid%d lenkf.j) | cut -d' ' -f 4)\n"%(iseg,iseg-1)) - fout.write("echo $jobid%d\n"%iseg ) - fout.write("\nsed -i 's/#if($capdate<$enddate) "+SBATCHQSUB+"/if($capdate<$enddate) "+SBATCHQSUB+"/g' lenkf.j\n\n") - fout.close() - - sp.call(['chmod', '755', self.rundir+'/ldas_batchrun.j']) - status = True - return status - - - def createRunScripts(self): - """ - """ - - status = False - - os.chdir(self.rundir) - lenkf=self.blddir+'/etc/lenkf.j.template' - shutil.copy(lenkf,'lenkf.j') - - my_qos='allnccs' - if self.GEOS_SITE == 'NAS': my_qos = 'normal' - if 'qos' in self.optRmInp : - my_qos = self.optRmInp['qos'] - - my_job=self.rqdExeInp['EXP_ID'] - if 'job_name' in self.optRmInp : - my_job = self.optRmInp['job_name'] - - start = self.begDates[0] - expid = self.rqdExeInp['EXP_ID'] - myDateTime = '%04d%02d%02d_%02d%02dz' % \ - (start.year, start.month, start.day,start.hour,start.minute) - my_logfile = os.path.relpath( - '/'.join([ - self.outdir, - self.rqdExeInp['EXP_DOMAIN'], - 'rc_out', - 'Y%04d' % start.year, - 'M%02d' % start.month, - '.'.join([expid, 'ldas_log', myDateTime, 'txt']), - ]), - self.rundir) - my_errfile = os.path.relpath( - '/'.join([ - self.outdir, - self.rqdExeInp['EXP_DOMAIN'], - 'rc_out', - 'Y%04d' % start.year, - 'M%02d' % start.month, - '.'.join([expid, 'ldas_err', myDateTime, 'txt']), - ]), - self.rundir) - with open(lenkf,'rt') as fin: - with open('lenkf.j','wt') as fout : - for line in fin : - if self.GEOS_SITE == 'NAS': - if '#SBATCH' in line: - continue - if 'sbatch $HOMDIR/lenkf.j' in line: - continue - - if self.GEOS_SITE == 'NCCS': - if '#PBS' in line: - continue - if 'qsub $HOMDIR/lenkf.j' in line: - continue - - if 'MY_ACCOUNT' in line : - fout.write(line.replace('MY_ACCOUNT',self.rqdRmInp['account'])) - elif 'MY_WALLTIME' in line : - fout.write(line.replace('MY_WALLTIME',self.rqdRmInp['walltime'])) - elif 'MY_NODES' in line : - line_ = line.replace('MY_NODES',str(self.optRmInp['nodes'])) - line_ = line_.replace('MY_NTASKS_PER_NODE',str(self.rqdRmInp['ntasks-per-node'])) - line_ = line_.replace('MY_CONSTRAINT', 'cas_ait') - fout.write(line_) - if self.GEOS_SITE == "NCCS" : - if self.BUILT_ON_SLES15 : - fout.write("#SBATCH --constraint=mil\n") - else: - assert int(self.rqdRmInp['ntasks-per-node']) <= 46, 'ntasks-per-node should be <=46 for cas' - fout.write("#SBATCH --constraint=cas\n") - - elif 'MY_OSERVER_NODES' in line : - fout.write(line.replace('MY_OSERVER_NODES',str(self.optRmInp['oserver_nodes']))) - elif 'MY_WRITERS_NPES' in line : - fout.write(line.replace('MY_WRITERS_NPES', str(self.optRmInp['writers-per-node']))) - elif 'MY_QOS' in line : - if 'allnccs' not in my_qos or 'normal' not in my_qos: - fout.write(line.replace('MY_QOS',my_qos)) - elif 'MY_JOB' in line : - fout.write(line.replace('MY_JOB',my_job)) - elif 'MY_EXPID' in line : - fout.write(line.replace('MY_EXPID',self.rqdExeInp['EXP_ID'])) - elif 'MY_EXPDOMAIN' in line : - fout.write(line.replace('MY_EXPDOMAIN',self.rqdExeInp['EXP_DOMAIN'])) - elif 'MY_LOGFILE' in line : - fout.write(line.replace('MY_LOGFILE',my_logfile)) - elif 'MY_ERRFILE' in line : - fout.write(line.replace('MY_ERRFILE',my_errfile)) - elif 'MY_MODEL' in line : - fout.write(line.replace('MY_MODEL',self.catch)) - elif 'MY_POSTPROC_HIST' in line : - fout.write(line.replace('MY_POSTPROC_HIST',str(self.rqdExeInp['POSTPROC_HIST']))) - elif 'MY_FIRST_ENS_ID' in line : - fout.write(line.replace('MY_FIRST_ENS_ID',str(self.first_ens_id))) - elif 'MY_LADAS_COUPLING' in line : - fout.write(line.replace('MY_LADAS_COUPLING',str(self.ladas_coupling))) - elif 'MY_ENSEMBLE_FORCING' in line : - fout.write(line.replace('MY_ENSEMBLE_FORCING',self.rqdExeInp.get('ENSEMBLE_FORCING', 'NO').upper())) - elif 'MY_ADAS_EXPDIR' in line : - if self.ladas_coupling > 0: - fout.write(line.replace('MY_ADAS_EXPDIR', self.rqdExeInp['ADAS_EXPDIR'])) - else : - my_expdir = self.exphome + '/' + self.rqdExeInp['EXP_ID'] - fout.write(line.replace('MY_EXPDIR',my_expdir)) - - sp.call(['chmod', '755', 'lenkf.j']) - - expdir = '/'.join(self.rundir.rstrip('/').split('/')[:-1]) - print ('\nExperiment directory: %s' % expdir) - print () - status = True - return status - -def _printdict(d): - """ - Private method: print a 'flat' dictionary - """ - - for key, val in d.items(): - print (key.ljust(23), ':', val) - -def _printExeInputKeys(rqdExeInpKeys): - """ - Private method: print sample exe input - """ - - print ('####################################################################################') - print ('# #') - print ('# REQUIRED INPUTS #') - print ('# #') - print ('# These inputs are needed to set up output dir structure. #') - print ('# #') - print ('####################################################################################') - print () - print ('############################################################') - print ('# #') - print ('# EXPERIMENT INFO #') - print ('# #') - print ('# Format for start/end times is yyyymmdd hhmmss. #') - print ('# #') - print ('############################################################') - print () - print ('EXP_ID:') - print ('EXP_DOMAIN:') - print ('NUM_LDAS_ENSEMBLE:') - print ('BEG_DATE:') - print ('END_DATE:') - print () - print ('############################################################') - print ('# #') - print ('# RESTART INFO #') - print ('# #') - print ('# (i) Select "RESTART" option: #') - print ('# #') - print ('# Use one of the following options if you *have* a #') - print ('# GEOSldas restart file: #') - print ('# #') - print ('# RESTART: 1 #') - print ('# YES, have restart file from GEOSldas #') - print ('# in SAME tile space (grid) with SAME boundary #') - print ('# conditions and SAME snow model parameter (WEMIN). #') - print ('# The restart domain can be for the same or #') - print ('# a larger one. #') - print ('# #') - print ('# RESTART: 2 #') - print ('# YES, have restart file from GEOSldas but #') - print ('# in a DIFFERENT tile space (grid) or with #') - print ('# DIFFERENT boundary conditions or DIFFERENT snow #') - print ('# model parameter (WEMIN). #') - print ('# Restart *must* be for the GLOBAL domain. #') - print ('# #') - print ('# Use one of the following options if you DO NOT have a #') - print ('# GEOSldas restart file #') - print ('# (works for global domain ONLY!): #') - print ('# #') - print ('# RESTART: 0 #') - print ('# Cold start from some old restart for Jan 1, 0z. #') - print ('# #') - print ('# RESTART: M #') - print ('# Re-tile from archived MERRA-2 restart file. #') - print ('# #') - print ('# RESTART: F #') - print ('# Re-tile from FP (Forward Processing) restart file. #') - print ('# #') - print ('# RESTART: G #') - print ('# Re-tile from any AGCM catch[cnclmxx]_internal_rst file.#') - print ('# #') - print ('# -------------------------------------------------------- #') - print ('# IMPORTANT: #') - print ('# Except for RESTART=1, SPIN-UP is REQUIRED in almost #') - print ('# all cases. #') - print ('# -------------------------------------------------------- #') - print ('# #') - print ('# #') - print ('# (ii) Specify experiment ID/location of restart file: #') - print ('# #') - print ('# For RESTART=1 or RESTART=2: #') - print ('# Specify RESTART_ID, RESTART_PATH, RESTART_DOMAIN with #') - print ('# restarts stored as follows: #') - print ('# RESTART_PATH/RESTART_ID/output/RESTART_DOMAIN/rs/ #') - print ('# #') - print ('# For RESTART=0 or RESTART=M or RESTART=F: #') - print ('# There is no need to specify RESTART_ID, RESTART_PATH, #') - print ('# and RESTART_DOMAIN. #') - print ('# #') - print ('# For RESTART=G: #') - print ('# RESTART_ID : full_path_to_AGCM_experiment_directory #') - print ('# RESTART_PATH : full_path_of_the_AGCM_restart_file #') - print ('# RESTART_DOMAIN is NOT required. #') - print ('# #') - print ('############################################################') - print () - print ('RESTART:') - print ('#RESTART_ID:') - print ('#RESTART_PATH:') - print ('#RESTART_DOMAIN:') - print () - print ('############################################################') - print ('# #') - print ('# SURFACE METEOROLOGICAL FORCING #') - print ('# #') - print ('# Surface meteorological forcing time step is in seconds. #') - print ('# #') - print ('# For more information, see: #') - print ('# GEOSldas/doc/README.MetForcing_and_BCS.md #') - print ('# #') - print ('############################################################') - print () - print ('MET_TAG:') - print ('MET_PATH:') - print ('FORCE_DTSTEP:') - print () - print ('############################################################') - print ('# #') - print ('# LAND BOUNDARY CONDITIONS (BCS) #') - print ('# #') - print ('# Path to and (atmospheric) resolution of BCS. #') - print ('# #') - print ('# For more information, see: #') - print ('# GEOSldas/doc/README.MetForcing_and_BCS.md #') - print ('# [..]/GEOSsurface_GridComp/Utils/Raster/make_bcs #') - print ('# #') - print ('############################################################') - print () - print ('BCS_PATH:') - print ('BCS_RESOLUTION:') - print () - print ('############################################################') - print ('# #') - print ('# LADAS COUPLING #') - print ('# #') - print ('# Coupling of LDAS to ADAS ("LADAS"): #') - print ('# #') - print ('# 0 -- LDAS not coupled with ADAS (default) #') - print ('# 1 -- LDAS coupled with central member of ADAS #') - print ('# 2 -- LDAS coupled with ens component of ADAS #') - print ('# #') - print ('# Requirements for LADAS_COUPLING > 0: #') - print ('# #') - print ('# (0) Specify ADAS_EXPDIR = [full_path]/[ADAS_EXPID] #') - print ('# #') - print ('# (1) BEG_DATE must be consistent with first cycle date #') - print ('# and time of ADAS experiment (time is typically #') - print ('# 3z, 9z, 15z, or 21z) #') - print ('# #') - print ('# (2) EXP_DOMAIN must be global CS grid as in ADAS exp #') - print ('# #') - print ('# (3) MET_TAG must be set to [ADAS_EXPID]__Nx+- #') - print ('# MET_PATH must be set as follows for #') - print ('# LADAS_COUPLING = 1: #') - print ('# [full_path]/[LDAS_EXPID]/scratch/ #') - print ('# LADAS_COUPLING = 2: #') - print ('# [ADAS_EXPDIR]/atmens/ensdiag/forc #') - print ('# After ldas exp setup, verify the following link: #') - print ('# ../input/met_forcing/forc -> [MET_PATH] #') - print ('# #') - print ('# (4) BCS_PATH must be consistent with that of #') - print ('# [ADAS_EXPDIR][/run/lnbcs #') - print ('# #') - print ('# (5) JOB_SGMT must match ADAS analysis window #') - print ('# (typically 6h) #') - print ('# #') - print ('# (6) NUM_SGMT must be set to 1 #') - print ('# #') - print ('# (7) HISTORY: #') - print ('# - instantaneous "catch_progn_incr" must be in #') - print ('# HISTORY collection #') - print ('# - time step must match that of LDAS analysis #') - print ('# - for LADAS_COUPLING=2, HISTORY must include #') - print ('# "catch_progn_incr[ENS_INDEX]" #') - print ('# #') - print ('############################################################') - print () - print ('LADAS_COUPLING: 0') - print () - print () - - _fn = '../etc/GEOSldas_LDAS.rc' # run ldas_setup from /bin directory - - with open(_fn) as _f: - i_ = 1 - for line in _f: - if ( i_ < 5 or i_ >10): # ignore lines 5-10 - may need to change if GEOSldas_LDAS.rc is edited - sys.stdout.write(line) - sys.stdout.flush() - i_ += 1 - print () - print () - - _fn = '../etc/GEOS_SurfaceGridComp.rc' # run ldas_setup from /bin directory - - with open(_fn) as _f : - i_ = 1 - for line in _f: - if ( 5<=i_ and i_<=21) : # ignore lines 5-21 - may need to change if GEOS_SurfaceGridComp.rc is edited - i_ +=1 - continue - if '"GEOSldas=>"' in line: - sys.stdout.write(line) - elif 'GEOSldas=>' in line: - line0 = line.split("GEOSldas=>")[1] - sys.stdout.write(line0) - elif not line.strip() or line.strip().startswith('#'): - sys.stdout.write(line) - sys.stdout.flush() - i_ += 1 - print () - print () - -def _printRmInputKeys(rqdRmInpKeys, optRmInpKeys): - """ - Private method: print sample resource manager input - """ - - print ('#') - print ('# REQUIRED inputs') - print ('#') - print ('# NOTE:') - print ('# - account = computational project number') - print ('# [At NCCS: Use command "getsponsor" to see available account number(s).]' ) - print ('# - walltime = walltime requested; format is HH:MM:SS (hours/minutes/seconds)') - print ('# - ntasks_model = number of processors requested for the model (typically 112; output server is not included)') - print ('# - ntasks-per-node = number of tasks per node (typically 46 for cascade* and 40 for skylake nodes)') - print ('# [If >40, cascade nodes will be allocated, else cascade or skylake.]') - print ('# [*NCCS recommends <=46 cores per node on SCU16 (cascade) due to OS issues (as of 6 Oct 2021).]') - print ('#') - for key in rqdRmInpKeys: - print (key + ':') - print () - print ('#') - print ('# OPTIONAL inputs') - print ('#') - print ('# NOTE:') - print ('# - job_name = name of experiment; default is "exp_id"') - print ('# - qos = quality-of-service; do not specify by default; specify "debug" for faster but limited service.') - print ('# - oserver_nodes = number of nodes for oserver ( default is 0 )') - print ('# - writers-per-node = tasks per oserver_node for writing ( default is 5 ),') - print ('# IMPORTANT REQUIREMENT: total #writers = writers-per-node * oserver_nodes >= 2') - print ('# Jobs will hang when oserver_nodes = writers-per-node = 1.') - print ('#') - for key in optRmInpKeys: - print ('#'+key + ':') - -def parseCmdLine(): - """ - parse command line arguments and return a dict of options - """ - #print 'in: parseCmdLine' - p = argparse.ArgumentParser( - description= \ - "Script to setup a GEOSldas experiment. The script requires "\ - "two (2) input files, one for the Fortran executable and the " \ - "other for the resource manager (SLURM). For sample input " \ - "files use './ldas_setup sample -h'.", - formatter_class=argparse.ArgumentDefaultsHelpFormatter, - ) - p_sub = p.add_subparsers(help='sub-command help') - - # subparser: sample command - p_sample = p_sub.add_parser( - 'sample', - help='write sample input files', - description='Print sample input files - either for the '\ - 'Fortran executable or the resource manager (SLURM)', - ) - group = p_sample.add_mutually_exclusive_group(required=True) - group.add_argument( - '--exeinp', - help='print sample input file used to generate RC files for GEOSldas App.', - action='store_true', - ) - group.add_argument( - '--batinp', - help='print sample input file for SLURM ', - action='store_true', - ) - # subparser: setup command - p_setup = p_sub.add_parser( - 'setup', - help='setup LDAS experiment', - description="The 'setup' sub-command is used to setup a GEOSldas " \ - "experiment. The positional argument 'exphome' is used to create " \ - "work_path (exphome+/output) and run_path (exphome+/run)." - ) - p_setup.add_argument( - '-v', - '--verbose', - help='verbose output', - action='store_true', - ) - p_setup.add_argument('exphome', help='experiment location') - p_setup.add_argument( - 'exeinpfile', - help='input file with arguments used to generate RC files for GEOSldas App', - ) - p_setup.add_argument( - 'batinpfile', - help='input file with arguments for SLURM', - ) - p_setup.add_argument( - '--account', - help='replace computing/sponsor account in batinp file', - type=str, default='None' - ) - p_setup.add_argument( - '--runmodel', - help='Obsolete.', - action='store_true', - ) - spltgrp = p_setup.add_mutually_exclusive_group() - spltgrp.add_argument( - '--daysperjob', - type=int, - metavar='N', - help='Obsolete. Use NUM_SGMT and JOB_SGMT in exeinp file.', - ) - spltgrp.add_argument( - '--monthsperjob', - type=int, - metavar='N', - help='Obsolete. Use NUM_SGMT and JOB_SGMT in exeinp file.', - ) - - return p.parse_args() - - -if __name__=='__main__': - - resource.setrlimit(resource.RLIMIT_STACK, (resource.RLIM_INFINITY, resource.RLIM_INFINITY)) - #print "reading params...." - args = vars(parseCmdLine()) # vars converts to dict - ld = LDASsetup(args) - - print ("creating dir structure") - status = ld.createDirStructure() - assert(status) - - print ("creating restart and bc") - status = ld.createLnRstBc() - assert(status) - - print ("creating RC Files") - status =ld.createRCFiles() - assert status - - print ("creating gcm style batch Run scripts lenkf.j") - status = ld.createRunScripts() - - print ("creating batch Run scripts") - status = ld.createBatchRun() - assert (status) diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template b/src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template deleted file mode 100644 index 7324b768..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/lenkf.j.template +++ /dev/null @@ -1,849 +0,0 @@ -#!/bin/csh -f - -# GEOSldas job script ("lenkf" = Land Ensemble Kalman Filter) -# -# usage: lenkf.j [-debug] - -####################################################################### -# Batch Parameters for Run Job -####################################################################### - -#SBATCH --output=MY_EXPDIR/scratch/GEOSldas_log_txt -#SBATCH --error=MY_EXPDIR/scratch/GEOSldas_err_txt -#SBATCH --account=MY_ACCOUNT -#SBATCH --time=MY_WALLTIME -#SBATCH --nodes=MY_NODES --ntasks-per-node=MY_NTASKS_PER_NODE -#SBATCH --job-name=MY_JOB -#SBATCH --qos=MY_QOS - -#PBS -l walltime=MY_WALLTIME -#PBS -l select=MY_NODES:ncpus=40:mpiprocs=40:model=MY_CONSTRAINT -#PBS -N MY_JOB -#PBS -q MY_QOS -#PBS -W group_list=MY_ACCOUNT -#PBS -o MY_EXPDIR/scratch/GEOSldas_log_txt -#PBS -e MY_EXPDIR/scratch/GEOSldas_err_txt -#PBS -j oe - -####################################################################### -# System Settings and Architecture Specific Environment Variables -####################################################################### -umask 022 -limit stacksize unlimited -setenv ARCH `uname` - -setenv EXPID MY_EXPID -setenv EXPDOMAIN MY_EXPDOMAIN -setenv EXPDIR MY_EXPDIR -setenv ESMADIR $EXPDIR/build/ -setenv GEOSBIN $ESMADIR/bin/ -# need to unsetenv LD_LIBRARY_PATH for execution of LDAS within the coupled land-atm DAS -unsetenv LD_LIBRARY_PATH - -set debug_flag = 0 -if ( "$1" == "-debug" ) then - set debug_flag = 1 -endif -unset argv -setenv argv - -source $GEOSBIN/g5_modules - -# OPENMPI flags -# Turn off warning about TMPDIR on NFS -setenv OMPI_MCA_shmem_mmap_enable_nfs_warning 0 -# pre-connect MPI procs on mpi_init -setenv OMPI_MCA_mpi_preconnect_all 1 -setenv OMPI_MCA_coll_tuned_bcast_algorithm 7 -setenv OMPI_MCA_coll_tuned_scatter_algorithm 2 -setenv OMPI_MCA_coll_tuned_reduce_scatter_algorithm 3 -setenv OMPI_MCA_coll_tuned_allreduce_algorithm 3 -setenv OMPI_MCA_coll_tuned_allgather_algorithm 4 -setenv OMPI_MCA_coll_tuned_allgatherv_algorithm 3 -setenv OMPI_MCA_coll_tuned_gather_algorithm 1 -setenv OMPI_MCA_coll_tuned_barrier_algorithm 0 -# required for a tuned flag to be effective -setenv OMPI_MCA_coll_tuned_use_dynamic_rules 1 -# disable file locks -setenv OMPI_MCA_sharedfp "^lockedfile,individual" - -# By default, ensure 0-diff across processor architecture by limiting MKL's freedom to pick algorithms. -# As of June 2021, MKL_CBWR=AVX2 is fastest setting that works for both haswell and skylake at NCCS. -# Change to MKL_CBWR=AUTO for fastest execution at the expense of results becoming processor-dependent. -#setenv MKL_CBWR "COMPATIBLE" -#setenv MKL_CBWR "AUTO" -setenv MKL_CBWR "AVX2" - -#setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:${BASEDIR}/${ARCH}/lib -# reversed sequence for LADAS_COUPLING (Sep 2020) (needed when coupling with ADAS using different BASEDIR) -setenv LD_LIBRARY_PATH ${BASEDIR}/${ARCH}/lib:${ESMADIR}/lib:${LD_LIBRARY_PATH} - -module load nco - -setenv RUN_CMD "$GEOSBIN/esma_mpirun -np " - -####################################################################### -# Experiment Specific Environment Variables -####################################################################### - -setenv HOMDIR $EXPDIR/run/ -setenv SCRDIR $EXPDIR/scratch -setenv MODEL MY_MODEL -setenv MYNAME `finger $USER | cut -d: -f3 | head -1` -setenv POSTPROC_HIST MY_POSTPROC_HIST - -# LADAS_COUPLING : 0 -- stand-alone LDAS (no coupling to ADAS) -# : 1 -- LDAS coupled to central (deterministic) component of ADAS -# : 2 -- LDAS coupled to atmospheric ensemble component of ADAS - -setenv LADAS_COUPLING MY_LADAS_COUPLING -setenv ENSEMBLE_FORCING MY_ENSEMBLE_FORCING -setenv ADAS_EXPDIR MY_ADAS_EXPDIR - -set NENS = `grep NUM_LDAS_ENSEMBLE: $HOMDIR/LDAS.rc | cut -d':' -f2` -set END_DATE = `grep END_DATE: $HOMDIR/CAP.rc | cut -d':' -f2` -set NUM_SGMT = `grep NUM_SGMT: $HOMDIR/CAP.rc | cut -d':' -f2` - -####################################################################### -# if LADAS_COUPLING==2, compute ens avg of atmens forcing -####################################################################### - -if ( $LADAS_COUPLING == 2 && $ENSEMBLE_FORCING == "NO" ) then - cd $HOMDIR - set force_in = $ADAS_EXPDIR - set force_out = `grep MET_PATH: $HOMDIR/LDAS.rc | cut -d ':' -f2` - python $GEOSBIN/average_ensemble_forcing.py $force_in $force_out $NENS -endif - -/bin/rm -f $HOMDIR/lenkf_job_completed.txt - -####################################################################### -# Set Experiment Run Parameters -####################################################################### - -####################################################################### -# Move to Scratch Directory and Copy .rc .nml .rst files -####################################################################### - -if (! -e $SCRDIR ) mkdir -p $SCRDIR -cd $SCRDIR -/bin/rm -rf *.* -/bin/cp $HOMDIR/cap_restart . -/bin/cp -f $HOMDIR/*.rc . -/bin/cp -f $HOMDIR/*.nml . - -set LSMCHOICE = `grep -n -m 1 "LSM_CHOICE" $HOMDIR/LDAS.rc | cut -d':' -f3` - -####################################################################### -# if $LADAS_COUPLING == 1: LDAS coupled to central ADAS simulation -####################################################################### - -if ( $LADAS_COUPLING == 1 ) then - - if ( $ENSEMBLE_FORCING == "YES" ) then - - # create perturbed forcing from central simulation and atm ensemble - - # python should come with ESMA_env g5_modules - #module load python/GEOSpyD/Ana2019.03_py3.7 - set forcgrid = `grep GEOSldas.GRIDNAME LDAS.rc | cut -d':' -f2 | awk '{print $1}'` - setenv GRID $forcgrid - $GEOSBIN/enpert_forc.csh - cd $SCRDIR - else - - # move central-simulation forcing held in met_forcing to scratch dir - echo "move lfo_Nx+- met forcing from $EXPDIR/input/met_forcing to $SCRDIR" - /bin/mv $EXPDIR/input/met_forcing/*lfo_Nx+-*nc4 $SCRDIR/. - - endif -endif - -####################################################################### -# Create HISTORY Collection Directories -####################################################################### - -set collections = '' -foreach line ("`cat HISTORY.rc`") - set firstword = `echo $line | awk '{print $1}'` - set firstchar = `echo $firstword | cut -c1` - set secondword = `echo $line | awk '{print $2}'` - - if ( $firstword == "::" ) goto done - - if ( $firstchar != "#" ) then - set collection = `echo $firstword | sed -e "s/'//g"` - set collections = `echo $collections $collection` - if ( $secondword == :: ) goto done - endif - - if ( $firstword == COLLECTIONS: ) then - set collections = `echo $secondword | sed -e "s/'//g"` - endif -end - -done: - -@ n_c = 0 -if ($POSTPROC_HIST > 0) then - foreach ThisCol ($collections) - set ref_t = `cat HISTORY.rc | grep ${ThisCol}.ref_time: | cut -d':' -f2 | cut -d',' -f1` - if ( $ref_t != '000000' ) then - echo ${ThisCol}.ref_time should be '000000' - @ n_c = $n_c + 1 - endif - end -endif -if ($n_c >= 1) then - exit -endif - -####################################################################### -# Domain Decomposition -####################################################################### -set npes_nx = `grep NX: LDAS.rc | cut -d':' -f2 ` -set npes_ny = `grep NY: LDAS.rc | cut -d':' -f2 ` -@ numprocs = $npes_nx * $npes_ny -if( -e IMS.rc ) then - set oldtasks = `head -n 1 IMS.rc` - if($numprocs != $oldtasks) then - $GEOSBIN/preprocess_ldas.x optimize ../input/tile.data $numprocs nothing nothing nothing - endif -endif - -if( -e JMS.rc ) then - set oldtasks = `head -n 1 JMS.rc | cut -c1-5` - if($numprocs != $oldtasks) then - $GEOSBIN/preprocess_ldas.x optimize ../input/tile.data $numprocs nothing nothing nothing - endif -endif - -set gridname = `grep GEOSldas.GRIDNAME LDAS.rc | cut -d':' -f2 | cut -d'-' -f2 | awk '{print $1}'` -if ( "$gridname" == "CF" ) then - set new_ny = `echo "NY: "$numprocs` - sed -i "/NY:/c\\$new_ny" LDAS.rc -else - set new_nx = `echo "NX: "$numprocs` - sed -i "/NX:/c\\$new_nx" LDAS.rc -endif - -####################################################################### -# Create Strip Utility to Remove Multiple Blank Spaces -####################################################################### - -set FILE = strip -/bin/rm $FILE -cat << EOF > $FILE -#!/bin/ksh -/bin/mv \$1 \$1.tmp -touch \$1 -while read line -do -echo \$line >> \$1 -done < \$1.tmp -exit -EOF -chmod +x $FILE - -################################################################## -###### -###### Perform multiple iterations of Model Run -###### -################################################################## - -@ counter = 1 -while ( $counter <= ${NUM_SGMT} ) - - /bin/rm -f EGRESS.ldas - /bin/cp -f $HOMDIR/CAP.rc . - ./strip CAP.rc - - # Set Time Variables for Current_(c), Ending_(e), and Segment_(s) dates - # --------------------------------------------------------------------- - set nymdc = `cat cap_restart | cut -c1-8` - set nhmsc = `cat cap_restart | cut -c10-15` - set nymde = `cat CAP.rc | grep END_DATE: | cut -d: -f2 | cut -c2-9` - set nhmse = `cat CAP.rc | grep END_DATE: | cut -d: -f2 | cut -c11-16` - set nymds = `cat CAP.rc | grep JOB_SGMT: | cut -d: -f2 | cut -c2-9` - set nhmss = `cat CAP.rc | grep JOB_SGMT: | cut -d: -f2 | cut -c11-16` - - # Compute Time Variables at the Finish_(f) of current segment - # ----------------------------------------------------------- - set nyear = `echo $nymds | cut -c1-4` - set nmonth = `echo $nymds | cut -c5-6` - set nday = `echo $nymds | cut -c7-8` - set nhour = `echo $nhmss | cut -c1-2` - set nminute = `echo $nhmss | cut -c3-4` - set nsec = `echo $nhmss | cut -c5-6` - @ dt = $nsec + 60 * $nminute + 3600 * $nhour + 86400 * $nday - - set nymdf = $nymdc - set nhmsf = $nhmsc - set date = `$GEOSBIN/tick $nymdf $nhmsf $dt` - set nymdf = $date[1] - set nhmsf = $date[2] - set year = `echo $nymdf | cut -c1-4` - set month = `echo $nymdf | cut -c5-6` - set day = `echo $nymdf | cut -c7-8` - - @ month = $month + $nmonth - while( $month > 12 ) - @ month = $month - 12 - @ year = $year + 1 - end - @ year = $year + $nyear - @ nymdf = $year * 10000 + $month * 100 + $day - - if( $nymdf > $nymde ) set nymdf = $nymde - if( $nymdf == $nymde ) then - if( $nhmsf > $nhmse ) set nhmsf = $nhmse - endif - - set yearc = `echo $nymdc | cut -c1-4` - set yearf = `echo $nymdf | cut -c1-4` - - # Prescribed LAI/SAI for CATCHCN - # ------------------------------- - - set PRESCRIBE_DVG = `grep PRESCRIBE_DVG LDAS.rc | cut -d':' -f2` - if( ${PRESCRIBE_DVG} == 3 ) then - set FCSTDATE = `grep FCAST_BEGTIME $HOMDIR/LDAS.rc | cut -d':' -f2` - if( `echo $FCSTDATE | cut -d' ' -f1` == "" ) then - set CAPRES = `cat cap_restart` - set CAPRES1 = `echo $CAPRES | cut -d' ' -f1` - set CAPRES2 = `echo $CAPRES | cut -d' ' -f2` - set CAPRES = 'FCAST_BEGTIME: '`echo $CAPRES1``echo $CAPRES2` - echo $CAPRES >> $HOMDIR/LDAS.rc - /bin/cp -p $HOMDIR/LDAS.rc . - endif - endif - - if( ${PRESCRIBE_DVG} >= 1 ) then - - # Modify local CAP.rc Ending date if Finish time exceeds Current year boundary - # ---------------------------------------------------------------------------- - - if( $yearf > $yearc ) then - @ yearf = $yearc + 1 - @ nymdf = $yearf * 10000 + 0101 - set oldstring = `cat CAP.rc | grep END_DATE:` - set newstring = "END_DATE: $nymdf $nhmsf" - /bin/mv CAP.rc CAP.tmp - cat CAP.tmp | sed -e "s?$oldstring?$newstring?g" > CAP.rc - endif - - # Creaate VEGDATA FIle Links - # -------------------------- - - if( ${PRESCRIBE_DVG} == 1 ) set VEGYR = $yearc - if( ${PRESCRIBE_DVG} >= 2 ) set VEGYR = CLIM - - set FILE = vegfile - set nz = 1 - /bin/rm CNLAI* - /bin/rm CNSAI* - - while ( $nz <= 3 ) - set nv = 1 - while ($nv <= 4 ) - /bin/ln -s ../VEGDATA/CNLAI${nv}${nz}_${VEGYR}.data CNLAI${nv}${nz}.data - /bin/ln -s ../VEGDATA/CNSAI${nv}${nz}_${VEGYR}.data CNSAI${nv}${nz}.data - echo "CNLAI${nv}${nz}_FILE: CNLAI${nv}${nz}.data" >> $FILE - echo "CNSAI${nv}${nz}_FILE: CNSAI${nv}${nz}.data" >> $FILE - @ nv++ - end - @ nz++ - end - /bin/mv LDAS.rc LDAS.rc.tmp - cat LDAS.rc.tmp $FILE >> LDAS.rc - /bin/rm LDAS.rc.tmp $FILE - endif - - # ---------------------------------------------------------------------------- - - set bYEAR = `cat cap_restart | cut -c1-4` - set bMON = `cat cap_restart | cut -c5-6` - set bDAY = `cat cap_restart | cut -c7-8` - set bHour = `cat cap_restart | cut -c10-11` - set bMin = `cat cap_restart | cut -c12-13` - - if($counter == 1) then - set logYEAR = $bYEAR - set logMON = $bMON - set logDAY = $bDAY - set logHour = $bHour - set logMin = $bMin - endif - - set old_mwrtm_file = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${bYEAR}/M${bMON}/${EXPID}.ldas_mwRTMparam.${bYEAR}${bMON}${bDAY}_${bHour}${bMin}z.nc4 - set old_catch_param = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${bYEAR}/M${bMON}/${EXPID}.ldas_catparam.${bYEAR}${bMON}${bDAY}_${bHour}${bMin}z.bin - if ( -l "$old_mwrtm_file" ) then - set old_mwrtm_file = `/usr/bin/readlink -f $old_mwrtm_file` - endif - if ( -l "$old_catch_param" ) then - set old_catch_param = `/usr/bin/readlink -f $old_catch_param` - endif - - - /bin/cp LDAS.rc $EXPDIR/output/$EXPDOMAIN/rc_out/Y${bYEAR}/M${bMON}/${EXPID}.ldas_LDAS_rc.${bYEAR}${bMON}${bDAY}_${bHour}${bMin}z.txt - /bin/cp CAP.rc $EXPDIR/output/$EXPDOMAIN/rc_out/Y${bYEAR}/M${bMON}/${EXPID}.ldas_CAP_rc.${bYEAR}${bMON}${bDAY}_${bHour}${bMin}z.txt - - # Run GEOSldas.x - # -------------- - # clean up - $GEOSBIN/RmShmKeys_sshmpi.csh - - # Debugging - # --------- - if ( $debug_flag == 1 ) then - echo "" - echo "------------------------------------------------------------------" - echo "" - echo "lenkf.j -debug:" - echo "" - echo "To start debugging, you must now go to the experiment's scratch directory." - echo "From there, source g5_modules and launch your debugging tool with GEOSldas.x, e.g.," - echo "" - echo " cd $SCRDIR - echo " source $GEOSBIN/g5_modules [for bash or zsh: source g5_modules.[z]sh]" - echo " module load tview [at NCCS] - echo " totalview $GEOSBIN/GEOSldas.x" - echo "" - echo "Availability of tools depends on the computing system and may require" - echo "loading modules. For more information, check with your computing center." - echo "See also GEOSldas Wiki at https://github.com/GEOS-ESM/GEOSldas/wiki" - echo "" - exit - endif - - @ oserver_nodes = MY_OSERVER_NODES - @ writers = MY_WRITERS_NPES - - if (! $?SLURM_NTASKS) then - set total_npes = `wc -l $PBS_NODEFILE | awk '{print $1}'` - else - set total_npes = $SLURM_NTASKS - endif - - if ($oserver_nodes == 0) then - set oserver_options = "" - else - set oserver_options = "--oserver_type multigroup --nodes_output_server $oserver_nodes --npes_backend_pernode $writers" - endif - - $RUN_CMD $total_npes $GEOSBIN/GEOSldas.x --npes_model $numprocs $oserver_options - - if( -e EGRESS.ldas ) then - set rc = 0 - echo GEOSldas Run Status: $rc - else - set rc = -1 - echo GEOSldas Run Status: $rc - echo "ERROR: GEOSldas run FAILED, exit without post-processing" - exit - endif - - - ####################################################################### - # Move Legacy LDASsa Files to ana/ens_avg Directory - ####################################################################### - - # must be done before moving HISTORY files - - set ObsFcses = `ls *.ldas_ObsFcstAna.*.bin` - foreach obsfcs ( $ObsFcses ) - set ThisTime = `echo $obsfcs | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - set THISDIR = $EXPDIR/output/$EXPDOMAIN/ana/ens_avg/Y${TY}/M${TM}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - /bin/mv $obsfcs ${THISDIR}$obsfcs - end - - set smapL4s = `ls *.ldas_tile_inst_smapL4SMaup.*.bin` - foreach smapl4 ( $smapL4s ) - set ThisTime = `echo $smapl4 | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - set THISDIR = $EXPDIR/output/$EXPDOMAIN/ana/ens_avg/Y${TY}/M${TM}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - /bin/mv $smapl4 ${THISDIR}$smapl4 - end - - - ####################################################################### - # Move HISTORY Files to cat/ens Directory - ####################################################################### - - set outfiles = `ls $EXPID.*[bin,nc4]` - set TILECOORD=`ls ../output/*/rc_out/*ldas_tilecoord.bin` - - # Move current files to /cat/ens - # ------------------------------ - - foreach ofile ( $outfiles ) - set ThisTime = `echo $ofile | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - if ($NENS == 1) then - set THISDIR = $EXPDIR/output/$EXPDOMAIN/cat/ens0000/Y${TY}/M${TM}/ - else - set THISDIR = $EXPDIR/output/$EXPDOMAIN/cat/ens_avg/Y${TY}/M${TM}/ - endif - if (! -e $THISDIR ) mkdir -p $THISDIR - - set file_ext = `echo $ofile | rev | cut -d'.' -f1 | rev` - - if($file_ext == nc4) then - /bin/mv $ofile $THISDIR/. - else - set binfile = `echo $ofile | rev | cut -d'.' -f2- | rev` - set decr_file = `echo $ofile | rev | cut -d'.' -f3- | rev`.ctl - ($GEOSBIN/tile_bin2nc4.x $binfile $decr_file $TILECOORD ; \ - /bin/mv ${binfile}.nc4 $THISDIR/. ; \ - /bin/rm ${binfile}.bin) & - endif - end - wait - - ####################################################################### - # Post-Process model diagnostic output - # (1) Concatenate sub-daily files to daily files - # (2) Write monthly means - ####################################################################### - - if ($POSTPROC_HIST > 0) then - - set PWD = `pwd` - - if ($NENS == 1) then - set OUTDIR = $EXPDIR/output/$EXPDOMAIN/cat/ens0000/ - else - set OUTDIR = $EXPDIR/output/$EXPDOMAIN/cat/ens_avg/ - endif - - set MONTHDIRS = `ls -d $OUTDIR/*/*` - - foreach THISMONTH ($MONTHDIRS) - - set MM = `echo $THISMONTH | rev | cut -d'/' -f1 | cut -c1-2 | rev` - set YYYY = `echo $THISMONTH | rev | cut -d'/' -f2 | cut -c1-4 | rev` - set NDAYS = `cal $MM $YYYY | awk 'NF {DAYS = $NF}; END {print DAYS}'` - - cd $THISMONTH - - foreach ThisCol ($collections) - # if monthly exists, move on to the next collection - if (-f $EXPID.${ThisCol}.monthly.$YYYY$MM.nc4) continue - - # create daily and remove the sub-daily - # ------------------------------------------------------------------ - set day=1 - while ($day <= $NDAYS) - if ( $day < 10 ) set DD=0${day} - if ( $day >= 10 ) set DD=${day} - @ day++ - set time_steps = `ls -1 $EXPID.$ThisCol.${YYYY}${MM}${DD}_* | rev | cut -d'.' -f2 | rev` - set LEN_SUB = `echo $#time_steps` - - # no file or just one file? nothing to concatenate, move on to the next collection - if ($LEN_SUB <= 1) continue - - # check if day is complete (get HISTORY time step from first two files) - set hour1 = `echo $time_steps[1] | cut -c10-11` - set min1 = `echo $time_steps[1] | cut -c12-13` - set hour2 = `echo $time_steps[2] | cut -c10-11` - set min2 = `echo $time_steps[2] | cut -c12-13` - @ dt_hist = ($hour2 - $hour1) * 60 + ($min2 - $min1) - @ N_per_day = (24 * 60) / $dt_hist - # not enough sub-daily files? move on to the next collection - if($LEN_SUB < $N_per_day) continue - - set tstep2 = \"`echo $time_steps | sed 's/\ /\","/g'`\" - -# ---------------------------------------------------------------------------- -# -# WARNING: The following block MUST begin in column 1!!! Do NOT indent!!! - -cat << EOF > timestamp.cdl -netcdf timestamp { -dimensions: -time = UNLIMITED ; // (NT currently) -string_length = 14 ; -variables: -char time_stamp (time, string_length) ; - -data: - -time_stamp = -DATAVALUES; -} -EOF - - sed -i -e "s/NT/$LEN_SUB/g" timestamp.cdl - sed -i -e "s/DATAVALUES/$tstep2/g" timestamp.cdl - ncgen -k4 -o timestamp.nc4 timestamp.cdl - ncrcat -h $EXPID.$ThisCol.${YYYY}${MM}${DD}_* ${EXPID}.${ThisCol}.$YYYY$MM$DD.nc4 - ncks -4 -h -v time_stamp timestamp.nc4 -A ${EXPID}.${ThisCol}.$YYYY$MM$DD.nc4 - /bin/rm timestamp.cdl - /bin/rm timestamp.nc4 - # rudimentary check for desired nc4 file; if ok, delete sub-daily files - if ( -f ${EXPID}.${ThisCol}.$YYYY$MM$DD.nc4 ) then - if ( ! -z ${EXPID}.${ThisCol}.$YYYY$MM$DD.nc4 ) then - /bin/rm $EXPID.${ThisCol}.${YYYY}${MM}${DD}_*.nc4 - endif - endif - end # concatenate for each day - - # write monthly mean file and (optionally) remove daily files - # ------------------------------------------------------------------ - - # NOTE: Collections written with daily frequency ("tavg24" and "inst24") have not - # been concatenated into daily files. There are two possibilities for the - # time stamps of files to be averaged: - # *.YYYYMMDD.* daily files from concatenation of sub-daily files - # *.YYYYMMDD_HHMM.* daily (avg or inst) files written directly by HISTORY.rc - - set time_steps = `ls -1 $EXPID.$ThisCol.${YYYY}${MM}??.* | rev | cut -d'.' -f2 | rev` - set time_steps_ = `ls -1 $EXPID.$ThisCol.${YYYY}${MM}??_* | rev | cut -d'.' -f2 | cut -d'_' -f2 | rev` - set LEN = `echo $#time_steps` - set LEN_ = `echo $#time_steps_` - - # check if month is complete - if ($LEN != 0) then - set dayl = `echo $time_steps[$LEN] | cut -c1-8` - set day1 = `echo $time_steps[1] | cut -c1-8` - @ NAVAIL = ($dayl - $day1) + 1 - else if( $LEN_ != 0 ) then - set dayl = `echo $time_steps_[$LEN_] | cut -c1-8` - set day1 = `echo $time_steps_[1] | cut -c1-8` - @ NAVAIL = ($dayl - $day1) + 1 - else - @ NAVAIL = 0 - endif - - # not enough days for monthly mean? move on to the next collection - if($NAVAIL != $NDAYS) continue - - # create monthly-mean nc4 file - ncra -h $EXPID.$ThisCol.${YYYY}${MM}*.nc4 ${EXPID}.${ThisCol}.monthly.$YYYY$MM.nc4 - - if($POSTPROC_HIST == 2) then - # rudimentary check for desired nc4 file; if ok, delete daily files - if ( -f ${EXPID}.${ThisCol}.monthly.$YYYY$MM.nc4 ) then - if ( ! -z ${EXPID}.${ThisCol}.monthly.$YYYY$MM.nc4 ) then - /bin/rm $EXPID.${ThisCol}.${YYYY}${MM}* - endif - endif - continue - endif - - end # each collection - end # each month - cd $PWD - endif # POSTPROC_HIST > 0 - - ####################################################################### - # Rename Final Checkpoints => Restarts for Next Segment and Archive - # Note: cap_restart contains the current NYMD and NHMS - ####################################################################### - - set eYEAR = `cat cap_restart | cut -c1-4` - set eMON = `cat cap_restart | cut -c5-6` - set eDAY = `cat cap_restart | cut -c7-8` - set eHour = `cat cap_restart | cut -c10-11` - set eMin = `cat cap_restart | cut -c12-13` - - # Create rc_out/YYYY/MM - # --------------------- - - set THISDIR = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${eYEAR}/M${eMON}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - - # Move mwrtm and cat_param - - set new_mwrtm_file = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${eYEAR}/M${eMON}/${EXPID}.ldas_mwRTMparam.${eYEAR}${eMON}${eDAY}_${eHour}${eMin}z.nc4 - set new_catch_param = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${eYEAR}/M${eMON}/${EXPID}.ldas_catparam.${eYEAR}${eMON}${eDAY}_${eHour}${eMin}z.bin - - if (-f $old_mwrtm_file) then - if ( -l "$new_mwrtm_file" ) then - /bin/rm -f $new_mwrtm_file - endif - /bin/ln -rs $old_mwrtm_file $new_mwrtm_file - /bin/rm ../input/restart/mwrtm_param_rst - /bin/ln -rs $new_mwrtm_file ../input/restart/mwrtm_param_rst - endif - - if (-f $old_catch_param) then - if ( -l "$new_catch_param" ) then - /bin/rm -f $new_catch_param - endif - /bin/ln -rs $old_catch_param $new_catch_param - endif - - # Move Intermediate Checkpoints to RESTARTS directory - # --------------------------------------------------- - - @ inens = MY_FIRST_ENS_ID - @ enens = $inens + $NENS - while ($inens < $enens) - if ($inens <10) then - set ENSDIR = `echo ens000${inens}` - else if($inens<100) then - set ENSDIR=`echo ens00${inens}` - else if($inens < 1000) then - set ENSDIR =`echo ens0${inens}` - else - set ENSDIR = `echo ens${inens}` - endif - set ENSID = `echo $ENSDIR | cut -c4-7` - set ENSID = _e${ENSID} - if ( $NENS == 1) set ENSID ='' - set THISDIR = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${eYEAR}/M${eMON}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - - set rstf = ${MODEL} - if (-f ${rstf}${ENSID}_internal_checkpoint ) then - set tmp_file = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${eYEAR}/M${eMON}/${EXPID}.${rstf}_internal_rst.${eYEAR}${eMON}${eDAY}_${eHour}${eMin} - /bin/mv ${rstf}${ENSID}_internal_checkpoint $tmp_file - /bin/rm -f $EXPDIR/input/restart/${rstf}${ENSID}_internal_rst - /bin/ln -rs $tmp_file $EXPDIR/input/restart/${rstf}${ENSID}_internal_rst - endif - - set rstf = 'landpert' - if (-f ${rstf}${ENSID}_internal_checkpoint ) then - set tmp_file = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${eYEAR}/M${eMON}/${EXPID}.${rstf}_internal_rst.${eYEAR}${eMON}${eDAY}_${eHour}${eMin} - # copy generic restart file to final location/name but remove lat/lon variables - # (lat/lon variables are not correct when running in EASE-grid tile space) - ncks -4 -O -C -x -v lat,lon ${rstf}${ENSID}_internal_checkpoint $tmp_file - /bin/rm -f ${rstf}${ENSID}_internal_checkpoint - set old_rst = `/usr/bin/readlink -f $EXPDIR/input/restart/${rstf}${ENSID}_internal_rst` - /bin/rm -f $EXPDIR/input/restart/${rstf}${ENSID}_internal_rst - /bin/ln -rs $tmp_file $EXPDIR/input/restart/${rstf}${ENSID}_internal_rst - /usr/bin/gzip $old_rst & - endif - - set rstf = 'landassim_obspertrseed' - if (-f ${rstf}${ENSID}_checkpoint ) then - set tmp_file = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${eYEAR}/M${eMON}/${EXPID}.${rstf}_rst.${eYEAR}${eMON}${eDAY}_${eHour}${eMin} - /bin/mv ${rstf}${ENSID}_checkpoint $tmp_file - /bin/rm -f $EXPDIR/input/restart/${rstf}${ENSID}_rst - /bin/ln -rs $tmp_file $EXPDIR/input/restart/${rstf}${ENSID}_rst - endif - # move intermediate check point files to output/$EXPDOMAIN/rs/$ENSDIR/Yyyyy/Mmm/ directories - # ------------------------------------------------------------------------------------------- - - set rstfiles1 = `ls ${MODEL}${ENSID}_internal_checkpoint.*` - set rstfiles2 = `ls landpert${ENSID}_internal_checkpoint.*` - set rstfiles3 = `ls landassim_obspertrseed${ENSID}_checkpoint.*` - - foreach rfile ( $rstfiles1 ) - set ThisTime = `echo $rfile | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - set THISDIR = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${TY}/M${TM}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - /bin/mv $rfile ${THISDIR}${EXPID}.${MODEL}_internal_rst.${ThisTime}.nc4 - /usr/bin/gzip ${THISDIR}${EXPID}.${MODEL}_internal_rst.${ThisTime}.nc4 & - end - - foreach rfile ( $rstfiles2 ) - set ThisTime = `echo $rfile | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - set THISDIR = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${TY}/M${TM}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - (ncks -4 -O -C -x -v lat,lon $rfile ${THISDIR}${EXPID}.landpert_internal_rst.${ThisTime}.nc4;\ - /usr/bin/gzip ${THISDIR}${EXPID}.landpert_internal_rst.${ThisTime}.nc4; \ - /bin/rm -f $rfile) & - end - - foreach rfile ( $rstfiles3 ) - set ThisTime = `echo $rfile | rev | cut -d'.' -f2 | rev` - set TY = `echo $ThisTime | cut -c1-4` - set TM = `echo $ThisTime | cut -c5-6` - set THISDIR = $EXPDIR/output/$EXPDOMAIN/rs/$ENSDIR/Y${TY}/M${TM}/ - if (! -e $THISDIR ) mkdir -p $THISDIR - /bin/mv $rfile ${THISDIR}${EXPID}.landassim_obspertrseed_rst.${ThisTime}.nc4 - end - - @ inens ++ - end ## end of while ($inens < $NENS) - wait - ##################### - # update cap_restart - # ################## - - set CO2LINE = `grep -n -m 1 "CO2_YEAR" $HOMDIR/LDAS.rc | cut -d':' -f1` - - if ( $CO2LINE >= 1 ) then - - # Update reference year for Carbon Tracker CO2 - ############################################## - - set CO2_BEFORE = `sed -n "${CO2LINE}p;d" LDAS.rc | cut -d':' -f2` - set CAP_BEFORE = `head -1 $HOMDIR/cap_restart | cut -c1-4` - @ DY = $CAP_BEFORE - $CO2_BEFORE - @ CO2_AFTER = `head -1 cap_restart | cut -c1-4` - $DY - set CO2UPDATE = "CO2_YEAR: $CO2_AFTER" - sed -i "${CO2LINE} s|.*|$CO2UPDATE|" LDAS.rc - /bin/rm -f $HOMDIR//LDAS.rc - /bin/cp -p LDAS.rc $HOMDIR/LDAS.rc - endif - - /bin/rm -f $HOMDIR/cap_restart - /bin/cp cap_restart $HOMDIR/cap_restart - - ####################################################################### - # Update Iteration Counter - ####################################################################### - - set enddate = `echo $END_DATE | cut -c1-8` - set endhour = `echo $END_DATE | cut -c10-11` - set capdate = `cat cap_restart | cut -c1-8` - set caphour = `cat cap_restart | cut -c10-11` - - if ( $capdate < $enddate ) then - @ counter = $counter + 1 - else if ( $capdate == $enddate && $caphour < $endhour ) then - @ counter = $counter + 1 - else - @ counter = ${NUM_SGMT} + 1 - endif - -## End of the while ( $counter <= ${NUM_SGMT} ) loop ## -end - -####################################################################### -# Set Next Log and Error Files -####################################################################### - -set logfile = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${logYEAR}/M${logMON}/${EXPID}.ldas_log.${logYEAR}${logMON}${logDAY}_${logHour}${logMin}z.txt -set errfile = $EXPDIR/output/$EXPDOMAIN/rc_out/Y${logYEAR}/M${logMON}/${EXPID}.ldas_err.${logYEAR}${logMON}${logDAY}_${logHour}${logMin}z.txt - -if (-f GEOSldas_log_txt) then - /bin/cp GEOSldas_log_txt $logfile - /bin/rm -f GEOSldas_log_txt -endif - -if(-f GEOSldas_err_txt) then - /bin/cp GEOSldas_err_txt $errfile - /bin/rm -f GEOSldas_err_txt -endif - -####################################################################### -# Re-Submit Job -####################################################################### - -if ( $LADAS_COUPLING > 0 ) then - if ( $rc == 0 ) then - echo 'SUCCEEDED' > $HOMDIR/lenkf_job_completed.txt - endif -else - if ( $rc == 0 ) then - cd $HOMDIR - #don't change below line(not even extra space) - if($capdate<$enddate) sbatch $HOMDIR/lenkf.j - if($capdate<$enddate) qsub $HOMDIR/lenkf.j - endif -endif diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 deleted file mode 100644 index 4d5725e6..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas.F90 +++ /dev/null @@ -1,142 +0,0 @@ - -! how to use : -! ./preprocess_ldas option arg1 arg2 arg3 - -program main - - use preprocess_ldas_routines, ONLY: & - createf2g, & - createLocalTilefile, & - createLocalBC, & - createLocalVegRestart, & - createLocalmwRTMRestart, & - createLocalCatchRestart, & - correctEase, & - convert_pert_rst, & - optimize_latlon - - implicit none - - character(len=20 ) :: option - character(len=512) :: arg1 - character(len=512) :: arg2 - character(len=512) :: arg3 - character(len=512) :: arg4 - character(len=512) :: arg5 - character(len=512) :: arg6 - character(len=512) :: arg7 - character(len=512) :: arg8 - - character(len=512) :: orig_tile - character(len=512) :: new_tile - character(len=512) :: domain_def_file - character(len=512) :: catch_def_file - character(len=512) :: out_path - character(len=512) :: exp_id - character(len=512) :: orig_catch - character(len=512) :: new_rtm - character(len=512) :: orig_rtm - character(len=512) :: new_catch - character(len=512) :: orig_BC - character(len=512) :: new_BC - character(len=512) :: orig_Veg - character(len=512) :: new_veg - character(len=512) :: orig_ease - character(len=512) :: new_ease - character(len=512) :: f2g_file - character(len=12 ) :: ymdhm - character(len=12 ) :: SURFLAY - - call get_command_argument(1,option) - call get_command_argument(2,arg1) - call get_command_argument(3,arg2) - call get_command_argument(4,arg3) - call get_command_argument(5,arg4) - call get_command_argument(6,arg5) - call get_command_argument(7,arg6) - call get_command_argument(8,arg7) - call get_command_argument(9,arg8) - - if( trim(option) == "c_f2g") then - - ! (1) generate 'f2g.txt' - ! (2) generate tile.domain if it is local - - orig_tile = arg1 - domain_def_file = arg2 - out_path = arg3 - catch_def_file = arg4 - exp_id = arg5 - ymdhm = trim(adjustl(arg6)) - SURFLAY = trim(adjustl(arg7)) - f2g_file = arg8 - - call createf2g(orig_tile,domain_def_file,trim(out_path),catch_def_file,trim(exp_id),ymdhm, SURFLAY, f2g_file) - - else if (trim(option) == "c_localtile") then - - orig_tile = arg1 - new_tile = arg2 - f2g_file = arg3 - call createLocalTilefile(f2g_file, orig_tile,new_tile) - - else if (trim(option) == "c_localbc" ) then - - orig_BC = arg1 - new_BC = arg2 - f2g_file = arg3 - - call createLocalBC(f2g_file, orig_BC, new_BC) - - else if (trim(option) == "c_localvegrst") then - - orig_veg = arg1 - new_veg = arg2 - f2g_file = arg3 - - call createLocalVegRestart(f2g_file, orig_veg, new_veg) - - else if (trim(option) == "c_localmwrtmrst") then - - orig_rtm = arg1 - new_rtm = arg2 - f2g_file = arg3 - - call createLocalmwRTMRestart(f2g_file, orig_rtm, new_rtm) - - else if (trim(option) == "c_localcatchrst") then - - orig_catch = arg1 - new_catch = arg2 - f2g_file = arg3 - - call createLocalCatchRestart(f2g_file, orig_catch, new_catch) - - else if (trim(option)=="correctease") then - - orig_ease = arg1 - new_ease = arg2 - - call correctEase(orig_ease,new_ease) - - else if (trim(option)=="c_convert_pert") then - - out_path = arg3 - exp_id = arg4 - - call convert_pert_rst(arg1,arg2, out_path,exp_id) - - else if (trim(option) == "optimize") then - - - call optimize_latlon(arg1,arg2, arg3, arg4) - - else - - print*, " wrong preprocess option:",option - - end if - -end program main - -! ====================== EOF ======================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 deleted file mode 100644 index 4a7e9ec1..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/preprocess_ldas_routines.F90 +++ /dev/null @@ -1,3370 +0,0 @@ - -module preprocess_ldas_routines - - ! collection of subroutines and functions needed for GEOSldas pre-processing - ! - ! The *.F90 module i was created as follows: - ! - ! 1.) git mv preprocess_ldas.F90 preprocess_ldas_routines.F90 (for best possible git diff) - ! 2.) removed main program from file and put into new file preprocess_ldas.F90 - ! 3.) moved additional helper subroutines and functions to here: - ! - LDAS_read_til_file() [from LDAS_TileCoordRoutines.F90] - ! - read_grid_elev() [from LDAS_TileCoordRoutines.F90] - ! - fix_dateline_bug_in_tilecoord() [from LDAS_TileCoordRoutines.F90] - ! - read_catchment_def() [from LDAS_TileCoordRoutines.F90] - ! - is_cat_in_box() [from LDAS_TileCoordRoutines.F90] - ! - domain_setup() [from LDAS_ensdrv_init_routines.F90] - ! - read_exclude_or_includelist() [from LDAS_ensdrv_init_routines.F90] - ! - read_cat_param() [from LDAS_ensdrv_init_routines.F90] - ! - is_in_list() [from LDAS_ensdrv_functions.F90] - ! - is_in_domain() [from LDAS_ensdrv_functions.F90] - ! - word_count() [from LDAS_ensdrv_functions.F90] - ! - open_land_param_file() [from LDAS_ensdrv_functions.F90] - - use netcdf - - use MAPL - - use MAPL_BaseMod, ONLY: & - NTYPS => MAPL_NumVegTypes, & - MAPL_Land - - use MAPL_ConstantsMod, ONLY: & - MAPL_RADIUS ! Earth radius - - use LDAS_ensdrv_Globals, ONLY: & - logit, & - logunit, & - nodata_generic, & - nodata_tol_generic - - use LDAS_TileCoordType, ONLY: & - tile_coord_type, & - grid_def_type, & - operator (==), & - io_grid_def_type - - use LDAS_TileCoordRoutines, ONLY: & - LDAS_create_grid_g, & - get_minExtent_grid, & - io_domain_files - - use nr_ran2_gasdev, ONLY: & - NRANDSEED - - use LDAS_DateTimeMod, ONLY: & - date_time_type - - use force_and_cat_progn_pert_types, ONLY: & - N_progn_pert_max, & - N_force_pert_max - - use catch_types, ONLY: & - cat_param_type - - use catch_constants, ONLY: & - N_gt => CATCH_N_GT - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use gFTL_StringVector - - use pFIO - - implicit none - - private - - public :: createf2g - public :: createLocalTilefile - public :: createLocalBC - public :: createLocalCatchRestart - public :: createLocalVegRestart - public :: createLocalmwRTMRestart - public :: correctEase - public :: optimize_latlon - public :: convert_pert_rst - - character(10), private :: tmpstring10 - character(40), private :: tmpstring40 - - ! Tile type for land that is to be excluded from the simulation domain. - ! (GEOSldas allows for non-global simulations and repeated "zooming" - ! of the domain while MAPL generally assumes a complete (global) tile - ! space. The *_ExcludeFromDomain tile type makes it possible to work - ! with complete (global) tile files (ie, make use of MAPL functionality) - ! and also maintain GEOSldas functionality. - - integer, parameter :: MAPL_Land_ExcludeFromDomain = 1100 - -contains - - ! ******************************************************************** - - subroutine createf2g(orig_tile,domain_def,out_path,catch_def_file,exp_id,ymdhm, SURFLAY, f2g_file) - - implicit none - character(*) :: orig_tile - character(*) :: domain_def - character(*) :: out_path - character(*) :: catch_def_file - character(*) :: exp_id - character(*) :: ymdhm - character(*) :: SURFLAY - character(*) :: f2g_file - - real :: minlon,maxlon,minlat,maxlat - character(len=512):: exclude_file,include_file - character(len=512):: bcs_path - logical :: file_exist - logical :: d_exist,c_exist - - integer :: n - - type(grid_def_type) :: tile_grid_g,tile_grid_d - type(tile_coord_type), dimension(:), pointer :: tile_coord_g => null() - type(tile_coord_type), dimension(:), pointer :: tile_coord_d => null() - integer, dimension(:), pointer :: f2g => null() - integer, dimension(:), pointer :: d2g => null() - integer, dimension(:), pointer :: d2f => null() - integer :: N_catg, N_catd,n1,n2,N_catf - - type(cat_param_type), dimension(:), allocatable :: cp - real :: dzsf - - namelist / domain_inputs / & - minlon, maxlon,minlat,maxlat, & - exclude_file,include_file - - inquire(file=trim(orig_tile),exist=file_exist) - if( .not. file_exist) stop ("original tile file not exist") - - inquire(file=trim(domain_def),exist=d_exist) - if( .not. d_exist) then - print*,"no domain definition file" - endif - - inquire(file=trim(catch_def_file),exist=c_exist) - if( .not. c_exist) then - print*,"no catchment definition file:" , catch_def_file - endif - - - if(d_exist) then - open (10, file=trim(domain_def), delim='apostrophe', action='read', status='old') - read (10, nml= domain_inputs) - close(10) - else - minlon = -180. - maxlon = 180. - minlat = -90. - maxlat = 90. - exclude_file = ' ' - include_file = ' ' - endif - - call LDAS_read_til_file(orig_tile,catch_def_file,tile_grid_g,tile_coord_g,f2g) - - N_catg=size(tile_coord_g) - - ! include and exclude files are absolute - - call domain_setup( & - N_catg, tile_coord_g, & - tile_grid_g, & - ' ', exclude_file, ' ', include_file, & - trim(out_path), 'exp_domain ', trim(exp_id), & - minlon, minlat, maxlon, maxlat, & - N_catd, d2g, tile_coord_d, & - tile_grid_d ) - - allocate(cp(N_catd)) - - read(SURFLAY,*) dzsf - print*, "SURFLAY: ", dzsf - n1 = index(catch_def_file,'/clsm/') - bcs_path(1:n1-1) = catch_def_file(1:n1-1) - call read_cat_param( N_catg, N_catd, d2g, tile_coord_d, dzsf, bcs_path(1:n1-1), bcs_path(1:n1-1),bcs_path(1:n1-1), & - cp ) - call write_cat_param(cp,N_catd) - - allocate(d2f(N_catd)) - d2f = 0 - N_catf = size(f2g) - if( N_catf /= N_catg) then - n = 1 - do n1 = 1,N_catd - do n2 = n, N_catf - if (d2g(n1) == f2g(n2)) then - d2f(n1) = n2 - n = n2+1 - exit - endif - enddo - enddo - if(any(d2f == 0)) stop " Domain includes those excluded tiles" - print*," f2g now is d2f " - else - d2f = d2g - endif - open(40,file=f2g_file,form='formatted',action='write') - write(40,*)N_catf - write(40,*)N_catd - do n=1,N_catd - write(40,*)d2f(n) - enddo - do n=1,N_catd - write(40,*)d2g(n) - enddo - close(40) - if (associated(f2g)) deallocate(f2g) - if (associated(d2g)) deallocate(d2g) - if (associated(d2f)) deallocate(d2f) - - contains - - ! ******************************************************************** - - logical function is_in_list(N_list, list, this_one) - - ! checks whether "this_one" is element of list - - ! reichle, 2 May 2003 - - implicit none - - integer :: N_list, this_one - integer, dimension(N_list) :: list - - integer :: n - - ! ------------------------------------ - - is_in_list = .false. - - do n=1,N_list - - if (list(n)==this_one) then - is_in_list = .true. - exit - end if - end do - - end function is_in_list - - ! ****************************************************************** - - logical function is_in_domain( & - this_cat_exclude, this_cat_include, this_cat_in_box ) - - ! determine whether catchment is in domain - ! - ! The domain is set up using (if present) an "ExcludeList" of catchments - ! to be excluded, an "IncludeList" (if present) of catchments to be included, - ! and the bounding box of a rectangular "zoomed" area (as specified - ! in the "exeinp" file used in ldas_setup). - ! - ! order of precedence: - ! 1. exclude catchments on ExcludeList - ! 2. include catchments on IncludeList or catchments within rectangular domain - ! (i.e., catchments in ExcludeList are *always* excluded) - ! - ! reichle, 7 May 2003 - ! reichle, 9 May 2005 - redesign (no more continents) - ! - ! ---------------------------------------------------------------- - - implicit none - - logical :: this_cat_include, this_cat_exclude, this_cat_in_box - - is_in_domain = .false. - - ! if catchment is NOT in ExcludeList - - if (.not. this_cat_exclude) then - - ! if catchment is within bounding box OR in IncludeList - - if ((this_cat_in_box) .or. (this_cat_include)) then - - is_in_domain = .true. - - end if - end if - - end function is_in_domain - - ! ******************************************************************* - - logical function is_cat_in_box( & - this_minlon, this_minlat, this_maxlon, this_maxlat, & - minlon, minlat, maxlon, maxlat ) - - ! determine whether catchment is within bounding box - reichle, 7 May 2003 - - implicit none - - real :: this_minlon, this_minlat, this_maxlon, this_maxlat - real :: minlon, minlat, maxlon, maxlat - - if ( (this_minlon >= minlon) .and. & - (this_maxlon <= maxlon) .and. & - (this_minlat >= minlat) .and. & - (this_maxlat <= maxlat) ) then - is_cat_in_box = .true. - else - is_cat_in_box = .false. - end if - - end function is_cat_in_box - - ! ******************************************************************** - - subroutine domain_setup( & - N_cat_global, tile_coord_global, & - tile_grid_g, & - exclude_path, exclude_file, include_path, include_file, & - work_path, exp_domain, exp_id, & - minlon, minlat, maxlon, maxlat, & - N_cat_domain, d2g, tile_coord, tile_grid_d ) - - ! Set up modeling domain and determine index vectors mapping from the - ! domain to global catchment space. - ! Determine actual bounding box for domain. - ! Also return tile_coord for domain and tile_grid_d for domain. - ! - ! ----------------------- - ! - ! The domain is set up using (if present) an "ExcludeList" of catchments - ! to be excluded, an "IncludeList" (if present) of catchments to be included, - ! and the bounding box of a rectangular "zoomed" area (as specified - ! in the "exeinp" file used in ldas_setup). - ! - ! order of precedence: - ! 1. exclude catchments in ExcludeList - ! 2. include catchments in IncludeList or catchments within rectangular domain - ! (i.e., catchments in ExcludeList are *always* excluded) - ! - ! input: - ! - ! input/output: - ! tile_grid_g : def of global tile definition grid - ! minlon, maxlon, etc: coordinates of bounding box of domain units as - ! in tile_coord file, that is longitude -180:180, - ! latitude -90:90 - ! - ! output: - ! N_cat_domain = number of catchments in zoomed domain - ! (for which model integration is conducted) - ! d2g = index from domain to global tiles - ! tile_coord_d = tile_coord vector for domain - ! tile_grid_d = def of smallest subgrid of global tile_grid_g that contains - ! all catchments (or tiles) in the domain (tile_grid_d%i_offg, - ! tile_grid_d%j_offg are offsets in indices between tile_grid_g - ! and tile_grid_d) - ! N_catd_cont = number of catchments of (full) domain on each continent - ! - ! - ! - reichle, May 7, 2003 - ! - reichle, Nov 7, 2003 - computation of bounding box of actual domain - ! - reichle, Jul 20, 2004 - fixed initialization of min_min_lon etc - ! - reichle, May 11, 2005 - minor output path changes for redesign - ! - reichle, May 16, 2005 - add output of tile_grid_d - ! - reichle, Aug 18, 2005 - reinstated minlon, maxlon, minlat, maxlat - ! - reichle, Jul 23, 2010 - major overhaul - ! - ! ---------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_cat_global - - type(tile_coord_type), dimension(:), pointer :: tile_coord_global ! input - - type(grid_def_type), intent(in) :: tile_grid_g - - character(*), intent(in) :: exclude_path, include_path - character(*), intent(in) :: exclude_file, include_file - - character(*), intent(in) :: work_path - - character(*), intent(in) :: exp_domain, exp_id - - real, intent(in) :: minlon, minlat ! from nml inputs - real, intent(in) :: maxlon, maxlat ! from nml inputs - - integer, intent(out) :: N_cat_domain - - integer, dimension(:), pointer :: d2g ! output - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! output - - type(grid_def_type), intent(out) :: tile_grid_d - - ! locals - - integer :: n, this_tileid, this_catpfaf, N_exclude, N_include, indomain, rc - - integer, dimension(N_cat_global) :: ExcludeList, IncludeList, tmp_d2g - - real :: this_minlon, this_minlat, this_maxlon, this_maxlat - - logical :: this_cat_exclude, this_cat_include, this_cat_in_box - - integer :: this_i_indg, this_j_indg - - type(grid_def_type) :: tmp_grid_def - logical :: c3_grid - character(512) :: fname - - character(len=*), parameter :: Iam = 'domain_setup' - character(len=400) :: err_msg - - ! ------------------------------------------------------------ - - if (logit) write (logunit,*) 'Setting up domain: ' - if (logit) write (logunit,*) - - ! ------------------------------------------------------------ - ! - ! try reading *domain.txt, *tilecoord.txt, and *tilegrids.txt files - - call io_domain_files( 'r', work_path, exp_id, & - N_cat_domain, d2g, tile_coord, tmp_grid_def, tile_grid_d, rc ) - - if (rc==0) then ! read was successful - - ! minimal consistency check - - if (.not. tile_grid_g==tmp_grid_def) then - err_msg = 'existing domain files inconsistent with ' // & - 'global tile_grid_g from tile_coord_file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - write (logunit,*) 'Domain successfully defined from existing files above.' - write (logunit,*) - - else - - print*, "Creating domain..., reading IncludeList and ExludeList if present..." - ! ------------------------------------------------------------ - ! - ! load ExcludeList: catchments listed in this file will *always* be excluded - - fname = trim(exclude_path) // '/' // trim(exclude_file) - - call read_exclude_or_includelist(N_cat_global, fname, ExcludeList, N_exclude) - - ! load IncludeList: catchments listed in this file will be included - ! (unless excluded via ExcludeList) - - fname = trim(include_path) // '/' // trim(include_file) - - call read_exclude_or_includelist(N_cat_global, fname, IncludeList, N_include) - ! ----------------- - ! - ! find and count catchments that are in the domain - - c3_grid = .false. - if(index(tile_grid_g%gridtype,"c3")/=0) c3_grid = .true. - - indomain = 0 ! initialize - - do n=1,N_cat_global - - this_tileid = tile_coord_global(n)%tile_id - - if( .not. c3_grid) then - this_minlon = tile_coord_global(n)%min_lon - this_minlat = tile_coord_global(n)%min_lat - this_maxlon = tile_coord_global(n)%max_lon - this_maxlat = tile_coord_global(n)%max_lat - else ! c3 grid can straddle the lat-lon - this_minlon = tile_coord_global(n)%com_lon - this_minlat = tile_coord_global(n)%com_lat - this_maxlon = tile_coord_global(n)%com_lon - this_maxlat = tile_coord_global(n)%com_lat - endif - - - this_cat_exclude = is_in_list( N_exclude, ExcludeList(1:N_exclude), this_tileid ) - this_cat_include = is_in_list( N_include, IncludeList(1:N_include), this_tileid ) - - this_cat_in_box = & - is_cat_in_box(this_minlon,this_minlat,this_maxlon,this_maxlat, & - minlon, minlat, maxlon, maxlat ) - - if (is_in_domain( & - this_cat_exclude, this_cat_include, this_cat_in_box )) then - - indomain = indomain + 1 - tmp_d2g(indomain) = n - - end if - - end do - - N_cat_domain = indomain - - if (N_cat_domain .eq. 0) then - err_msg = 'No catchments found in domain' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else - if (logit) then - write (logunit,*) 'Number of catchments in domain = ', N_cat_domain - write (logunit,*) - end if - end if - - ! ------------------------------------------------------------------- - ! - ! assemble d2g, tile_coord, tile_grid_d - - allocate(d2g( N_cat_domain)) - allocate(tile_coord(N_cat_domain)) - - d2g(1:N_cat_domain) = tmp_d2g(1:N_cat_domain) - - tile_coord = tile_coord_global(d2g) - - ! finalize extent of actual domain: - ! determine smallest subgrid of tile_grid_d that contains all - ! catchments/tiles in domain - - tile_grid_d = get_minExtent_grid( N_cat_domain, tile_coord%i_indg, tile_coord%j_indg, & - tile_coord%min_lon, tile_coord%min_lat, tile_coord%max_lon, tile_coord%max_lat, & - tile_grid_g) - - ! output domain files - - tmp_grid_def = tile_grid_g ! cannot use intent(in) tile_grid_g w/ io_domain_files - - call io_domain_files( 'w', work_path, exp_id, & - N_cat_domain, d2g, tile_coord, tmp_grid_def, tile_grid_d, rc ) - - end if ! domain/tilecoord/tilegrids files exist - - ! output extent of domain and tile_grid_d to logunit - - if (logit) write (logunit,*) 'Actual extent of domain grid:' - if (logit) write (logunit,*) 'min lon = ', tile_grid_d%ll_lon - if (logit) write (logunit,*) 'max lon = ', tile_grid_d%ur_lon - if (logit) write (logunit,*) 'min lat = ', tile_grid_d%ll_lat - if (logit) write (logunit,*) 'max lat = ', tile_grid_d%ur_lat - if (logit) write (logunit,*) - - tmpstring40 = 'tile_grid_d' - - if (logit) call io_grid_def_type('w', logunit, tile_grid_d, tmpstring40) - - print*, "Done with " // trim(Iam) - - end subroutine domain_setup - - ! ************************************************************************* - - subroutine read_exclude_or_includelist(N_cat, fname, MyList, N_list) - - ! read numbers/IDs of catchments in MyList (ExcludeList or IncludeList) - ! - ! format of MyList file: ASCII list of tile IDs - ! - ! N_list = number of catchments in MyList - ! - ! reichle, 2 May 2003 - ! - ! -------------------------------------------------------------- - - implicit none - - ! N_cat = max number of catchments allowed in list - ! (use N_cat_global when calling this subroutine) - - integer, intent(in) :: N_cat - character(*), intent(in) :: fname - - integer, intent(out) :: N_list - - integer, dimension(N_cat), intent(out) :: MyList - - ! locals - - integer :: istat, tmpint - - logical :: file_exists - - character(len=*), parameter :: Iam = 'read_exclude_or_includelist' - character(len=400) :: err_msg - - ! ----------------------------------------------------------- - - N_list = 0 - - inquire( file=fname, exist=file_exists) - - if (file_exists) then - - open(10, file=fname, form='formatted', action='read', & - status='old', iostat=istat) - - if (istat==0) then - - if (logit) write (logunit,*) & - 'reading ExcludeList or IncludeList from ', trim(fname) - if (logit) write (logunit,*) - - do - read(10,*,iostat=istat) tmpint - - if (istat==-1) then - if (logit) write (logunit,*) ' found ', N_list, ' catchments on list' - exit - else if (istat/=0) then - err_msg = 'read error other than end-of-file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - else - N_list = N_list+1 - MyList(N_list) = tmpint - end if - - if (N_list>N_cat) then - - write (tmpstring10,*) N_cat - write (tmpstring40,*) N_list - - err_msg = 'N_list=' // trim(tmpstring40) & - // ' > N_cat=' // trim(tmpstring10) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - end do - - close(10,status='keep') - - else - - if (logit) write (logunit,*) & - 'could not open ExcludeList or IncludeList file ', trim(fname) - - end if - - else - - if (logit) write (logunit,*) & - 'ExcludeList or IncludeList file does not exist: ', trim(fname) - - end if - - if (logit) write (logunit,*) - - end subroutine read_exclude_or_includelist - - ! **************************************************************** - - integer function word_count( mystring ) - - ! count number of words in "mystring" (delimited by space) - ! - ! - reichle, 31 Mar 2015 - - implicit none - - character(len=*) :: mystring - - integer :: N_words, N_string, ii - - logical :: current_is_space, next_is_space - - N_words = 0 - - current_is_space = (mystring(1:1)==' ') - - if (.not. current_is_space) N_words = N_words + 1 - - do ii=2,len(mystring) - - next_is_space = (mystring(ii:ii)==' ') - - if (current_is_space .and. .not. next_is_space) N_words = N_words + 1 - - current_is_space = next_is_space - - end do - - word_count = N_words - - end function word_count - - ! *********************************************************************** - - integer function open_land_param_file( unitnumber, formatted_file, is_big_endian, & - N_search_dir, fname, pathname, search_dir, ignore_stop ) - - ! reichle, 13 Dec 2010 - ! reichle, 21 Oct 2011 - added optional output "istat" - ! reichle, 11 Dec 2013 - moved from "clsm_ensdrv_drv_routines.F90" - ! and converted to function - - ! try reading land or mwRTM parameter files from various sub-dirs for - ! compatibility with old and new parameter directory structures - - ! fname = file name (without path) of parameter file - ! pathname = path to parameter file - ! search_dir = vector (length N_search_dir) of subdirectories to search - ! for file fname - - ! ignore_stop = optional input, if present and .true., skip call to "stop_it()" - - implicit none - - integer :: unitnumber, N_search_dir - - logical :: formatted_file - - logical :: is_big_endian - - character(*) :: fname - - character(*) :: pathname - - character(*), dimension(:) :: search_dir - - logical, optional :: ignore_stop - - ! local variables - - character(len=512) :: filename - - integer :: i, istat - - logical :: ignore_stop_tmp - - character(len=*), parameter :: Iam = 'open_land_param_file' - character(len=400) :: err_msg - - ! ------------------------------------------------------------------ - ! - ! try opening file - - do i=1,N_search_dir - - filename = trim(pathname) // '/' // trim(search_dir(i)) // '/' // trim(fname) - - if (formatted_file) then - - open(unitnumber, file=filename, form='formatted', & - action='read', status='old', iostat=istat) - - else - - if (is_big_endian) then - - open(unitnumber, file=filename, form='unformatted', & - convert='big_endian', & - action='read', status='old', iostat=istat) - - else - - open(unitnumber, file=filename, form='unformatted', & - convert='little_endian', & - action='read', status='old', iostat=istat) - - end if - - end if - - if (istat==0) exit ! exit loop when first successful - - end do - - ! report back opened filename or stop (unless requested otherwise) - - if (istat==0) then - - if (logit) write (logunit,'(400A)') 'Reading from: ' // trim(filename) - - else - - if (logit) then - - write (logunit,*) 'Cannot find file ', trim(fname), ' in: ' - - do i=1,N_search_dir - write (logunit,*) trim(pathname) // '/' // trim(search_dir(i)) - end do - - end if - - ! figure out whether to stop - - ignore_stop_tmp = .false. ! default: stop if file not opened successfully - - if (present(ignore_stop)) ignore_stop_tmp = ignore_stop - - if (.not. ignore_stop_tmp) then - err_msg = 'ERROR opening file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - if (logit) write (logunit,*) - - open_land_param_file = istat - - end function open_land_param_file - - ! ***************************************************************************************** - - subroutine read_cat_param( & - N_catg, N_catf, f2g, tile_coord_f, dzsf, veg_path, soil_path, top_path, & - cp ) - - ! Reads soil properties and topographic parameters from global files - ! and extracts data for the (full) domain. - ! - ! Additional parameters are derived from the ones that have been read - ! from files. - ! - ! cp = cat_param_f - ! - ! reichle, 12 May 2003 - ! reichle, 6 Jun 2005 - adapted to read "SiB2_V2" parameters - ! reichle, 5 Apr 2013 - removed alb_param_type fields "sc_albvr", "sc_albnr" - ! reichle, 25 Jul 2013 - removed LAI, GRN, and albedo inputs, renamed subroutine - ! from "read_land_parameters()" to "read_cat_param()" - ! reichle, 16 Nov 2015 - read static (JPL) veg height from boundary condition file - ! reichle, 14 Jul 2020 - work around for new "peat fraction" column in Icarus-NLv4 (ignore for now) - ! - ! ------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_catg, N_catf - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f ! intent(in) - - real, intent(in) :: dzsf - - integer, dimension(N_catf), intent(in) :: f2g - - character(*), intent(in) :: veg_path - character(*), intent(in) :: soil_path - character(*), intent(in) :: top_path - - type(cat_param_type), dimension(N_catf), intent(out) :: cp - - ! local variables - - integer, parameter :: N_search_dir_max = 5 - integer, parameter :: N_col_real_max = 18 ! "v15" soil_param.dat had 22 columns (incl. first 4 columns with integers) - - character( 80) :: fname - character(999) :: tmpstr999 - - character(100), dimension(N_search_dir_max) :: search_dir - - integer :: n, k, m, dummy_int, dummy_int2, istat, N_search_dir, N_col - - integer, dimension(N_catg) :: tmpint, tmpint2, tmptileid - - real, dimension(N_catg,N_col_real_max) :: tmpreal - - real :: dummy_real, dummy_real2, z_in_m, term1, term2 - - logical :: dummy_logical - - character(len=*), parameter :: Iam = 'read_cat_param' - character(len=400) :: err_msg - - real, dimension(NTYPS) :: VGZ2 - - ! legacy vegetation height look-up table (for backward compatibility) - ! - DATA VGZ2 /35.0, 20.0, 17.0, 0.6, 0.5, 0.6/ ! Dorman and Sellers (1989) - - ! --------------------------------------------------------------------- - - if (logit) write (logunit,*) 'reading Catchment model parameters' - if (logit) write (logunit,*) - - ! ----------------------------- - - ! Vegetation class - - if (logit) write (logunit,*) 'Reading vegetation class and, if available, height' - - fname = '/mosaic_veg_typs_fracs' - - N_search_dir = 2 ! specify sub-dirs of veg_path to search for file "fname" - - search_dir(1) = 'clsm' - search_dir(2) = 'VEGETATION-GSWP2' - - ! find out how many columns are in the (formatted) file - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, trim(veg_path), search_dir) - - read(10,'(a)') tmpstr999 ! read first line - - close(10, status='keep') - - ! count words in first line (delimited by space) - - N_col = word_count( tmpstr999 ) - - ! read parameters - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, trim(veg_path), search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - select case (N_col) - - case (6) - - ! legacy vegetation height from look-up table - - if (logit) write (logunit,*) 'Using vegetation height look-up table' - - do n=1,N_catg - - read (10,*) tmptileid(n), dummy_int, tmpint(n) - - end do - - if ( (any(tmpint<1)) .or. (any(tmpint>NTYPS)) ) then - - err_msg = 'veg type (class) exceeds allowed min/max' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - do n=1,N_catg - - tmpreal(n,1) = VGZ2( tmpint(n) ) - - end do - - - case (7,8) - - ! vegetation height from boundary condition file - - if (logit) write (logunit,*) 'reading vegetation height from file' - - do n=1,N_catg - - ! 7-th column contains veg height in m - ! 8-th column contains ASCAT z0 values (IGNORED for now, reichle, 31 Oct 2017) - - read (10,*) tmptileid(n), dummy_int, tmpint(n), & - dummy_int2, dummy_real, dummy_real2, tmpreal(n,1) - - end do - - case default - - err_msg = 'unknown number of columns in ' // trim(fname) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - - do k=1,N_catf - - ! this check works only for "SiB2_V2" and newer versions - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with veg parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - cp(k)%vegcls = tmpint( f2g(k) ) - cp(k)%veghght = tmpreal(f2g(k),1) - - end do - - ! ----------------------------------- - - ! Soil parameters, surface layer time scales, and topographical parameters - - N_search_dir = 2 ! specify sub-dirs of path to search for file "fname" - - search_dir(1) = 'clsm' - search_dir(2) = '.' - - ! --------------------- - ! - ! Soil parameters - - if (logit) write (logunit,*) 'Reading soil parameters' - - fname = '/soil_param.dat' - - ! find out how many columns are in the (formatted) file - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, soil_path, search_dir) - - read(10,'(a)') tmpstr999 ! read first line - - close(10, status='keep') - - ! count words in first line (delimited by space) - - N_col = word_count( tmpstr999 ) - - ! read parameters - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, soil_path, search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - do n=1,N_catg - - ! "SiB2_V2" version - - read (10,*) tmptileid(n), dummy_int, tmpint(n), tmpint2(n), & - (tmpreal(n,m), m=1,N_col-4) - - end do - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - - do k=1,N_catf - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with soil parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - cp(k)%bee = tmpreal(f2g(k),1) - cp(k)%psis = tmpreal(f2g(k),2) - cp(k)%poros = tmpreal(f2g(k),3) - cp(k)%cond = tmpreal(f2g(k),4) - cp(k)%wpwet = tmpreal(f2g(k),5) - cp(k)%dpth = tmpreal(f2g(k),6) - - cp(k)%soilcls30 = tmpint( f2g(k)) - cp(k)%soilcls100 = tmpint2(f2g(k)) - - end do - - ! additional soil parameters from recent versions of "soil_param.dat" - ! (eg. for use in calibration of the microwave radiative transfer model) - ! - reichle, 1 Apr 2015 - - select case (N_col) - - case (19,20) - - ! starting with "v16" (De Lannoy et al., 2014, doi:10.1002/2014MS000330), - ! soil_param.dat has 19 columns - - ! "Icarus-NLv4" has 20 columns (new, last column is peat fraction, ignore for now) - - do k=1,N_catf - - cp(k)%gravel30 = tmpreal(f2g(k), 7) - cp(k)%orgC30 = tmpreal(f2g(k), 8) - cp(k)%orgC = tmpreal(f2g(k), 9) - cp(k)%sand30 = tmpreal(f2g(k),10) - cp(k)%clay30 = tmpreal(f2g(k),11) - cp(k)%sand = tmpreal(f2g(k),12) - cp(k)%clay = tmpreal(f2g(k),13) - cp(k)%wpwet30 = tmpreal(f2g(k),14) - cp(k)%poros30 = tmpreal(f2g(k),15) - - end do - - case default - - do k=1,N_catf - - cp(k)%gravel30 = nodata_generic - cp(k)%orgC30 = nodata_generic - cp(k)%orgC = nodata_generic - cp(k)%sand30 = nodata_generic - cp(k)%clay30 = nodata_generic - cp(k)%sand = nodata_generic - cp(k)%clay = nodata_generic - cp(k)%wpwet30 = nodata_generic - cp(k)%poros30 = nodata_generic - - end do - - end select - - ! ------------------------------------ - - ! Surface layer timescales - - if (logit) write (logunit,*) 'Reading surface layer timescales atau/btau' - - fname = '/tau_param.dat' - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, soil_path, search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - do n=1,N_catg - - read (10,*) tmptileid(n), dummy_int, (tmpreal(n,m), m=1,4) - - end do - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - - do k=1,N_catf - - ! this check works only for "SiB2_V2" version - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with tau parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! select atau and btau depending on surface layer depth - - if (abs(dzsf-20.)<1e-4 ) then ! use atau2, btau2 - - cp(k)%atau = tmpreal(f2g(k),1) - cp(k)%btau = tmpreal(f2g(k),2) - - elseif (abs(dzsf-50.)<1e-4 ) then ! use atau5, btau5 - - cp(k)%atau = tmpreal(f2g(k),3) - cp(k)%btau = tmpreal(f2g(k),4) - - else - - err_msg = 'unknown value for dzsf' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end do - - ! make sure atau and btau are not unphysical - - if (any(cp%atau<=0)) then - err_msg = 'unphysical atau value(s)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - if (any(cp%btau<=0)) then - err_msg = 'unphysical btau value(s)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - - ! ------------------------------------ - - ! Topographical parameters - - if (logit) write (logunit,*) 'Reading topo parameters (ar)' - - fname = '/ar.new' - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, top_path, search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - do n=1,N_catg - - read (10,*) tmptileid(n), dummy_int, (tmpreal(n,m), m=1,12) - - end do - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - - do k=1,N_catf - - ! this check works only for "SiB2_V2" version - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with ar parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - cp(k)%gnu = tmpreal(f2g(k),1) - cp(k)%ars1 = tmpreal(f2g(k),2) - cp(k)%ars2 = tmpreal(f2g(k),3) - cp(k)%ars3 = tmpreal(f2g(k),4) - cp(k)%ara1 = tmpreal(f2g(k),5) - cp(k)%ara2 = tmpreal(f2g(k),6) - cp(k)%ara3 = tmpreal(f2g(k),7) - cp(k)%ara4 = tmpreal(f2g(k),8) - cp(k)%arw1 = tmpreal(f2g(k),9) - cp(k)%arw2 = tmpreal(f2g(k),10) - cp(k)%arw3 = tmpreal(f2g(k),11) - cp(k)%arw4 = tmpreal(f2g(k),12) - - end do - - ! -------------------- - - if (logit) write (logunit,*) 'Reading topo parameters (bf)' - - fname = '/bf.dat' - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, top_path, search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - do n=1,N_catg - - read (10,*) tmptileid(n), dummy_int, (tmpreal(n,m), m=1,4) - - end do - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - - do k=1,N_catf - - ! this check works only for "SiB2_V2" version - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with bf parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! --------- - - if (cp(k)%gnu/=tmpreal(f2g(k),1)) then - err_msg = 'land(): something wrong with gnu' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - cp(k)%bf1 = tmpreal(f2g(k),2) - cp(k)%bf2 = tmpreal(f2g(k),3) - cp(k)%bf3 = tmpreal(f2g(k),4) - - end do - - ! -------------------- - - if (logit) write (logunit,*) 'Reading topo parameters (ts)' - - fname = '/ts.dat' - - istat = open_land_param_file( & - 10, .true., dummy_logical, N_search_dir, fname, top_path, search_dir) - - tmptileid = 0 - - tmpreal = nodata_generic - - do n=1,N_catg - - read (10,*) tmptileid(n), dummy_int, (tmpreal(n,m), m=1,5) - - end do - - close (10,status='keep') - - if (logit) write (logunit,*) 'done reading' - if (logit) write (logunit,*) - do k=1,N_catf - - ! this check works only for "SiB2_V2" version - - if (tile_coord_f(k)%tile_id/=tmptileid(f2g(k))) then - err_msg = 'something wrong with ts parameters' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! ------- - - if (cp(k)%gnu/=tmpreal(f2g(k),1)) then - err_msg = 'land(): something wrong with gnu' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - cp(k)%tsa1 = tmpreal(f2g(k),2) - cp(k)%tsa2 = tmpreal(f2g(k),3) - cp(k)%tsb1 = tmpreal(f2g(k),4) - cp(k)%tsb2 = tmpreal(f2g(k),5) - - end do - - ! --------------------------------------------------------------------- - - if (logit) write (logunit,*) 'computing derived land surface parameters...' - if (logit) write (logunit,*) - - do k=1,N_catf - - ! Three soil depths for soil moisture model: - ! - ! dzsf: surface layer - ! dzrz: root zone -> water capacity of the root zone - ! dzpr: unsaturated zone -> approx depth-to-bedrock - ! - ! NOTE: Units of dz** are [mm] while excess/deficits from catchment() - ! are in SI units (ie kg/m^2) or loosely speaking, in mm of water. - ! In other words, density of water (1000 kg/m^3) is built - ! into dz** (reichle, 5 Feb 04). - - cp(k)%dzsf = dzsf - - cp(k)%dzrz = 1000. - - ! changed re-setting of dzrz back to earlier value because - ! Sarith parameters are in fact consistent that the earlier version - ! reichle, 12 Sep 2007 - ! - ! cp(k)%dzpr = max(1500., cp(k)%dpth) - ! - ! previously, root zone depth ranged from .75m to 1m, which - ! is inconsistent with subroutine catchment(), where root - ! zone depth is hard-wired to 1m, and with the time scale - ! parameters, that have been derived for 1m root zone depth - ! (THE LATTER IS IN FACT *NOT* TRUE - reichle, 12 Sep 2007) - ! - reichle, 30 May 2003 - - cp(k)%dzpr = max(1000., cp(k)%dpth) - - if (cp(k)%dzrz > 0.75*cp(k)%dzpr) cp(k)%dzrz = 0.75*cp(k)%dzpr - - ! soil storages - - cp(k)%vgwmax = cp(k)%poros*cp(k)%dzrz - - z_in_m = cp(k)%dzpr/1000. - - term1 = -1.+((cp(k)%psis-z_in_m)/cp(k)%psis)**((cp(k)%bee-1.)/cp(k)%bee) - - term2 = cp(k)%psis*cp(k)%bee/(cp(k)%bee-1) - - cp(k)%cdcr1 = 1000.*cp(k)%poros*(z_in_m-(-term2*term1)) - - cp(k)%cdcr2 = (1.-cp(k)%wpwet)*cp(k)%poros*cp(k)%dzpr - - ! soil depths for ground temperature model - - if (N_gt/=6) then - - write (tmpstring10,*) N_gt - - err_msg = 'using N_gt = ' // trim(tmpstring10) // & - 'but only 6 layer depths are specified.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - cp(k)%dzgt(1) = 0.0988 - cp(k)%dzgt(2) = 0.1952 - cp(k)%dzgt(3) = 0.3859 - cp(k)%dzgt(4) = 0.7626 - cp(k)%dzgt(5) = 1.5071 - cp(k)%dzgt(6) = 10.0000 - - end do - - end subroutine read_cat_param - - ! ********************************************************************************** - - subroutine write_cat_param(cat_param, N_catd) - type(cat_param_type), intent(in) :: cat_param(:) - integer,intent(in) :: N_catd - character(len=512):: fname - type(date_time_type) :: start_time - - integer :: k,n - - read(ymdhm(1:4),*) start_time%year ! 4-digit year - read(ymdhm(5:6),*) start_time%month ! month in year - read(ymdhm(7:8),*) start_time%day ! day in month - read(ymdhm(9:10),*) start_time%hour ! hour of day - read(ymdhm(11:12),*) start_time%min - start_time%sec = 0 - start_time%pentad = -9999 ! pentad of year - start_time%dofyr = -9999 - - fname = get_io_filename(trim(out_path), trim(exp_id),'ldas_catparam', date_time=start_time, & - dir_name='rc_out', file_ext='.bin') - - open(10, file=trim(fname), form='unformatted', status='unknown', action='write') - - print*, 'Writing catparam file : ' // trim(fname) - - write (10) (cat_param(n)%dpth, n=1,N_catd) - - write (10) (cat_param(n)%dzsf, n=1,N_catd) - write (10) (cat_param(n)%dzrz, n=1,N_catd) - write (10) (cat_param(n)%dzpr, n=1,N_catd) - - do k=1,N_gt - write (10) (cat_param(n)%dzgt(k), n=1,N_catd) - end do - - write (10) (cat_param(n)%poros, n=1,N_catd) - write (10) (cat_param(n)%cond, n=1,N_catd) - write (10) (cat_param(n)%psis, n=1,N_catd) - write (10) (cat_param(n)%bee, n=1,N_catd) - - write (10) (cat_param(n)%wpwet, n=1,N_catd) - - write (10) (cat_param(n)%gnu, n=1,N_catd) - - write (10) (cat_param(n)%vgwmax, n=1,N_catd) - - write (10) (real(cat_param(n)%vegcls), n=1,N_catd) - write (10) (real(cat_param(n)%soilcls30), n=1,N_catd) - write (10) (real(cat_param(n)%soilcls100), n=1,N_catd) - - write (10) (cat_param(n)%bf1, n=1,N_catd) - write (10) (cat_param(n)%bf2, n=1,N_catd) - write (10) (cat_param(n)%bf3, n=1,N_catd) - write (10) (cat_param(n)%cdcr1, n=1,N_catd) - write (10) (cat_param(n)%cdcr2, n=1,N_catd) - write (10) (cat_param(n)%ars1, n=1,N_catd) - write (10) (cat_param(n)%ars2, n=1,N_catd) - write (10) (cat_param(n)%ars3, n=1,N_catd) - write (10) (cat_param(n)%ara1, n=1,N_catd) - write (10) (cat_param(n)%ara2, n=1,N_catd) - write (10) (cat_param(n)%ara3, n=1,N_catd) - write (10) (cat_param(n)%ara4, n=1,N_catd) - write (10) (cat_param(n)%arw1, n=1,N_catd) - write (10) (cat_param(n)%arw2, n=1,N_catd) - write (10) (cat_param(n)%arw3, n=1,N_catd) - write (10) (cat_param(n)%arw4, n=1,N_catd) - write (10) (cat_param(n)%tsa1, n=1,N_catd) - write (10) (cat_param(n)%tsa2, n=1,N_catd) - write (10) (cat_param(n)%tsb1, n=1,N_catd) - write (10) (cat_param(n)%tsb2, n=1,N_catd) - write (10) (cat_param(n)%atau, n=1,N_catd) - write (10) (cat_param(n)%btau, n=1,N_catd) - - write (10) (cat_param(n)%gravel30, n=1,N_catd) - write (10) (cat_param(n)%orgC30 , n=1,N_catd) - write (10) (cat_param(n)%orgC , n=1,N_catd) - write (10) (cat_param(n)%sand30 , n=1,N_catd) - write (10) (cat_param(n)%clay30 , n=1,N_catd) - write (10) (cat_param(n)%sand , n=1,N_catd) - write (10) (cat_param(n)%clay , n=1,N_catd) - write (10) (cat_param(n)%wpwet30 , n=1,N_catd) - write (10) (cat_param(n)%poros30 , n=1,N_catd) - - write (10) (cat_param(n)%veghght , n=1,N_catd) - - close (10,status='keep') - - end subroutine write_cat_param - - end subroutine createf2g - - ! ******************************************************************** - - subroutine readsize(f2g_file, N_catg,N_catf) - - implicit none - character(*), intent(in):: f2g_file - integer,intent(out) :: N_catg - integer,intent(out) :: N_catf - - logical :: file_exist - - inquire(file=f2g_file,exist=file_exist) - if(file_exist) then - open(40,file= f2g_file,form='formatted',action='read',status='old') - read(40,*)N_catg - read(40,*)N_catf - close(40) - else - print*, " wrong, no f2g.txt" - endif - end subroutine readsize - - ! ******************************************************************** - - subroutine readf2g(f2g_file, N_catf,f2g) - - implicit none - character(*), intent(in):: f2g_file - integer,intent(in) :: N_catf - integer,dimension(N_catf),intent(inout) :: f2g - - integer :: N_catg - logical :: file_exist - integer :: local_size,n - - inquire(file=f2g_file,exist=file_exist) - if(file_exist) then - open(40,file= f2g_file,form='formatted',action='read',status='old') - read(40,*)N_catg - read(40,*)local_size - - if(local_size /= N_catf) print*, "wrong f2g.txt" - - if(N_catg == N_catf) then - close(40) - return - endif - - do n=1,N_catf - read(40,*)f2g(n) - enddo - close(40) - ! call MAPL_sort(this%f2g) - else - print*, " wrong, no f2g.txt" - endif - - end subroutine readf2g - - ! ******************************************************************** - - subroutine createLocalTilefile(f2g_file, orig_tile,new_tile) - - implicit none - character(*), intent(in) :: f2g_file - character(*), intent(in) :: orig_tile - character(*), intent(in) :: new_tile - - character(len=256) :: line - character(len=3) :: MAPL_Land_STRING - character(len=4) :: MAPL_Land_ExcludeFromDomain_STRING - character(len=400) :: err_msg - - logical :: file_exist - - integer, dimension(:),allocatable :: f2g - integer :: N_catg, N_catf,n,stat, ty - integer :: N_tile,N_grid,g_id - - character(len=*), parameter :: Iam = 'createLocalTilefile' - - ! string handling below relies on MAPL_Land and MAPL_Land_ExcludeFromDomain - ! falling into a certain range - - ! verify that MAPL_Land has three digits - - if (MAPL_Land<100 .or. MAPL_Land>999) then - err_msg = 'string handling implemented only for 100<=MAPL_Land<=999' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! verify that MAPL_Land_ExcludeFromDomain has four digits - - if (MAPL_Land_ExcludeFromDomain<1000 .or. MAPL_Land_ExcludeFromDomain>9999) then - err_msg = 'string handling implemented only for 1000<=MAPL_Land_ExcludeFromDomain<=9999' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! convert integers to appropriate-length strings - - write (MAPL_Land_STRING, '(i3)') MAPL_Land - write (MAPL_Land_ExcludeFromDomain_STRING,'(i4)') MAPL_Land_ExcludeFromDomain - - inquire(file=trim(orig_tile),exist=file_exist) - if( .not. file_exist) stop ("original tile file does not exist") - - ! Set default local tile file name - call readsize( f2g_file, N_catg,N_catf) - if(N_catg == N_catf) then - print*, "It is global domain..." - return - endif - allocate(f2g(N_catf)) - call readf2g(f2g_file, N_catf,f2g) - - open(40,file=trim(orig_tile),action="read") - open(50,file=trim(new_tile),action="write") - - ! copy the header back into the output tile file - ! (also corrects bug in EASE *.til files that have "N_grid=1" in line 2 but - ! still contain three additional lines for second grid definition) - do n=1,5 - read(40,'(A)') line - if(n==1) then - read(line,*) N_tile - endif - if(n==2) then - read(line,*) N_grid - endif - write(50,'(A)') trim(line) - enddo - if (N_grid==2) then - do n=1,3 - read(40,'(A)') line - write(50,'(A)') trim(line) - enddo - endif - - g_id = 0 - do while(.true.) - ! read one line of *.til file - read(40,'(A)',IOSTAT=stat) line - if(IS_IOSTAT_END(stat)) exit - ! extract first "integer" in "line" and put into "ty" - read(line,*) ty - if( ty == MAPL_Land ) then - ! find index where MAPL_Land ("100") starts in "line" - n=index(line,MAPL_Land_STRING) - ! make sure that a space is available in front of MAPL_Land ("100") - if (n<=1) then - err_msg = 'string handling requires at least one blank space in first column of *.til file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - ! here g_id is (consecutive) id of the global *land* tiles - g_id=g_id+1 - if(.not. any( f2g(:) == g_id)) then - ! if tile is not in local domain, replace " 100" in "line" with "1100" - line(n-1:n+2)=MAPL_Land_ExcludeFromDomain_STRING - endif - endif - ! write "line" into the output tile file - write(50,'(A)') trim(line) - enddo - close(40) - close(50) - - end subroutine createLocalTilefile - - ! ******************************************************************** - - subroutine createLocalBC(f2g_file, orig_BC, new_BC) - - implicit none - character(*),intent(in) :: f2g_file - character(*),intent(in) :: orig_BC - character(*),intent(in) :: new_BC - - real,dimension(14) :: tmprealvec14 - real,allocatable :: tmpvec(:) - integer :: istat, N_catg,N_catf - integer,dimension(:),allocatable :: f2g - - call readsize(f2g_file, N_catg,N_catf) - if(N_catg==N_catf) return - allocate(f2g(N_catf)) - call readf2g(f2g_file, N_catf,f2g) - - allocate(tmpvec(N_catg)) - open(10,file=trim(orig_BC),form='unformatted',action='read',status='old',iostat=istat) - open(20,file=trim(new_BC),form='unformatted',action='write') - - do while(.true.) - read(10,iostat=istat) tmprealvec14 - if(IS_IOSTAT_END(istat)) exit - read(10) tmpvec - write(20) tmprealvec14 - write(20) tmpvec(f2g) - enddo - close(10) - close(20) - deallocate(tmpvec) - end subroutine createLocalBC - - ! ******************************************************************** - - subroutine createLocalCatchRestart(f2g_file, orig_catch, new_catch) - - implicit none - character(*),intent(in):: f2g_file - character(*),intent(in):: orig_catch - character(*),intent(in):: new_catch - integer,parameter :: subtile=4 - integer :: istat, filetype, rc,i, j, ndims - real,allocatable :: tmp1(:) - real,allocatable :: tmp2(:,:) - type(Netcdf4_FileFormatter) :: InFmt,OutFmt - type(FileMetadata) :: OutCfg - type(FileMetadata) :: InCfg - integer :: dim1,dim2 - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: vname,dname - integer ::n, N_catg,N_catf - integer,dimension(:),allocatable :: f2g - - call readsize(f2g_file, N_catg,N_catf) - if(N_catg == N_catf) return - allocate(f2g(N_catf)) - call readf2g(f2g_file, N_catf,f2g) - - allocate(tmp1(N_catg)) - allocate(tmp2(N_catg,subtile)) - - ! check file type - - call MAPL_NCIOGetFileType(orig_catch, filetype,rc=rc) - - if (filetype /= 0) then - - print*, "Catchment restart is binary" - - ! binary - - open(10,file=trim(orig_catch),form='unformatted',action='read',status='old',iostat=istat) - open(20,file=trim(new_catch),form='unformatted',action='write') - - do n=1,30 - read(10) tmp1 - write(20) tmp1(f2g) - enddo - - do n=1,2 - read(10) tmp2 - write(20) tmp2(f2g,:) - enddo - - do n=1,20 - read(10) tmp1 - write(20) tmp1(f2g) - enddo - ! note : the offline restart does not have the last five variables - do n=1,4 - read(10,iostat=istat) tmp2 - if(.not. IS_IOSTAT_END(istat)) write(20) tmp2(f2g,:) - enddo - ! 57 WW - read(10,iostat=istat) tmp2 - if(.not. IS_IOSTAT_END(istat)) write(20) tmp2(f2g,:) - - close(10) - close(20) - else - - ! filetype = 0 : nc4 output file will also be nc4 - - call InFmt%open(trim(orig_catch), pFIO_READ,rc=rc) - InCfg = InFmt%read(rc=rc) - OutCfg = InCfg - - call OutCfg%modify_dimension('tile', size(f2g), rc=rc) - - call OutFmt%create(trim(new_catch),rc=rc) - call OutFmt%write(OutCfg,rc=rc) - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (trim(vname) =='time') then - call var_iter%next() - cycle - endif - - if (ndims == 1) then - call MAPL_VarRead (InFmt,vname,tmp1) - call MAPL_VarWrite(OutFmt,vname,tmp1(f2g)) - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,tmp1 ,offset1=j) - call MAPL_VarWrite(OutFmt,vname,tmp1(f2g),offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,tmp1 ,offset1=j,offset2=i) - call MAPL_VarWrite(OutFmt,vname,tmp1(f2g) ,offset1=j,offset2=i) - enddo - enddo - - end if - call var_iter%next() - enddo - call inFmt%close(rc=rc) - call OutFmt%close(rc=rc) - end if ! file type nc4 - print*, "done create local catchment restart" - end subroutine createLocalCatchRestart - - ! ******************************************************************** - - subroutine createLocalmwRTMRestart(f2g_file, orig_mwrtm, new_mwrtm) - - implicit none - character(*),intent(in):: f2g_file - character(*),intent(in):: orig_mwrtm - character(*),intent(in):: new_mwrtm - integer,parameter :: subtile=4 - integer :: rc - real,allocatable :: tmp1(:) - type(Netcdf4_FileFormatter) :: InFmt,OutFmt - type(FileMetadata) :: OutCfg - type(FileMetadata) :: InCfg - - type(StringVariableMap), pointer :: variables - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: vname - integer :: N_catg,N_catf - integer,dimension(:),allocatable :: f2g - - call readsize(f2g_file, N_catg,N_catf) - if(N_catg == N_catf) return - allocate(f2g(N_catf)) - call readf2g(f2g_file, N_catf,f2g) - - allocate(tmp1(N_catg)) - - ! nc4 in and out file will also be nc4 - call InFmt%open(trim(orig_mwrtm), pFIO_READ,rc=rc) - InCfg = InFmt%read(rc=rc) - OutCfg = InCfg - - call OutCfg%modify_dimension('tile', size(f2g), rc=rc) - - call OutFmt%create(trim(new_mwrtm),rc=rc) - call OutFmt%write(OutCfg,rc=rc) - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - vname => var_iter%key() - call MAPL_VarRead (InFmt,vname,tmp1) - call MAPL_VarWrite(OutFmt,vname,tmp1(f2g)) - call var_iter%next() - enddo - - call inFmt%close(rc=rc) - call OutFmt%close(rc=rc) - - deallocate(f2g,tmp1) - - end subroutine createLocalmwRTMRestart - - ! ******************************************************************** - - subroutine createLocalVegRestart(f2g_file, orig_veg, new_veg) - - implicit none - character(*),intent(in):: f2g_file - character(*),intent(in):: orig_veg - character(*),intent(in):: new_veg - integer :: istat - real,allocatable :: rity(:) - real,allocatable :: z2(:) - real,allocatable :: ascatz0(:) - real,allocatable :: tmp(:) - - integer :: N_catg,N_catf - integer,dimension(:),allocatable :: f2g - integer :: filetype - type(Netcdf4_FileFormatter) :: InFmt,OutFmt - type(FileMetadata) :: OutCfg - type(FileMetadata) :: InCfg - - type(StringVariableMap), pointer :: variables - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: vname - integer :: rc - - call readsize(f2g_file, N_catg,N_catf) - if(N_catg == N_catf) return - allocate(f2g(N_catf)) - call readf2g(f2g_file, N_catf,f2g) - - allocate(rity(N_catg)) - allocate(z2(N_catg)) - allocate(ascatz0(N_catg)) - - call MAPL_NCIOGetFileType(orig_veg, filetype,rc=rc) - - if (filetype /=0) then - open(10,file=trim(orig_veg),form='unformatted',action='read',status='old',iostat=istat) - open(20,file=trim(new_veg),form='unformatted',action='write') - read(10) rity - read(10) z2 - read(10) ascatz0 - write(20) rity(f2g) - write(20) z2(f2g) - write(20) ascatz0(f2g) - - close(10) - close(20) - else - ! nc4 in and out file will also be nc4 - call InFmt%open(trim(orig_veg), pFIO_READ,rc=rc) - InCfg = InFmt%read(rc=rc) - OutCfg = InCfg - - call OutCfg%modify_dimension('tile', size(f2g), rc=rc) - - call OutFmt%create(trim(new_veg),rc=rc) - call OutFmt%write(OutCfg,rc=rc) - - variables => InCfg%get_variables() - var_iter = variables%begin() - allocate(tmp(N_catg)) - do while (var_iter /= variables%end()) - vname => var_iter%key() - call MAPL_VarRead (InFmt,vname,tmp) - call MAPL_VarWrite(OutFmt,vname,tmp(f2g)) - call var_iter%next() - enddo - - call inFmt%close(rc=rc) - call OutFmt%close(rc=rc) - deallocate(tmp) - endif - deallocate(f2g) - - end subroutine createLocalVegRestart - - ! ******************************************************************** - - subroutine correctEase(orig_ease,new_ease) - - ! This subroutine corrects for a bug that is present in some EASE *.til files - ! through at least Icarus-NLv4. - ! Affected files state "N_grid=1" in line 2 of the header, but the header still includes - ! three additional lines for a second grid, which throws off the canonical *.til reader - ! (subroutine LDAS_read_til_file()). - ! - ! This subroutine creates a second, corrected version of the *.til file that can be - ! read with the canonical reader during ldas_setup. - ! - ! - reichle, 2 Aug 2020 - - implicit none - character(*),intent(in) :: orig_ease - character(*),intent(in) :: new_ease - logical :: file_exist,is_oldEASE - integer :: i, N_tile, N_grid - character(len=256) :: tmpline - - inquire(file=trim(orig_ease),exist=file_exist) - if( .not. file_exist) stop (" no ease_tile_file") - - open(55,file=trim(orig_ease),action='read') - read(55,*) N_tile - read(55,*) N_grid - read(55,*) - read(55,*) - read(55,*) - read(55,'(A)') tmpline - close(55) - - is_oldEASE= .false. - if(N_grid==1 .and. index(tmpline,'OCEAN')/=0) is_oldEASE=.true. - - if( is_oldEASE) then - open(55,file=trim(orig_ease),action='read') - open(56,file=trim(new_ease),action='write') - do i =1,5 - read(55,'(A)')tmpline - write(56,'(A)')trim(tmpline) - enddo - read(55,*) - read(55,*) - read(55,*) - do i=1,N_tile - read(55,'(A)')tmpline - write(56,'(A)')trim(tmpline) - enddo - close(56) - close(55) - end if - end subroutine correctEase - - ! ******************************************************************** - ! - ! subroutine to optimize the domain setup (domain decomposition and processor layout) - ! - ! The domain is cut into N_proc stripes, where - ! - N_proc is the number of processors used for the model simulation (i.e., excl. OSERVER tasks) - ! - a stripe cuts across the entire north-south extent of the domain (lat-lon, EASE) or - ! across an entire face (cube-sphere) -- see below - ! - each stripe must be at least two grid cells thick - ! - each stripe should contain roughly the same number of land *tiles* - ! - ! For lat-lon and EASE grid tile spaces: - ! - cut into N_proc stripes of size N_lat-by-IMS(k), k=1:N_proc, IMS(k)>=2, - ! where IMS(k)=no. of grid cells in longitude direction ("thickness" of stripe k) is - ! written into file IMS.rc - ! For cube-sphere grid tile spaces: - ! - cut into N_proc stripes of size N_face-by-JMS(k), k=1:N_proc, JMS(k)>=2, - ! where JMS(k)=no. of grid cells ("thickness" of stripe k) is written - ! into file JMS.rc - ! - ! cube-sphere lat-lon/EASE - ! --------------------------------------------------- - ! NX: 1 N_proc - ! NY: N_proc 1 - ! JMS.rc IMS.rc - - subroutine optimize_latlon(fname_tilefile, N_proc_string, optimized_file, run_dir) - - implicit none - - character(*), intent(in) :: fname_tilefile ! file name (with path) of tile file (*.til) - character(*), intent(in) :: N_proc_string ! *string* w/ no. of processors (or tasks), excl. OSERVER tasks - character(*), intent(in) :: optimized_file - character(*), intent(in) :: run_dir - - ! local variables - integer :: N_proc - integer :: N_tile,N_lon,N_lat,N_grid - integer,allocatable :: landPosition(:) - integer,allocatable :: IMS(:),JMS(:) - integer,allocatable :: local_land(:) - integer :: total_land - integer :: n,typ,tmpint - real :: tmpreal - integer :: avg_land,n0,local - integer :: i,s,e,j,k,n1,n2 - logical :: file_exist - character(len=256):: tmpLine - character(len=128):: gridname - real :: rate,rates(60),maxf(60) - integer :: IMGLOB, JMGLOB - integer :: face(6),face_land(6) - logical :: forward - character(len=:), allocatable :: IMS_file, JMS_File - - ! ----------------------------- - - read (N_proc_string,*) N_proc ! input is string for historical reasons... - - ! get tile info - - inquire(file=trim(fname_tilefile),exist=file_exist) - if( .not. file_exist) stop ( "tile file does not exist") - - open (10, file=trim(fname_tilefile), form='formatted', action='read') - read (10,*) N_tile - read (10,*) N_grid ! some number (?) - read (10,*) gridname ! some string describing tile definition grid (?) - read (10,*) N_lon - read (10,*) n_lat - - if (index(gridname,"CF") /=0) then ! cube-sphere tile space - - IMGLOB = N_lon ! e.g., 180 for c180 - JMGLOB = N_lat ! e.g., 1080 for c180 (6*180=1080) - if(JMGLOB/6 /= IMGLOB) stop " wrong im, jm" - - allocate(landPosition(JMGLOB)) - landPosition = 0 - total_land = 0 - - if(N_grid==2) then - read (10,*) ! some string describing ocean grid (?) - read (10,*) ! # ocean grid cells in longitude direction (N_i_ocn) (?) - read (10,*) - endif - - do n = 1,N_tile - read (10,*) & - typ, & ! 1 - tmpreal, & ! 2 * - tmpreal, & ! 3 - tmpreal, & ! 4 - i , & ! 5 - j ! 6 - !tmpreal, & ! 7 - !tmpint, & ! 8 - !tmpreal, & ! 9 * - !tmpint, & ! 10 - !tmpreal, & ! 11 - !tmpint ! 12 * (previously "tile_id") - if(typ==MAPL_Land) then - total_land=total_land+1 - landPosition(j) = landPosition(j)+1 - endif - - ! assume all land tiles are at the beginning - ! UNSAFE ASSUMPTION! - reichle, 2 Aug 2020 - - if (typ/=MAPL_Land .and. typ/=MAPL_Land_ExcludeFromDomain) then ! exit if not land - - if (logit) then - write (logunit,*) 'WARNING: Encountered first non-land tile in *.til file.' - write (logunit,*) ' Stop reading *.til file under the assumption that' - write (logunit,*) ' land tiles are first in *.til file.' - write (logunit,*) ' This is NOT a safe assumption beyond Icarus-NLv[x] tile spaces!!' - end if - - exit ! assuming land comes first in the til file - - end if - - enddo - close(10) - - if(mod(N_proc,6) /=0) then - print*,"WARNING: ntasks should be adjusted to multiple of 6 for cubed-sphere grid :",N_proc - N_proc = N_proc-mod(N_proc,6) - endif - - print*, "total tiles", total_land - - if(sum(landPosition) /= total_land) print*, "wrong counting of land" - - do k=1,6 - n1 = (k-1)*IMGLOB+1 - n2 = k*IMGLOB - face_land(k) = sum(landPosition(n1:n2)) - face(k) = nint(1.0*face_land(k)/total_land * N_proc) - if ( face(k) == 0) face(k) = 1 - enddo - - ! now make sure sum(face) == N_proc - k=sum(face)-N_proc - - if (k < 0) then - do i=1, -k - n=minloc(face,DIM=1) - face(n) = face(n)+1 - enddo - else - do i = 1,k - n=maxloc(face,DIM=1) - face(n) = face(n)-1 - enddo - endif - - if (sum(face) /= N_proc) stop " wrong proc face" - - ! 2) each process should have average land tiles - - ALLOCATE(JMS(N_proc)) - allocate(local_land(N_Proc)) - JMS = 0 - local_land = 0 - - local = 0 - n0 = 0 - j = 0 - do k=1,6 - n1 = (k-1)*IMGLOB+1 - n2 = k*IMGLOB - - do i=1,60 - rates(i) = -0.3 + i*0.01 - enddo - - maxf=rms_cs(rates) - i=minloc(maxf,DIM=1) - rate = rates(i) - avg_land = ceiling(1.0*face_land(k)/face(k)) - avg_land = avg_land - nint(rate*avg_land) - - tmpint = 0 - j = j+face(k) - forward = .true. - do n = n1,n2 - tmpint=tmpint+landPosition(n) - if((local+1) == j .and. n < n2) cycle - if(n==n2) then - local = local + 1 - local_land(local)=tmpint - JMS(local)=n-n0 - tmpint=0 - n0=n - cycle - endif - if(tmpint .ge. avg_land) then - local = local + 1 - if (n-n0 == 1) forward =.true. - if (forward) then - local_land(local)=tmpint - JMS(local)=n-n0 - tmpint=0 - n0=n - forward = .false. - else - local_land(local)=tmpint - landPosition(n) - JMS(local)=n-1-n0 - tmpint=landPosition(n) - n0=n-1 - forward = .true. - endif - endif - enddo - local = j - enddo - if( sum(JMS) /= JMGLOB) then - print*, sum(JMS), JMGLOB - stop ("wrong cs-domain distribution in the first place") - endif - ! adjust JMS.rc to make sure each processor has at least 2 grid cells in j dimension - ! (i.e., each proc's subdomain must include at least 2 latitude stripes; - ! stripes of grid cells may or may not contain land tiles) - j = 1 - do k = 1,6 - n1 = j - n2 = j+face(k)-1 - do i = n1,n2 - if(JMS(i) == 0) then - n = maxloc(JMS(n1:n2),DIM=1) - JMS(i) = 1 - JMS(n+n1-1) = JMS(n+n1-1)-1 - endif - if(JMS(i) == 1) then - n = maxloc(JMS(n1:n2),DIM=1) - JMS(i) = 2 - JMS(n+n1-1) = JMS(n+n1-1)-1 - endif - enddo - j=j+face(k) - enddo - - print*,"land_distribute: ",local_land - print*, "JMS.rc", JMS - if( sum(JMS) /= JMGLOB) then - print*, sum(JMS), JMGLOB - stop ("wrong cs-domain distribution") - endif - tmpint = 0 - k = 0 - do n = 1, N_proc - tmpint= tmpint+JMS(n) - if( tmpint == IMGLOB) then - k=k+1 - tmpint = 0 - endif - enddo - - if( k /=6 ) stop ("one or more processes may accross the face") - - open(10,file=optimized_file,action='write') - write(10,'(A)') "GEOSldas.GRIDNAME: " // trim(gridname) - write(10,'(A)') "GEOSldas.GRID_TYPE: Cubed-Sphere" - write(10,'(A)') "GEOSldas.NF: 6" - write(10,'(A,I6)') "GEOSldas.IM_WORLD: ", IMGLOB - write(10,'(A)') "GEOSldas.LM: 1" - write(10,'(A,I5)') "NY: ",N_proc - write(10,'(A)') "NX: 1" - write(10,'(A)') "GEOSldas.JMS_FILE: JMS.rc" - close(10) - - JMS_file = trim(run_dir)//"/JMS.rc" - open(10,file=JMS_file ,action='write') - write(10,'(I5,I5)') N_proc, maxval(face) - do n=1,N_proc - write(10,'(I8)') JMS(n) - enddo - close(10) - - else - - allocate(IMS(N_Proc)) - allocate(local_land(N_Proc)) - IMS=0 - local_land = 0 - - ! NOTE: - ! There is a bug in at least some EASE *.til files through at least Icarus-NLv4. - ! Affected files state "N_grid=1" in line 2 of the header, but the header still includes - ! three additional lines for a second grid. - ! - ! The "else" block below corrects for this bug. - ! - ! Elsewhere, LDAS pre-processing corrects for this bug through subroutine correctEase() in - ! preprocess_LDAS.F90, which creates a second, corrected version of the *.til file during - ! ldas_setup. - ! - ! -reichle, 2 Aug 2020 - - if(N_grid==2) then - read (10,*) ! some string describing ocean grid (?) - read (10,*) ! # ocean grid cells in longitude direction (N_i_ocn) (?) - read (10,*) - read(10,'(A)') tmpLine - else - read(10,'(A)') tmpLine - if (index(tmpLine,"OCEAN") /=0) then - read (10,*) ! some string describing ocean grid (?) - read (10,*) ! # ocean grid cells in longitude direction (N_i_ocn) (?) - read (10,*) - read(10,'(A)') tmpLine - endif - endif - - if (index(gridname,'EASE') /=0) then - s=0 - e=N_lon-1 - else - s=1 - e=N_lon - endif - allocate(landPosition(s:e)) - - landPosition=0 - total_land= 0 - - ! 1) read through tile file, put the land tile into the N_lon of bucket - - read (tmpLine,*) & - typ, & ! 1 - tmpreal, & ! 2 * - tmpreal, & ! 3 - tmpreal, & ! 4 - i ! 5 - if(typ==MAPL_Land) then - total_land=total_land+1 - landPosition(i) = landPosition(i)+1 - endif - - do n = 2,N_tile - read (10,*) & - typ, & ! 1 - tmpreal, & ! 2 * - tmpreal, & ! 3 - tmpreal, & ! 4 - i ! 5 - !tmpint, & ! 6 - !tmpreal, & ! 7 - !tmpint, & ! 8 - !tmpreal, & ! 9 * - !tmpint, & ! 10 - !tmpreal, & ! 11 - !tmpint ! 12 * (previously "tile_id") - if(typ==MAPL_Land) then - total_land=total_land+1 - landPosition(i) = landPosition(i)+1 - endif - - ! assume all land tiles are at the beginning - ! UNSAFE ASSUMPTION! - reichle, 2 Aug 2020 - - if (typ/=MAPL_Land .and. typ/=MAPL_Land_ExcludeFromDomain) then ! exit if not land - - if (logit) then - write (logunit,*) 'WARNING: Encountered first non-land tile in *.til file.' - write (logunit,*) ' Stop reading *.til file under the assumption that' - write (logunit,*) ' land tiles are first in *.til file.' - write (logunit,*) ' This is NOT a safe assumption beyond Icarus-NLv[x] tile spaces!!' - end if - - exit ! assuming land comes first in the til file - - end if - - enddo - - close(10) - - if(sum(landPosition) /= total_land) print*, "wrong counting of land" - - do n=1,60 - rates(n) = -0.3 + (n-1)*0.01 - enddo - - maxf=rms(rates) - n=minloc(maxf,DIM=1) - rate = rates(n) - - ! 2) each process should have average land tiles - - avg_land = ceiling(1.0*total_land/N_proc) - print*,"avg_land",avg_land - - ! rate is used to readjust the avg_land - ! in case that the last processors don't have any land tiles, - ! we can increase ther rates - - avg_land = avg_land - nint(rate*avg_land) - print*,"re adjust the avg_land",avg_land - tmpint = 0 - local = 1 - n0 = s-1 - forward = .true. - do n=s,e - tmpint=tmpint+landPosition(n) - if(local == N_proc .and. n < e) cycle ! all lefteover goes to the last process - if( n==e ) then - local_land(local)=tmpint - IMS(local)=n-n0 - exit - endif - - if( tmpint .ge. avg_land ) then - if (forward .or. n-n0 == 1 ) then - local_land(local)=tmpint - IMS(local)=n-n0 - tmpint=0 - n0=n - forward = .false. - else - local_land(local) = tmpint - landPosition(n) - IMS(local)=(n-1)-n0 - tmpint= landPosition(n) - n0 = n-1 - forward = .true. - endif - local = local + 1 - endif - enddo - print*,"rms rate: ", rms(rate) - - print*,"land_distribute: ",local_land - - if( sum(local_land) /= total_land) stop ("wrong distribution") - if( sum(IMS) /= N_lon) stop ("wrong domain distribution") - - ! redistribute IMS and try to make it >=2 (may be impossible for large N_Proc) - do i = 1, N_proc - if(IMS(i) == 0) then - n = maxloc(IMS,DIM=1) - IMS(i) = 1 - IMS(n) = IMS(n)-1 - endif - if(IMS(i) == 1) then - n = maxloc(IMS,DIM=1) - IMS(i) = 2 - IMS(n) = IMS(n)-1 - endif - enddo - if( any(IMS <=1) ) stop ("Each processor must have at least 2 longitude stripes. Request fewer processors.") - - open(10,file=optimized_file, action='write') - write(10,'(A)') "GEOSldas.GRID_TYPE: LatLon" - write(10,'(A)') "GEOSldas.GRIDNAME: "//trim(gridname) - write(10,'(A)') "GEOSldas.LM: 1" - write(10,'(A)') "GEOSldas.POLE: PE" - write(10,'(A)') "GEOSldas.DATELINE: DE" - write(10,'(A,I6)') "GEOSldas.IM_WORLD: ", N_lon - write(10,'(A,I6)') "GEOSldas.JM_WORLD: ", N_lat - - write(10,'(A,I5)') "NX: ",N_proc - write(10,'(A)') "NY: 1" - - write(10,'(A)') "GEOSldas.IMS_FILE: IMS.rc" - close(10) - - IMS_file = trim(run_dir)//"/IMS.rc" - open(10,file=IMS_file,action='write') - write(10,'(I5)') N_proc - do n=1,N_proc - write(10,'(I8)') IMS(n) - enddo - close(10) - - endif - - contains - - ! *************************************************************************** - - elemental function rms(rates) result (f) - real :: f - real,intent(in) :: rates - integer :: tmpint,local - integer :: n0,proc,n - integer :: avg_land - integer,allocatable :: local_land(:) - logical :: forward - - allocate (local_land(N_proc)) - local_land = 0 - avg_land = ceiling(1.0*total_land/N_proc) - avg_land = avg_land -nint(rates*avg_land) - - forward = .true. - tmpint = 0 - local = 1 - n0 = s-1 - do n=s,e - tmpint=tmpint+landPosition(n) - if(local == N_proc .and. n < e) cycle ! all lefteover goes to the last process - if( n==e ) then - local_land(local)=tmpint - exit - endif - - if( tmpint .ge. avg_land ) then - if (forward .or. n-n0 == 1 ) then - local_land(local)=tmpint - tmpint=0 - n0=n - forward = .false. - else - local_land(local) = tmpint - landPosition(n) - tmpint= landPosition(n) - n0 = n-1 - forward = .true. - endif - local = local + 1 - endif - enddo - f = 0.0 - do proc = 1, N_proc - f =max(f,1.0*abs(local_land(proc)-avg_land)) - enddo - deallocate(local_land) - end function rms - - ! *************************************************************************** - - elemental function rms_cs(rates) result (f) - real :: f - real,intent(in) :: rates - integer :: tmpint,local - integer :: proc,n - integer :: avg_land - integer,allocatable :: local_land(:) - integer :: n1,n2,n0 - logical :: forward - - allocate (local_land(face(k))) - local_land = 0 - avg_land = ceiling(1.0*face_land(k)/face(k)) - avg_land = avg_land -nint(rates*avg_land) - if (avg_land <=0) then - f = face_land(k) - return - endif - - tmpint = 0 - local = 1 - - n1 = (k-1)*IMGLOB+1 - n2 = k*IMGLOB - tmpint = 0 - forward = .true. - n0 = n1-1 - do n = n1,n2 - tmpint=tmpint+landPosition(n) - if(local == face(k) .and. n < n2) cycle ! all lefteover goes to the last process - if(n==n2) then - local_land(local)=tmpint - local = local + 1 - cycle - endif - if(tmpint .ge. avg_land) then - if (n -n0 == 1) forward = .true. ! if only one step, should not got backward - if (forward) then - local_land(local)=tmpint - tmpint=0 - n0 = n - forward = .false. - else - local_land(local) = tmpint - landPosition(n) - tmpint = landPosition(n) - n0 = n-1 - forward = .true. - endif - local = local + 1 - endif - enddo - - f = 0.0 - do proc = 1, face(k) - ! punish for no land tiles - f =max(f,1.0*abs(local_land(proc)-avg_land)) - enddo - deallocate(local_land) - end function rms_cs - - end subroutine optimize_latlon - - ! ******************************************************************** - - subroutine convert_pert_rst(pfile_name,pfile_nc4,in_path,exp_id) - - implicit none - character(*),intent(in) :: pfile_name - character(*),intent(in) :: in_path - character(*),intent(in) :: exp_id - character(*),intent(in) :: pfile_nc4 - - integer :: N_catf,N_lon,N_lat,N_lonf,N_latf - integer :: N_force_pert,N_progn_pert - integer,pointer :: f2g(:) - - type(tile_coord_type), dimension(:), pointer :: tile_coord_f => null() - - type(grid_def_type) :: pert_grid_g - type(grid_def_type) :: pert_grid_f - integer :: RC,istat - integer,allocatable :: Pert_rseed(:) - real,allocatable :: Force_pert_ntrmdt_f(:,:,:) - real,allocatable :: Progn_pert_ntrmdt_f(:,:,:) - - call io_domain_files('r',in_path, trim(exp_id),N_catf,f2g,tile_coord_f,pert_grid_g,pert_grid_f,RC) - - N_lon = pert_grid_g%N_lon - N_lat = pert_grid_g%N_lat - N_lonf= pert_grid_f%N_lon - N_latf= pert_grid_f%N_lat - - call i_pert_ldas(RC) - - call o_pert_GEOSldas(rc) - - contains - - ! *************************************************************************** - - subroutine i_pert_ldas(rc) - integer,intent(inout),optional :: rc - - integer :: nrandseed_tmp - type(grid_def_type) :: pert_grid_f_tmp - character(len=*), parameter :: Iam = 'io_pert_rstrt' - integer :: k - real, allocatable :: real_tmp(:) - - open(10, file=pfile_name, convert='big_endian',form='unformatted', status='old', & - action='read', iostat=istat) - - ! one additional header line (as of 21 May 2010)!!! - - call io_grid_def_type( 'r', 10, pert_grid_f_tmp ) - - read (10) nrandseed_tmp, N_force_pert, N_progn_pert - - ! check whether entries in file match passed arguments - ! (check does *not* include *_pert_param!) - - if ( (nrandseed_tmp /= NRANDSEED) ) then ! .or. & - ! (N_force_pert_tmp /= N_force_pert) .or. & - ! (N_progn_pert_tmp /= N_progn_pert) ) then - stop 'pert.rstrt file not compatible (1)' - end if - - allocate(Pert_rseed(NRANDSEED)) - allocate(Force_pert_ntrmdt_f(N_lonf,N_latf, N_Force_pert)) - allocate(Progn_pert_ntrmdt_f(N_lonf,N_latf, N_Progn_pert)) - - if ( index(pert_grid_f%gridtype,'LatLon')/=0 .or. & - index(pert_grid_f%gridtype,'LATLON')/=0 .or. & - index(pert_grid_f%gridtype,'latlon')/=0 ) then - - if ( (pert_grid_f_tmp%N_lon /= pert_grid_f%N_lon) .or. & - (pert_grid_f_tmp%N_lat /= pert_grid_f%N_lat) .or. & - (abs(pert_grid_f_tmp%ll_lon - pert_grid_f%ll_lon) > 1e-4) .or. & - (abs(pert_grid_f_tmp%ll_lat - pert_grid_f%ll_lat) > 1e-4) .or. & - (abs(pert_grid_f_tmp%dlon - pert_grid_f%dlon) > 1e-4) .or. & - (abs(pert_grid_f_tmp%dlat - pert_grid_f%dlat) > 1e-4) ) then - stop 'pert.rstrt file not compatible (2)' - end if - - else - - if ( index(pert_grid_f_tmp%gridtype,pert_grid_f%gridtype)==0 .or. & - (pert_grid_f_tmp%N_lon /= pert_grid_f%N_lon) .or. & - (pert_grid_f_tmp%N_lat /= pert_grid_f%N_lat) .or. & - (pert_grid_f_tmp%i_offg /= pert_grid_f%i_offg) .or. & - (pert_grid_f_tmp%j_offg /= pert_grid_f%j_offg) ) then - stop 'pert.rstrt file not compatible (3)' - end if - - end if - - ! reading - read (10) Pert_rseed(:) - allocate(real_tmp(N_lonf*N_latf)) - do k=1,N_force_pert - !read (10) ((Force_pert_ntrmdt_f(i,j,k), i=1,N_lonf),j=1,N_latf) - read (10) real_tmp(:) - Force_pert_ntrmdt_f(:,:,k) = reshape(real_tmp,[N_lonf, N_latf]) - end do - - do k=1,N_progn_pert - !read (10) ((Progn_pert_ntrmdt_f(i,j,k), i=1,N_lonf),j=1,N_latf) - read (10) real_tmp(:) - Progn_pert_ntrmdt_f(:,:,k) = reshape(real_tmp,[N_lonf, N_latf]) - end do - - close(10) - deallocate(real_tmp) - rc = 0 - end subroutine i_pert_ldas - - ! ******************************************************************** - - subroutine o_pert_GEOSldas(rc) - integer,intent(inout) :: rc - integer :: NCFOutID, STATUS - integer :: seeddim,latdim, londim, Nforce,NProgn - integer :: dims(3), seedid,forceid,prognid - integer :: xstart, ystart - integer :: shuffle, deflate, deflate_level - real :: fill_value - - fill_value = -9999. !1.0e+15 - shuffle = 1 - deflate = 1 - deflate_level = 2 - - !1) create file - status = NF90_CREATE (trim(pfile_nc4), NF90_NOCLOBBER + NF90_HDF5, NCFOutID) - - !2) define dims - ! status = NF_DEF_DIM(NCFOutID, 'nprogn' , N_progn_pert_max, Nprogn) - status = NF90_DEF_DIM(NCFOutID, 'nseed' , NRANDSEED, seeddim) - status = NF90_DEF_DIM(NCFOutID, 'lat' , N_lat, latdim) - status = NF90_DEF_DIM(NCFOutID, 'lon' , N_lon, londim) - status = NF90_DEF_DIM(NCFOutID, 'nforce' , N_force_pert_max, Nforce) - status = NF90_DEF_DIM(NCFOutID, 'nprogn' , N_progn_pert_max, Nprogn) - - ! 3) define vars - status = NF90_DEF_VAR(NCFOutID,'pert_rseed',NF90_DOUBLE,seeddim,seedid) - status = NF90_PUT_ATT(NCFOutID, seedid, 'long_name','perturbations_rseed') - status = NF90_PUT_ATT(NCFOutID, seedid, 'units', '1') - - dims(1)= londim - dims(2)= latdim - dims(3)= Nforce - - status = NF90_DEF_VAR(NCFOutID,'fpert_ntrmdt',NF90_REAL, dims, forceid) - !status = nf90_def_var_deflate(NCFOutID, forceid, shuffle, deflate, deflate_level) - status = NF90_PUT_ATT(NCFOutID, forceid, 'long_name', 'force_pert_intermediate') - status = NF90_PUT_ATT(NCFOutID, forceid, 'units', '1') - status = nf90_put_att(NCFOutID, forceid, '_FillValue', fill_value) - dims(1)= londim - dims(2)= latdim - dims(3)= Nprogn - - status = NF90_DEF_VAR(NCFOutID, 'ppert_ntrmdt', NF90_REAL, dims, prognid) - !status = nf90_def_var_deflate(NCFOutID, prognid, shuffle, deflate, deflate_level) - status = NF90_PUT_ATT(NCFOutID, prognid, 'long_name', 'progn_pert_intermediate') - status = NF90_PUT_ATT(NCFOutID, prognid, 'units', '1') - status = nf90_put_att(NCFOutID, prognid, '_FillValue', fill_value) - - - status = nf90_enddef(NCFOutID) - ! 4) writing - - status= NF90_PUT_VAR(NCFOutID,seedid ,real(Pert_rseed,kind=8)) - - xstart = 1 + pert_grid_f%i_offg - ystart = 1 + pert_grid_f%j_offg - - ! will change to MAPL default 1.0e+15 - !do i = 1, N_lonf - ! do j = 1, N_latf - ! do k = 1, N_force_pert - ! if (Force_pert_ntrmdt_f(i,j,k) < -9998) Force_pert_ntrmdt_f(i,j,k)=fill_value - ! enddo - ! enddo - !enddo - - status= NF90_PUT_VAR(NCFOutID, forceid, Force_pert_ntrmdt_f, start=[xstart,ystart,1], & - count=[N_lonf,N_latf,N_force_pert]) - - ! will change to MAPL default 1.0e+15 - !do i = 1, N_lonf - ! do j = 1, N_latf - ! do k = 1, N_progn_pert - ! if (Progn_pert_ntrmdt_f(i,j,k) < -9998) Progn_pert_ntrmdt_f(i,j,k)=fill_value - ! enddo - ! enddo - !enddo - - status= NF90_PUT_VAR(NCFOutID, prognid, Progn_pert_ntrmdt_f, start=[xstart,ystart,1], & - count=[N_lonf,N_latf,N_progn_pert]) - - STATUS = NF90_CLOSE (NCFOutID) - - deallocate(Force_pert_ntrmdt_f, Progn_pert_ntrmdt_f) - - rc = status - end subroutine o_pert_GEOSldas - - end subroutine convert_pert_rst - - ! ************************************************************************************************** - - subroutine LDAS_read_til_file( tile_file, catch_file, tile_grid_g, tile_coord_land, f2g ) - - ! read land tile information from *.til file - ! - ! This subroutine: - ! - is the GEOSldas version of the LDASsa subroutine read_til_file() and - ! - was known as LDAS_read_land_tile() when in LDAS_TileCoordRoutines.F90. - ! - ! inputs: - ! tile_file : *.til tile definition file (full path + name) - ! catch_file : catchment.def file (full path + name) - ! - ! outputs: - ! tile_grid_g : parameters of tile definition grid - ! tile_coord_land : coordinates of tiles (see tile_coord_type), - ! implemented as pointer which is allocated in - ! this subroutine - ! NOTE: number of *land* tiles can be diagnosed with size(tile_coord) - ! optional: - ! f2g : the full domain id to the global id - ! - ! "tile_id" is no longer read from *.til file and is now set in this - ! subroutine to match order of tiles in *.til file - ! - reichle, 22 Aug 2013 - ! - ! improved documentation of bug in some EASE *.til files (header says N_grid=1 but has two grid defs) - ! and minor clean-up - ! - reichle, 2 Aug 2020 - ! - ! ------------------------------------------------------------- - - implicit none - - character(*), intent(in) :: tile_file - character(*), intent(in) :: catch_file - type(grid_def_type), intent(inout):: tile_grid_g - type(tile_coord_type), dimension(:), pointer :: tile_coord_land ! out - integer, dimension(:), optional, pointer :: f2g ! out - - ! locals - type(tile_coord_type), dimension(:), allocatable :: tile_coord - integer, dimension(:), allocatable :: f2g_tmp ! out - - real :: ease_cell_area - integer :: i, N_tile, N_grid,tmpint1, tmpint2, tmpint3, tmpint4 - integer :: i_indg_offset, j_indg_offset, col_order - integer :: N_tile_land, n_lon, n_lat - logical :: ease_grid - integer :: typ,k,fid - - character(256) :: tmpline - character(128) :: gridname - character(512) :: fname - - character(len=*), parameter :: Iam = 'LDAS_read_til_file' - - ! --------------------------------------------------------------- - - i_indg_offset = 0 - j_indg_offset = 0 - - ! read *.til file header - - if (logit) write (logunit,'(400A)') trim(Iam), '(): reading from ' // trim(tile_file) - - open (10, file=trim(tile_file), form='formatted', action='read') - - read (10,*) N_tile ! number of all tiles in *.til file, incl non-land types - read (10,*) N_grid - read (10,*) gridname - read (10,*) n_lon - read (10,*) n_lat - - ! NOTE: - ! There is a bug in at least some EASE *.til files through at least Icarus-NLv4. - ! Affected files state "N_grid=1" in line 2 of the header, but the header still includes - ! three additional lines for a second grid. - ! LDAS pre-processing corrects for this bug through subroutine correctEase() in - ! preprocess_LDAS.F90, which creates a second, corrected version of the *.til file during - ! ldas_setup. Here, this corrected *.til file is read! - - if(N_grid==2) then - read (10,*) ! some string describing ocean grid (?) - read (10,*) ! # ocean grid cells in longitude direction (N_i_ocn) (?) - read (10,*) ! # ocean grid cells in latitude direction (N_j_ocn) (?) - endif - - ease_grid = .false. - col_order = 0 - - call LDAS_create_grid_g( gridname, n_lon, n_lat, & - tile_grid_g, i_indg_offset, j_indg_offset, ease_cell_area ) - - if (index(tile_grid_g%gridtype,'EASE')/=0) ease_grid = .true. ! 'EASEv1' or 'EASEv2' - if (index(tile_grid_g%gridtype,'SiB2')/=0) col_order=1 ! old bcs - - allocate(tile_coord(N_tile)) - allocate(f2g_tmp(N_tile)) - - i = 0 - fid = 0 - - ! WJ notes: i and k are the same---global ids - ! fid --- num in simulation domain - - do k=1,N_tile - - read(10,'(A)') tmpline - read(tmpline,*) typ - - ! tile type "MAPL_Land_ExcludeFromDomain" identifies land tiles to exclude - ! when non-global domain is created - - if (typ==MAPL_Land .or. typ==MAPL_Land_ExcludeFromDomain) then ! all land - - i=i+1 - tile_coord(i)%tile_id = k - - ! now keep only tiles that are not excluded by way of MAPL_Land_ExcludeFromDomain - - if (typ==MAPL_Land) then - fid=fid+1 - f2g_tmp(fid) = k - end if - - ! Not sure ".or. N_grid==1" will always work in the following conditional. - ! Some Tripolar grid *.til files may have N_grid=1. - ! - reichle, 2 Aug 2020 - - if (ease_grid .or. N_grid==1) then - - ! EASE grid til file has fewer columns - ! (excludes "tile_id", "frac_pfaf", and "area") - - read (tmpline,*) & - tile_coord(i)%typ, & ! 1 - tile_coord(i)%pfaf, & ! 2 - tile_coord(i)%com_lon, & ! 3 - tile_coord(i)%com_lat, & ! 4 - tile_coord(i)%i_indg, & ! 5 - tile_coord(i)%j_indg, & ! 6 - tile_coord(i)%frac_cell ! 7 - - tile_coord(i)%frac_pfaf = nodata_generic - - ! compute area of tile in [km^2] (units convention in tile_coord structure) - - tile_coord(i)%area = ease_cell_area*tile_coord(i)%frac_cell/1000./1000. ! [km^2] - - else ! not ease grid - - if (col_order==1) then - - ! old "SiB2_V2" file format - - read (tmpline,*) & - tile_coord(i)%typ, & ! 1 - tile_coord(i)%pfaf, & ! 2 * - tile_coord(i)%com_lon, & ! 3 - tile_coord(i)%com_lat, & ! 4 - tile_coord(i)%i_indg, & ! 5 - tile_coord(i)%j_indg, & ! 6 - tile_coord(i)%frac_cell, & ! 7 - tmpint1, & ! 8 - tmpint2, & ! 9 * - tmpint3, & ! 10 - tile_coord(i)%frac_pfaf, & ! 11 - tmpint4, & ! 12 (previously "tile_id") - tile_coord(i)%area ! 13 - - else - - read (tmpline,*) & - tile_coord(i)%typ, & ! 1 - tile_coord(i)%area, & ! 2 * - tile_coord(i)%com_lon, & ! 3 - tile_coord(i)%com_lat, & ! 4 - tile_coord(i)%i_indg, & ! 5 - tile_coord(i)%j_indg, & ! 6 - tile_coord(i)%frac_cell, & ! 7 - tmpint1, & ! 8 - tile_coord(i)%pfaf, & ! 9 * - tmpint2, & ! 10 - tile_coord(i)%frac_pfaf, & ! 11 - tmpint3 ! 12 * (previously "tile_id") - - ! change units of area to [km^2] - 23 Sep 2010: fixed units, reichle - - tile_coord(i)%area = tile_coord(i)%area*MAPL_RADIUS*MAPL_RADIUS/1000./1000. - - end if ! col_order 1 - - end if ! (ease_grid) - - ! fix i_indg and j_indg such that they refer to a global grid - ! (see above) - - tile_coord(i)%i_indg = tile_coord(i)%i_indg + i_indg_offset - tile_coord(i)%j_indg = tile_coord(i)%j_indg + j_indg_offset - - else - - ! exit if not land - - if (logit) then - write (logunit,*) 'WARNING: Encountered first non-land tile in *.til file.' - write (logunit,*) ' Stop reading *.til file under the assumption that' - write (logunit,*) ' land tiles are first in *.til file.' - write (logunit,*) ' This is NOT a safe assumption beyond Icarus-NLv[x] tile spaces!!' - end if - - exit ! assuming land comes first in the til file - - endif - - end do - - close(10) - - N_tile_land=i - allocate(tile_coord_land(N_tile_land)) - tile_coord_land=tile_coord(1:N_tile_land) - ! pert_[x]_indg is not written into the tile_coord file and not needed in preprocessing - tile_coord_land%pert_i_indg = nint(nodata_generic) - tile_coord_land%pert_j_indg = nint(nodata_generic) - if(present(f2g)) then - allocate(f2g(fid)) - f2g = f2g_tmp(1:fid) - endif - - call read_catchment_def( catch_file, N_tile_land, tile_coord_land ) - - ! ---------------------------------------------------------------------- - ! - ! if elevation info is still needed, read *gridded* elevation data (check only first tile!) - - ! gridded elevation file is NOT available for EASE grids, where elevation information - ! is in catchment.def file - - if ( abs(tile_coord_land(1)%elev-nodata_generic)topo_DYN_ave.file') - open(10,file='topo_DYN_ave.file', action='read') - fname= '' - read(10,'(A)') fname - close(10) - call read_grid_elev( trim(fname), tile_grid_g, N_tile_land, tile_coord_land ) - - end if - - if ( abs(tile_coord_land(1)%elev-nodata_generic)tile_grid%dlon+latlon_tol) then - - if (logit) write (logunit,*) & - 'resetting min/maxlon in tile_id=', tile_coord(k)%tile_id - - ! "push" tile to the east of the dateline - - tile_coord(k)%min_lon = -180. - tile_coord(k)%max_lon = -180. + 0.5*tile_grid%dlon - - end if - - - ! check that com_lon is within tile definition grid cell - - if ( .not. ( & - (tile_coord(k)%com_lon >= this_minlon) .and. & - (tile_coord(k)%com_lon <= this_maxlon) ) ) then - if (logit) write (logunit,*) & - 'resetting com_lon in tile_id=', tile_coord(k)%tile_id - - tile_coord(k)%com_lon = & - 0.5*(tile_coord(k)%min_lon + tile_coord(k)%max_lon) - - end if - - end do - end if - - end subroutine fix_dateline_bug_in_tilecoord - - ! ********************************************************************** - - subroutine read_catchment_def( catchment_def_file, N_tile, tile_coord ) - - ! reichle, 17 May 2011: read elevation data if available - - ! format of catchment.def file - ! - ! Header line: N_tile - ! - ! Columns: tile_id, Pfaf, min_lon, max_lon, min_lat, max_lat, [elev] - ! - ! Elevation [m] is ONLY available for EASE grid tile definitions - - implicit none - - character(*), intent(in) :: catchment_def_file - - integer, intent(in) :: N_tile - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! inout - - ! locals - - integer :: i, istat, tmpint1, sweep - - integer, dimension(N_tile) :: tmp_tileid, tmp_pfaf - - character(len=*), parameter :: Iam = 'read_catchment_def' - character(len=400) :: err_msg - - ! --------------------------------------------------------------- - - ! read file header - - if (logit) write (logunit,'(400A)') & - 'read_catchment_def(): reading from' // trim(catchment_def_file) - if (logit) write (logunit,*) - - ! sweep=1: Try reading 7 columns. If this fails, try again. - ! sweep=2: Read only 6 columns. - - do sweep=1,2 - - if (logit) write (logunit,*) 'starting sweep ', sweep - - open (10, file=trim(catchment_def_file), form='formatted', action='read') - - read (10,*) tmpint1 - - if (logit) write (logunit,*) 'file contains coordinates for ', tmpint1, ' tiles' - if (logit) write (logunit,*) - - if (N_tile/=tmpint1) then - print*,"need :", N_tile,"but have: ",tmpint1 - err_msg = 'tile_coord_file and catchment_def_file mismatch. (1)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - do i=1,N_tile - - if (sweep==1) then - - ! read 7 columns, avoid using exact format specification - - read (10,*, iostat=istat) tmp_tileid(i), tmp_pfaf(i), & - tile_coord(i)%min_lon, & - tile_coord(i)%max_lon, & - tile_coord(i)%min_lat, & - tile_coord(i)%max_lat, & - tile_coord(i)%elev - - else - - ! read 6 columns, avoid using exact format specification - - read (10,*, iostat=istat) tmp_tileid(i), tmp_pfaf(i), & - tile_coord(i)%min_lon, & - tile_coord(i)%max_lon, & - tile_coord(i)%min_lat, & - tile_coord(i)%max_lat - - tile_coord(i)%elev = nodata_generic - - end if - - if (istat/=0) then ! read error - - if (sweep==1) then - - close(10,status='keep') - - if (logit) write (logunit,*) 'sweep 1 failed, trying sweep 2' - - exit ! exit sweep 1, try sweep 2 - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'sweep 2 failed') - - end if - - end if - - if (i==N_tile) then ! reached end of tile loop w/o read error - - close(10,status='keep') - - if (logit) write (logunit,*) 'sweep ', sweep, 'successfully completed' - - return - - end if - - end do ! loop through tiles - - end do ! loop through sweeps - - if ( any(tile_coord(1:N_tile)%tile_id/=tmp_tileid) .or. & - any(tile_coord(1:N_tile)%pfaf /=tmp_pfaf) ) then - - err_msg = 'tile_coord_file and catchment_def_file mismatch. (2)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end subroutine read_catchment_def - - ! ----------------------------------------------------------------- - - end subroutine LDAS_read_til_file - - ! ************************************************************************************ - -end module preprocess_ldas_routines - -! ====================== EOF ======================================================= - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh deleted file mode 100755 index 73d3b421..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/process_hist.csh +++ /dev/null @@ -1,78 +0,0 @@ -#!/bin/csh -f - -## I am changed the CUBE/EASE logic -## if CUBE we produce 2D -## anything else, SMAP and other offline grids we produce tile space - -setenv LSM_CHOICE $1 -setenv AEROSOL_DEPOSITION $2 -setenv GRID $3 -setenv GRIDNAME $4 -setenv HISTRC $5 -setenv RUN_IRRIG $6 -setenv ASSIM $7 -setenv NENS $8 - -echo $GRIDNAME - -if($ASSIM == 1) then - sed -i 's|\#ASSIM|''|g' $HISTRC - sed -i '/^\#EASE/d' $HISTRC - sed -i '/^\#CUBE/d' $HISTRC -else - sed -i '/^\#ASSIM/d' $HISTRC -endif - -if($GRID == CUBE) then - sed -i '/^\#EASE/d' $HISTRC - sed -i 's|\#CUBE|''|g' $HISTRC - sed -i 's|GRIDNAME|'"$GRIDNAME"'|g' $HISTRC -else - sed -i '/^\#CUBE/d' $HISTRC - sed -i 's|\#EASE|''|g' $HISTRC - sed -i 's|GRIDNAME|'"$GRIDNAME"'|g' $HISTRC -endif - -if($LSM_CHOICE == 1) then - set GridComp = CATCH - sed -i '/^>>>HIST_CATCHCN<<>>HIST_CATCHCNCLM45<<>>HIST_CATCHCNCLM45<<>>HIST_CATCHCN<<>>HIST_CATCHCN<<>>HIST_CATCHCNCLM45<< 1) then - set GridComp = ENSAVG - sed -i 's|VEGDYN|'VEGDYN_e0000'|g' $HISTRC - sed -i 's|TP1|'TSOIL1TILE'|g' $HISTRC - sed -i 's|TP2|'TSOIL2TILE'|g' $HISTRC - sed -i 's|TP3|'TSOIL3TILE'|g' $HISTRC - sed -i 's|TP4|'TSOIL4TILE'|g' $HISTRC - sed -i 's|TP5|'TSOIL5TILE'|g' $HISTRC - sed -i 's|TP6|'TSOIL6TILE'|g' $HISTRC -# sed -i 's|DATAATM|'DATAATM0000'|g' $HISTRC -endif - -sed -i 's|GridComp|'$GridComp'|g' $HISTRC - -if($AEROSOL_DEPOSITION == 0) then - sed -i '/^>>>HIST_AEROSOL<<>>HIST_AEROSOL<<>>HIST_IRRIG<<>>HIST_IRRIG<< MY_exeinp.txt -# -# (2) Use the resource parameter settings below when editing MY_exeinp.txt -# -############################################################################## - -NUM_LDAS_ENSEMBLE: [NUM_ATM_ENSEMBLE] - -LADAS_COUPLING: 2 - -ADAS_EXPDIR: [full_path]/[ADAS_EXPDIR] - -MET_TAG: [ADAS_EXPID]__Nx+- -MET_PATH: [ADAS_EXPDIR]/atmens/ensdiag/mem - -MET_HINTERP: 0 - -LAND_ASSIM: YES - -LANDASSIM_DT: 10800 -LANDASSIM_T0: 013000 - -FIRST_ENS_ID: 1 - -ENSEMBLE_FORCING: YES - -JOB_SGMT: 00000000 060000 -NUM_SGMT: 1 - -################################# EOF ######################################## diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central b/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central deleted file mode 100644 index c30c880a..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/sample_config_files/LADAS/exeinp.txt.Hy4dEnVar.central +++ /dev/null @@ -1,39 +0,0 @@ -# -# Sample GEOSldas "exeinp" file for LADAS (central simulation) -# -# This sample is for the GEOSldas instance that is coupled with the central -# simulation component of the Hy4dEnVar ADAS: -# -# (1) Create exeinp template using: -# ldas_setup sample --exeinp > MY_exeinp.txt -# -# (2) Use the resource parameter settings below when editing MY_exeinp.txt -# -############################################################################## - -LADAS_COUPLING: 1 - -ADAS_EXPDIR: [full_path]/[ADAS_EXPDIR] - -MET_TAG: [ADAS_EXPID]__Nx+- -MET_PATH: ../../scratch -# option to use perturbed forcing created from central simulation and atm ensemble -# MET_PATH: [ADAS_EXPDIR]/atmens/rgdlfo - -MET_HINTERP: 0 - -LAND_ASSIM: YES - -LANDASSIM_DT: 10800 -LANDASSIM_T0: 013000 - -FIRST_ENS_ID: 1 - -ENSEMBLE_FORCING: NO -# option to use perturbed forcing created from central simulation and atm ensemble -# ENSEMBLE_FORCING: YES - -JOB_SGMT: 00000000 060000 -NUM_SGMT: 1 - -################################# EOF ######################################## diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 deleted file mode 100644 index df52c8be..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/tile_bin2nc4.F90 +++ /dev/null @@ -1,454 +0,0 @@ -PROGRAM tile_bin2nc4 - - implicit none - INCLUDE 'netcdf.inc' - - integer :: i,k, n, NTILES - integer :: NCFOutID, Vid, STATUS, CellID, TimID, nVars - character(256) :: Usage="tile_bin2nc4.x BINFILE DESCRIPTOR TILECOORD" - character(512) :: BINFILE, TILECOORD, DESCRIPTOR, arg(3) - character(128) :: MYNAME, BUF - integer, dimension(8) :: date_time_values - character (22) :: time_stamp - real, allocatable, dimension (:) :: lons, lats, var - integer, allocatable, dimension (:) :: tileid, i_index, j_index - integer :: myunit1, myunit2 - real :: undef - ! processing command line agruments - - I = command_argument_count() - - if( I /=3 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call get_command_argument(n,arg(n)) - enddo - - call get_environment_variable ("MYNAME" ,MYNAME ) - read(arg(1),'(a)') BINFILE - read(arg(2),'(a)') DESCRIPTOR - read(arg(3),'(a)') TILECOORD - -! print *,MYNAME -! print *,trim(BINFILE) -! print *,trim(DESCRIPTOR) -! print *,trim(TILECOORD) - - ! reading TILECOORD - - open (newunit=myunit1, file = trim(TILECOORD), form = 'unformatted', action ='read') - read (myunit1) NTILES - allocate (lons (1:NTILES)) - allocate (lats (1:NTILES)) - allocate (tileid (1:NTILES)) - allocate (var (1:NTILES)) - allocate (i_index(1:NTILES)) - allocate (j_index(1:NTILES)) - - read (myunit1) tileid - read (myunit1) tileid - read (myunit1) tileid - read (myunit1) lons - read (myunit1) lats - read (myunit1) var - read (myunit1) var - read (myunit1) var - read (myunit1) var - read (myunit1) i_index - read (myunit1) j_index - - close (myunit1,status = 'keep') - - ! read binary and write NC4 - - open (newunit=myunit1, file = trim(DESCRIPTOR), form ='formatted', action = 'read') - nVars = 0 - - undef = 0.100000E+16 - k = 0 - do - read(myunit1, '(a)', iostat=status) buf - if (status /= 0) exit - k = k + 1 - if(buf(1:index(buf,' ') -1) == 'vars') then - i = index(buf,' ') - read (buf(i:),*, IOSTAT = n) nVars - endif - if(buf(1:index(buf,' ') -1) == 'undef') then - i = index(buf,' ') - read (buf(i:),*, IOSTAT = n) undef - endif - if(nVars /= 0) exit - - end do - - status = NF_CREATE (trim(BINFILE)//'.nc4', NF_NETCDF4, NCFOutID) - status = NF_DEF_DIM(NCFOutID, 'tile' , NTILES, CellID) - status = NF_DEF_DIM(NCFOutID, 'time' , NF_UNLIMITED, TimID) - - status = NF_DEF_VAR(NCFOutID, 'lon' , NF_FLOAT, 1 ,CellID, vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM('longitude'), 'longitude') - status = NF_DEF_VAR(NCFOutID, 'lat' , NF_FLOAT, 1 ,CellID, vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM('latitude'), 'latitude') - status = NF_DEF_VAR(NCFOutID, 'IG' , NF_INT, 1 ,CellID, vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM('I_INDEX'), 'I_INDEX') - status = NF_DEF_VAR(NCFOutID, 'JG' , NF_INT, 1 ,CellID, vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM('J_INDEX'), 'J_INDEX') - do n = 1, nVars - - read(myunit1, '(a)', iostat=status) buf - status = NF_DEF_VAR(NCFOutID,buf(1:index(buf,' ') -1) , NF_FLOAT, 2 ,(/CellID, TimID/), vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM(getAttribute(buf(1:index(buf,' ') -1), LNAME = 1)), & - getAttribute(buf(1:index(buf,' ') -1), LNAME = 1)) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & - LEN_TRIM(getAttribute(buf(1:index(buf,' ') -1), UNT = 1)), & - getAttribute(buf(1:index(buf,' ') -1), UNT = 1)) - status = nf_put_att_real(NCFOutID, vid, '_FillValue',NF_FLOAT, 1, undef) - end do - - - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) - - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), & - trim(MYNAME)) - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCFOutID) - - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,'lon' ) ,(/1/),(/NTILES/),lons ) - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,'lat' ) ,(/1/),(/NTILES/),lats ) - status = NF_PUT_VARA_INT (NCFOutID,VarID(NCFOutID,'IG' ) ,(/1/),(/NTILES/),i_index ) - status = NF_PUT_VARA_INT (NCFOutID,VarID(NCFOutID,'JG' ) ,(/1/),(/NTILES/),j_index ) - - ! reading and writing - - open (newunit=myunit2, file = trim(BINFILE)//'.bin', form = 'unformatted', action = 'read') - - rewind (myunit1) - do i = 1, k - read(myunit1, '(a)', iostat=status) buf - end do - - do n = 1, nVars - read (myunit1, '(a)', iostat=status) buf - read (myunit2) var - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,buf(1:index(buf,' ') -1)) ,(/1,1/),(/NTILES,1/),var ) - end do - - STATUS = NF_CLOSE (NCFOutID) - close (myunit1) - close (myunit2) - - contains - - ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! *********************************************************************** - - FUNCTION getAttribute (SHORT_NAME, LNAME, UNT) result (str_atr) - - character(*), intent(in) :: SHORT_NAME - integer, intent (in), optional :: LNAME, UNT - character(128) :: str_atr, LONG_NAME, UNITS - - SELECT case (trim(SHORT_NAME)) - - ! For SM_L4 - ! reichle, 20 May 2020: verified SHORT_NAME and corrected UNITS to match SMAP L4_SM Product Specs; LONG_NAME (mostly) from GEOS_CatchGridComp.F90 - ! reichle, 14 Feb 2022: added "WATERTABLED" (now: "PEATCLSM_WATERLEVEL") and "FSWCHANGE" (now: "PEATCLSM_FSWCHANGE") - ! reichle, 21 Feb 2022: added "mwrtm_vegopacity" - - case ('sm_surface'); LONG_NAME = 'water_surface_layer'; UNITS = 'm3 m-3' - case ('sm_rootzone'); LONG_NAME = 'water_root_zone'; UNITS = 'm3 m-3' - case ('sm_profile'); LONG_NAME = 'water_ave_prof'; UNITS = 'm3 m-3' - case ('sm_surface_wetness'); LONG_NAME = 'surface_soil_wetness'; UNITS = '1' - case ('sm_rootzone_wetness'); LONG_NAME = 'root_zone_soil_wetness'; UNITS = '1' - case ('sm_profile_wetness'); LONG_NAME = 'ave_prof_soil_wetness'; UNITS = '1' - case ('surface_temp'); LONG_NAME = 'ave_catchment_temp_incl_snw'; UNITS = 'K' - case ('soil_temp_layer1'); LONG_NAME = 'soil_temperatures_layer_1'; UNITS = 'K' - case ('soil_temp_layer2'); LONG_NAME = 'soil_temperatures_layer_2'; UNITS = 'K' - case ('soil_temp_layer3'); LONG_NAME = 'soil_temperatures_layer_3'; UNITS = 'K' - case ('soil_temp_layer4'); LONG_NAME = 'soil_temperatures_layer_4'; UNITS = 'K' - case ('soil_temp_layer5'); LONG_NAME = 'soil_temperatures_layer_5'; UNITS = 'K' - case ('soil_temp_layer6'); LONG_NAME = 'soil_temperatures_layer_6'; UNITS = 'K' - case ('snow_mass'); LONG_NAME = 'snow_mass'; UNITS = 'kg m-2' - case ('snow_depth'); LONG_NAME = 'snow_depth_in_snow_covered_area'; UNITS = 'm' - case ('land_evapotranspiration_flux'); LONG_NAME = 'Evaporation_land'; UNITS = 'kg m-2 s-1' - case ('overland_runoff_flux'); LONG_NAME = 'runoff_flux'; UNITS = 'kg m-2 s-1' - case ('baseflow_flux'); LONG_NAME = 'baseflow_flux'; UNITS = 'kg m-2 s-1' - case ('snow_melt_flux'); LONG_NAME = 'Snowmelt_flux_land'; UNITS = 'kg m-2 s-1' - case ('soil_water_infiltration_flux'); LONG_NAME = 'rainwater_infiltration_flux'; UNITS = 'kg m-2 s-1' - case ('land_fraction_saturated'); LONG_NAME = 'fractional_area_of_saturated_zone'; UNITS = '1' - case ('land_fraction_unsaturated'); LONG_NAME = 'fractional_area_of_unsaturated_zone'; UNITS = '1' - case ('land_fraction_wilting'); LONG_NAME = 'fractional_area_of_wilting_zone'; UNITS = '1' - case ('land_fraction_snow_covered'); LONG_NAME = 'fractional_area_of_land_snowcover'; UNITS = '1' - case ('heat_flux_sensible'); LONG_NAME = 'Sensible_heat_flux_land'; UNITS = 'W m-2' - case ('heat_flux_latent'); LONG_NAME = 'Latent_heat_flux_land'; UNITS = 'W m-2' - case ('heat_flux_ground'); LONG_NAME = 'Ground_heating_land'; UNITS = 'W m-2' - case ('net_downward_shortwave_flux'); LONG_NAME = 'Net_shortwave_land'; UNITS = 'W m-2' - case ('net_downward_longwave_flux'); LONG_NAME = 'Net_longwave_land'; UNITS = 'W m-2' - case ('radiation_shortwave_downward_flux');LONG_NAME = 'Incident_shortwave_land'; UNITS = 'W m-2' - case ('radiation_longwave_absorbed_flux'); LONG_NAME = 'surface_absorbed_longwave_flux'; UNITS = 'W m-2' - case ('precipitation_total_surface_flux'); LONG_NAME = 'RainfSnowf'; UNITS = 'kg m-2 s-1' - case ('snowfall_surface_flux'); LONG_NAME = 'snowfall'; UNITS = 'kg m-2 s-1' - case ('surface_pressure'); LONG_NAME = 'surface_pressure'; UNITS = 'Pa' - case ('height_lowatmmodlay'); LONG_NAME = 'reference_height_for_Tair_Qair_Wind'; UNITS = 'm' - case ('temp_lowatmmodlay'); LONG_NAME = 'air_temperature_at_RefH'; UNITS = 'K' - case ('specific_humidity_lowatmmodlay'); LONG_NAME = 'specific_humidity_at_RefH'; UNITS = 'kg kg-1' - case ('windspeed_lowatmmodlay'); LONG_NAME = 'wind_speed_at_RefH'; UNITS = 'm s-1' - case ('vegetation_greenness_fraction'); LONG_NAME = 'greeness_fraction'; UNITS = '1' - case ('leaf_area_index'); LONG_NAME = 'leaf_area_index'; UNITS = 'm2 m-2' - case ('depth_to_water_table_from_surface_in_peat'); LONG_NAME = 'depth_to_water_table_from_surface_in_peat'; UNITS = 'm' - case ('free_surface_water_on_peat_flux'); LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat'; UNITS = 'kg m-2 s-1' - case ('mwrtm_vegopacity'); LONG_NAME = 'Lband_microwave_vegopacity_normalized_with_cos_inc_angle'; UNITS = '1' - - ! additional defintions for SMAP Nature Run - reichle, 20 May 2020 - - case ('snow_temp_layer1'); LONG_NAME = 'temperature_top_snow_layer'; UNITS = 'K' - case ('tb_h'); LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Hpol'; UNITS = 'K' - case ('tb_v'); LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Vpol'; UNITS = 'K' - case ('TB_LAND_1410MHZ_40DEG_HPOL'); LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Hpol'; UNITS = 'K' - case ('TB_LAND_1410MHZ_40DEG_VPOL'); LONG_NAME = 'brightness_temperature_land_1410MHz_40deg_Vpol'; UNITS = 'K' - - ! Done for SM_L4 - - case ('Tair'); LONG_NAME = 'air_temperature_at_RefH'; UNITS = 'K' - case ('TA'); LONG_NAME = 'air_temperature_at_RefH'; UNITS = 'K' - case ('Qair'); LONG_NAME = 'specific_humidity_at_RefH'; UNITS = 'kg kg-1' - case ('QA'); LONG_NAME = 'specific_humidity_at_RefH'; UNITS = 'kg kg-1' - case ('LWdown'); LONG_NAME = 'surface_absorbed_longwave_flux'; UNITS = 'W m-2' - case ('LWDNSRF'); LONG_NAME = 'surface_absorbed_longwave_flux'; UNITS = 'W m-2' - case ('SWdown'); LONG_NAME = 'downward_shortwave_radiation'; UNITS = 'W m-2' - case ('Wind'); LONG_NAME = 'wind_speed_at_RefH'; UNITS = 'm s-1' - case ('UU'); LONG_NAME = 'wind_speed_at_RefH'; UNITS = 'm s-1' - case ('Psurf'); LONG_NAME = 'surface_pressure'; UNITS = 'Pa' - case ('PS'); LONG_NAME = 'surface_pressure'; UNITS = 'Pa' - case ('Rainf_C'); LONG_NAME = 'convective_rainfall'; UNITS = 'kg m-2 s-1' - case ('Rainf'); LONG_NAME = 'liquid_water_precipitation'; UNITS = 'kg m-2 s-1' - case ('Snowf'); LONG_NAME = 'total_snowfall'; UNITS = 'kg m-2 s-1' - case ('RainfSnowf'); LONG_NAME = 'RainfSnowf'; UNITS = 'kg m-2 s-1' - case ('SWnet'); LONG_NAME = 'downward_net_shortwave_radiation'; UNITS = 'W m-2' - case ('RefH'); LONG_NAME = 'reference_height_for_Tair_Qair_Wind'; UNITS = 'm' - case ('DZ'); LONG_NAME = 'reference_height_for_Tair_Qair_Wind'; UNITS = 'm' - case ('CATDEF'); LONG_NAME = 'catchment_deficit'; UNITS = 'kg m-2' - case ('RZEXC'); LONG_NAME = 'root_zone_excess'; UNITS = 'kg m-2' - case ('SRFEXC'); LONG_NAME = 'surface_excess'; UNITS = 'kg m-2' - case ('WESNN1'); LONG_NAME = 'snow_mass_layer_1'; UNITS = 'kg m-2' - case ('WESNN2'); LONG_NAME = 'snow_mass_layer_2'; UNITS = 'kg m-2' - case ('WESNN3'); LONG_NAME = 'snow_mass_layer_3'; UNITS = 'kg m-2' - case ('HTSNNN1'); LONG_NAME = 'heat_content_snow_layer_1'; UNITS = 'J m-2' - case ('HTSNNN2'); LONG_NAME = 'heat_content_snow_layer_2'; UNITS = 'J m-2' - case ('HTSNNN3'); LONG_NAME = 'heat_content_snow_layer_3'; UNITS = 'J m-2' - case ('SNDZN1'); LONG_NAME = 'snow_depth_layer_1'; UNITS = 'm' - case ('SNDZN2'); LONG_NAME = 'snow_depth_layer_2'; UNITS = 'm' - case ('SNDZN3'); LONG_NAME = 'snow_depth_layer_3'; UNITS = 'm' - case ('FICE1'); LONG_NAME = 'snow_frozen_fraction_layer_1'; UNITS = '1' - case ('FICE2'); LONG_NAME = 'snow_frozen_fraction_layer_2'; UNITS = '1' - case ('FICE3'); LONG_NAME = 'snow_frozen_fraction_layer_3'; UNITS = '1' - case ('ALBVR'); LONG_NAME = 'surface_reflectivity_for_visible_beam'; UNITS = '1' - case ('ALBVF'); LONG_NAME = 'surface_reflectivity_for_visible_diffuse'; UNITS = '1' - case ('ALBNR'); LONG_NAME = 'surface_reflectivity_for_near_infared_beam'; UNITS = '1' - case ('ALBNF'); LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse'; UNITS = '1' - case ('HLWUP'); LONG_NAME = 'surface_emitted_longwave_flux'; UNITS = 'W m-2' - case ('GWETPROF'); LONG_NAME = 'ave_prof_soil_wetness'; UNITS = '1' - case ('GWETROOT'); LONG_NAME = 'root_zone_soil_wetness'; UNITS = '1' - case ('GWETTOP'); LONG_NAME = 'surface_soil_wetness'; UNITS = '1' - case ('PRMC'); LONG_NAME = 'water_ave_prof'; UNITS = 'm3 m-3' - case ('RZMC'); LONG_NAME = 'water_root_zone'; UNITS = 'm3 m-3' - case ('SFMC'); LONG_NAME = 'water_surface_layer'; UNITS = 'm3 m-3' - case ('TPSNOW'); LONG_NAME = 'temperature_top_snow_layer'; UNITS = 'K' - case ('TUNST'); LONG_NAME = 'temperature_unsaturated_zone'; UNITS = 'K' - case ('TSAT'); LONG_NAME = 'temperature_saturated_zone'; UNITS = 'K' - case ('TWLT'); LONG_NAME = 'temperature_wilted_zone'; UNITS = 'K' - case ('TSURF'); LONG_NAME = 'ave_catchment_temp_incl_snw'; UNITS = 'K' - case ('TPSURF'); LONG_NAME = 'ave_catchment_temp_incl_snw'; UNITS = 'K' - case ('GRN'); LONG_NAME = 'greeness_fraction'; UNITS = '1' - case ('LAI'); LONG_NAME = 'leaf_area_index'; UNITS = '1' - case ('TP1'); LONG_NAME = 'soil_temperatures_layer_1'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('TP2'); LONG_NAME = 'soil_temperatures_layer_2'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('TP3'); LONG_NAME = 'soil_temperatures_layer_3'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('TP4'); LONG_NAME = 'soil_temperatures_layer_4'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('TP5'); LONG_NAME = 'soil_temperatures_layer_5'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('TP6'); LONG_NAME = 'soil_temperatures_layer_6'; UNITS = 'K' ! units now K, rreichle & borescan, 6 Nov 2020 - case ('PRECTOTLAND');LONG_NAME = 'Total_precipitation_land'; UNITS = 'kg m-2 s-1' - case ('PRECSNOLAND');LONG_NAME = 'snowfall_land'; UNITS = 'kg m-2 s-1' - case ('SNOWMASS') ;LONG_NAME = 'snow_mass'; UNITS = 'kg m-2' - case ('SNOMAS') ;LONG_NAME = 'snow_mass'; UNITS = 'kg m-2' - case ('SNO'); LONG_NAME = 'snowfall'; UNITS = 'kg m-2 s-1' - case ('SNODP'); LONG_NAME = 'snow_depth_in_snow_covered_area'; UNITS = 'm' - case ('EVPSOIL'); LONG_NAME = 'baresoil_evap_energy_flux'; UNITS = 'W m-2' - case ('EVPTRNS'); LONG_NAME = 'transpiration_energy_flux'; UNITS = 'W m-2' - case ('EVPINTR'); LONG_NAME = 'interception_loss_energy_flux'; UNITS = 'W m-2' - case ('EVPSBLN'); LONG_NAME = 'snow_ice_evaporation_energy_flux'; UNITS = 'W m-2' - case ('RUNOFF'); LONG_NAME = 'runoff_flux'; UNITS = 'kg m-2 s-1' - case ('BASEFLOW'); LONG_NAME = 'baseflow_flux'; UNITS = 'kg m-2 s-1' - case ('SMLAND'); LONG_NAME = 'Snowmelt_flux_land'; UNITS = 'kg m-2 s-1' - case ('QINFIL'); LONG_NAME = 'rainwater_infiltration_flux'; UNITS = 'kg m-2 s-1' - case ('FRUNST'); LONG_NAME = 'fractional_area_of_unsaturated_zone'; UNITS = '1' - case ('FRSAT'); LONG_NAME = 'fractional_area_of_saturated_zone'; UNITS = '1' - case ('FRSNO'); LONG_NAME = 'fractional_area_of_land_snowcover'; UNITS = '1' - case ('FRWLT'); LONG_NAME = 'fractional_area_of_wilting_zone'; UNITS = '1' - case ('PARDFLAND'); LONG_NAME = 'surface_downwelling_par_diffuse_flux'; UNITS = 'W m-2' - case ('PARDRLAND'); LONG_NAME = 'surface_downwelling_par_beam_flux'; UNITS = 'W m-2' - case ('SHLAND'); LONG_NAME = 'Sensible_heat_flux_land'; UNITS = 'W m-2' - case ('LHLAND'); LONG_NAME = 'Latent_heat_flux_land'; UNITS = 'W m-2' - case ('EVLAND'); LONG_NAME = 'Evaporation_land'; UNITS = 'kg m-2 s-1' - case ('LWLAND'); LONG_NAME = 'Net_longwave_land'; UNITS = 'W m-2' - case ('SWLAND'); LONG_NAME = 'Net_shortwave_land'; UNITS = 'W m-2' - case ('SWDOWNLAND'); LONG_NAME = 'Incident_shortwave_land'; UNITS = 'W m-2' - case ('GHLAND'); LONG_NAME = 'Ground_heating_land'; UNITS = 'W m-2' - case ('TWLAND'); LONG_NAME = 'Avail_water_storage_land'; UNITS = 'kg m-2' - case ('TSLAND'); LONG_NAME = 'Total_snow_storage_land'; UNITS = 'kg m-2' - case ('TELAND'); LONG_NAME = 'Total_energy_storage_land'; UNITS = 'J m-2' - case ('WCHANGE'); LONG_NAME = 'rate_of_change_of_total_land_water'; UNITS = 'kg m-2 s-1' - case ('ECHANGE'); LONG_NAME = 'rate_of_change_of_total_land_energy'; UNITS = 'W m-2' - case ('SPLAND'); LONG_NAME = 'rate_of_spurious_land_energy_source'; UNITS = 'W m-2' - case ('SPWATR'); LONG_NAME = 'rate_of_spurious_land_water_source'; UNITS = 'kg m-2 s-1' - case ('SPSNOW'); LONG_NAME = 'rate_of_spurious_snow_energy'; UNITS = 'W m-2' - case ('PEATCLSM_WATERLEVEL');LONG_NAME = 'depth_to_water_table_from_surface_in_peat'; UNITS = 'm' - case ('PEATCLSM_FSWCHANGE'); LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat'; UNITS = 'kg m-2 s-1' - case ('CNLAI'); LONG_NAME = 'CN_exposed_leaf-area_index'; UNITS = '1' - case ('CNTLAI'); LONG_NAME = 'CN_total_leaf-area_index'; UNITS = '1' - case ('CNSAI'); LONG_NAME = 'CN_exposed_stem-area_index'; UNITS = '1' - case ('CNTOTC'); LONG_NAME = 'CN_total_carbon'; UNITS = 'kg m-2' - case ('CNVEGC'); LONG_NAME = 'CN_total_vegetation_carbon'; UNITS = 'kg m-2' - case ('CNROOT'); LONG_NAME = 'CN_total_root_carbon'; UNITS = 'kg m-2' - case ('CNNPP'); LONG_NAME = 'CN_net_primary_production'; UNITS = 'kg m-2 s-1' - case ('CNGPP'); LONG_NAME = 'CN_gross_primary_production'; UNITS = 'kg m-2 s-1' - case ('CNSR'); LONG_NAME = 'CN_total_soil_respiration'; UNITS = 'kg m-2 s-1' - case ('CNNEE'); LONG_NAME = 'CN_net_ecosystem_exchange'; UNITS = 'kg m-2 s-1' - case ('CNXSMR'); LONG_NAME = 'abstract_C_pool_to_meet_excess_MR_demand'; UNITS = 'kg m-2' - case ('CNADD'); LONG_NAME = 'CN_added_to_maintain_positive_C'; UNITS = 'kg m-2 s-1' - case ('PARABS'); LONG_NAME = 'absorbed_PAR'; UNITS = 'W m-2' - case ('PARINC'); LONG_NAME = 'incident_PAR'; UNITS = 'W m-2' - case ('SCSAT'); LONG_NAME = 'saturated_stomatal_conductance'; UNITS = 'm s-1' - case ('SCUNS'); LONG_NAME = 'unstressed_stomatal_conductance'; UNITS = 'm s-1' - case ('BTRAN'); LONG_NAME = 'transpiration coefficient'; UNITS = '1' - case ('SIF'); LONG_NAME = 'solar induced fluorescence'; UNITS = 'umol m-2 sm s-1' - case ('CLOSS'); LONG_NAME = 'CN_carbon_loss_to_fire'; UNITS = 'kg m-2 s-1' - case ('BURN'); LONG_NAME = 'CN_fractional_area_burn_rate'; UNITS = 's-1' - case ('FSEL'); LONG_NAME = 'fire season length'; UNITS = 'days' - case ('EVPSNO'); LONG_NAME = 'snowpack_evaporation_energy_flux'; UNITS = 'W m-2' - case ('GHTSKIN'); LONG_NAME = 'Ground_heating_skin_temp'; UNITS = 'W m-2' - case ('WAT10CM'); LONG_NAME = 'soil moisture in Upper 10cm'; UNITS = 'kg m-2' - case ('WATSOI'); LONG_NAME = 'totoal soil moisture'; UNITS = 'kg m-2' - case ('ICESOI'); LONG_NAME = 'soil frozen water content'; UNITS = 'kg m-2' - case ('RMELTDU001'); LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_1'; UNITS = 'kg m-2 s-1' - case ('RMELTDU002'); LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_2'; UNITS = 'kg m-2 s-1' - case ('RMELTDU003'); LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_3'; UNITS = 'kg m-2 s-1' - case ('RMELTDU004'); LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_4'; UNITS = 'kg m-2 s-1' - case ('RMELTDU005'); LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_5'; UNITS = 'kg m-2 s-1' - case ('RMELTBC001'); LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_1'; UNITS = 'kg m-2 s-1' - case ('RMELTBC002'); LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_2'; UNITS = 'kg m-2 s-1' - case ('RMELTOC001'); LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_1'; UNITS = 'kg m-2 s-1' - case ('RMELTOC002'); LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_2'; UNITS = 'kg m-2 s-1' - - ! land assimilation increments for Catchment prognostic variables in coupled land-atmosphere DAS (#sqz 2020-01) - - case ('TCFSAT_INCR'); LONG_NAME = 'increment_canopy_temperature_saturated_zone'; UNITS = 'K' - case ('TCFTRN_INCR'); LONG_NAME = 'increment_canopy_temperature_transition_zone'; UNITS = 'K' - case ('TCFWLT_INCR'); LONG_NAME = 'increment_canopy_temperature_wilting_zone'; UNITS = 'K' - case ('QCFSAT_INCR'); LONG_NAME = 'increment_canopy_specific_humidity_saturated_zone'; UNITS = 'kg kg-1' - case ('QCFTRN_INCR'); LONG_NAME = 'increment_canopy_specific_humidity_transition_zone'; UNITS = 'kg kg-1' - case ('QCFWLT_INCR'); LONG_NAME = 'increment_canopy_specific_humidity_wilting_zone'; UNITS = 'kg kg-1' - case ('CAPAC_INCR'); LONG_NAME = 'increment_interception_reservoir_capac'; UNITS = 'kg m-2' - case ('CATDEF_INCR'); LONG_NAME = 'increment_catchment_deficit'; UNITS = 'kg m-2' - case ('RZEXC_INCR'); LONG_NAME = 'increment_root_zone_excess'; UNITS = 'kg m-2' - case ('SRFEXC_INCR'); LONG_NAME = 'increment_surface_excess'; UNITS = 'kg m-2' - case ('GHTCNT1_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_1'; UNITS = 'J m-2' - case ('GHTCNT2_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_2'; UNITS = 'J m-2' - case ('GHTCNT3_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_3'; UNITS = 'J m-2' - case ('GHTCNT4_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_4'; UNITS = 'J m-2' - case ('GHTCNT5_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_5'; UNITS = 'J m-2' - case ('GHTCNT6_INCR'); LONG_NAME = 'increment_soil_heat_content_layer_6'; UNITS = 'J m-2' - case ('WESNN1_INCR'); LONG_NAME = 'increment_snow_mass_layer_1'; UNITS = 'kg m-2' - case ('WESNN2_INCR'); LONG_NAME = 'increment_snow_mass_layer_2'; UNITS = 'kg m-2' - case ('WESNN3_INCR'); LONG_NAME = 'increment_snow_mass_layer_3'; UNITS = 'kg m-2' - case ('HTSNNN1_INCR'); LONG_NAME = 'increment_heat_content_snow_layer_1'; UNITS = 'J m-2' - case ('HTSNNN2_INCR'); LONG_NAME = 'increment_heat_content_snow_layer_2'; UNITS = 'J m-2' - case ('HTSNNN3_INCR'); LONG_NAME = 'increment_heat_content_snow_layer_3'; UNITS = 'J m-2' - case ('SNDZN1_INCR'); LONG_NAME = 'increment_snow_depth_layer_1'; UNITS = 'm' - case ('SNDZN2_INCR'); LONG_NAME = 'increment_snow_depth_layer_2'; UNITS = 'm' - case ('SNDZN3_INCR'); LONG_NAME = 'increment_snow_depth_layer_3'; UNITS = 'm' - - ! land assimilation forecast and analysis for Catchment model diagnostics - - case ('SFMC_FCST'); LONG_NAME = 'soil_moisture_surface_forecast'; UNITS = 'm3 m-3' - case ('RZMC_FCST'); LONG_NAME = 'soil_moisture_rootzone_forecast'; UNITS = 'm3 m-3' - case ('PRMC_FCST'); LONG_NAME = 'soil_moisture_profile_forecast'; UNITS = 'm3 m-3' - case ('TSURF_FCST'); LONG_NAME = 'ave_catchment_temp_incl_snw_forecast'; UNITS = 'K' - case ('TSOIL1_FCST'); LONG_NAME = 'soil_temperatures_layer_1_forecast'; UNITS = 'K' - - case ('SFMC_FCST_ENSSTD'); LONG_NAME = 'soil_moisture_surface_forecast_ensstd'; UNITS = 'm3 m-3' - case ('RZMC_FCST_ENSSTD'); LONG_NAME = 'soil_moisture_rootzone_forecast_ensstd'; UNITS = 'm3 m-3' - case ('PRMC_FCST_ENSSTD'); LONG_NAME = 'soil_moisture_profile_forecast_ensstd'; UNITS = 'm3 m-3' - case ('TSURF_FCST_ENSSTD'); LONG_NAME = 'ave_catchment_temp_incl_snw_forecast_ensstd'; UNITS = 'K' - case ('TSOIL1_FCST_ENSSTD'); LONG_NAME = 'soil_temperatures_layer_1_forecast_ensstd'; UNITS = 'K' - - case ('SFMC_ANA'); LONG_NAME = 'soil_moisture_surface_analysis'; UNITS = 'm3 m-3' - case ('RZMC_ANA'); LONG_NAME = 'soil_moisture_rootzone_analysis'; UNITS = 'm3 m-3' - case ('PRMC_ANA'); LONG_NAME = 'soil_moisture_profile_analysis'; UNITS = 'm3 m-3' - case ('TSURF_ANA'); LONG_NAME = 'ave_catchment_temp_incl_snw_analysis'; UNITS = 'K' - case ('TSOIL1_ANA'); LONG_NAME = 'soil_temperatures_layer_1_analysis'; UNITS = 'K' - - case ('SFMC_ANA_ENSSTD'); LONG_NAME = 'soil_moisture_surface_analysis_ensstd'; UNITS = 'm3 m-3' - case ('RZMC_ANA_ENSSTD'); LONG_NAME = 'soil_moisture_rootzone_analysis_ensstd'; UNITS = 'm3 m-3' - case ('PRMC_ANA_ENSSTD'); LONG_NAME = 'soil_moisture_profile_analysis_ensstd'; UNITS = 'm3 m-3' - case ('TSURF_ANA_ENSSTD'); LONG_NAME = 'ave_catchment_temp_incl_snw_analysis_ensstd'; UNITS = 'K' - case ('TSOIL1_ANA_ENSSTD'); LONG_NAME = 'soil_temperatures_layer_1_analysis_ensstd'; UNITS = 'K' - - ! other land assimilation fields - - case ('MWRTM_VEGOPACITY'); LONG_NAME = 'Lband_microwave_vegopacity_normalized_with_cos_inc_angle'; UNITS = '1' - - ! default LONG_NAME and UNITS for nc4 files created by tile_bin2nc4.F90 (used for any SHORT_NAME not listed above): - - case default; LONG_NAME = 'not defined in tile_bin2nc4.F90'; UNITS = 'not defined in tile_bin2nc4.F90'; - - end select - - if (present(LNAME)) str_atr = trim (LONG_NAME) - if (present(UNT)) str_atr = trim (UNITS ) - - END FUNCTION getAttribute - -END PROGRAM tile_bin2nc4 diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m deleted file mode 100644 index c35942da..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/Create_ccorr_cat_progn_default.m +++ /dev/null @@ -1,57 +0,0 @@ - -% create string array to initialize ccorr_cat_progn in default namelist file -% -% reichle, 1 Jun 2005 -% reichle, 6 Dec 2013 - updated for new "progn_pert_type" - -sm={ -'catdef' -'rzexc' -'srfexc' -'snow' -'tc' -'ght(1)' -'ght(2)' -'ght(3)' -'ght(4)' -'ght(5)' -'ght(6)' } - -k=0; - -for i=1:length(sm) - for j=(i+1):length(sm) - - k=k+1; - - tmpstr = [ 'ccorr_progn_pert%', sm{i}, '%', sm{j}]; - - os{k} = tmpstr; - - es{k} = ' = 0.'; - - if (j==25) - - k=k+1; - - os{k} = ''; - es{k} = ''; - - end - - end -end - -sa = [ char(os) char(es) ]; - -diary tmp.txt - -disp(sa) - -diary off - -% ========= EOF ==================================== - - - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py deleted file mode 100755 index a6926450..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py +++ /dev/null @@ -1,121 +0,0 @@ -#!/usr/bin/env python -# -# This code works with the python version loaded by g5_modules associated with GEOSldas v17.13.1: -# python/GEOSpyD/Min4.11.0_py3.9_AND_Min4.8.3_py2.7 -# -# This script generates a sample HISTORY.rc file for GEOSldas to write Catchment -# model analysis increments in ensemble space, as needed in the weakly-coupled -# Hybrid-4DEnVar land-atm DAS (LADAS). - -import os -import glob -import subprocess as sp - -# ------------------------------------------------------------------ -# -# specify number of ensemble members here: - -nens = 32 - -# ------------------------------------------------------------------ -# -# some definitions of text elements in HISTORY.rc file - -heads = """ -# -# Sample GEOSldas HISTORY.rc file for LADAS (atm ensemble) -# -# - This sample HISTORY.rc is for the GEOSldas instance that is weakly coupled with the -# atmospheric ensemble component of the Hybrid-4DEnVar ADAS (ADASens). -# -# - The sample file was generated with the utility script -# "GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/generate_catchincr_hist.py". -# -# - The sample file triggers output of the GEOSldas "catch_progn_incr" collection in -# ensemble space, which is needed by ADASens. -# -# - The IDs of the ensemble members and their total number in GEOSldas must match -# those of ADASens. -# -# - The "catch_progn_incr" output is in tile space, which must be the same for -# GEOSldas and ADASens. -# -# -################################################################################## - -EXPID: MyGEOSldasAtmEns - -COLLECTIONS: -""" - -label = """ -:: -""" - -hist_template = """ -'catch_progn_incr' -:: -descr: 'Tile-space,3-Hourly,Instantaneous,Single-Level,Assimilation, Land Prognostics Increments', -template: '%y4%m2%d2_%h2%n2z.bin', -mode: 'instantaneous', -frequency: 030000, -ref_time: 013000, -fields: 'TCFSAT_INCR' , 'CATCHINCR_e' , - 'TCFTRN_INCR' , 'CATCHINCR_e' , - 'TCFWLT_INCR' , 'CATCHINCR_e' , - 'QCFSAT_INCR' , 'CATCHINCR_e' , - 'QCFTRN_INCR' , 'CATCHINCR_e' , - 'QCFWLT_INCR' , 'CATCHINCR_e' , - 'CAPAC_INCR' , 'CATCHINCR_e' , - 'CATDEF_INCR' , 'CATCHINCR_e' , - 'RZEXC_INCR' , 'CATCHINCR_e' , - 'SRFEXC_INCR' , 'CATCHINCR_e' , - 'GHTCNT1_INCR' , 'CATCHINCR_e' , - 'GHTCNT2_INCR' , 'CATCHINCR_e' , - 'GHTCNT3_INCR' , 'CATCHINCR_e' , - 'GHTCNT4_INCR' , 'CATCHINCR_e' , - 'GHTCNT5_INCR' , 'CATCHINCR_e' , - 'GHTCNT6_INCR' , 'CATCHINCR_e' , - 'WESNN1_INCR' , 'CATCHINCR_e' , - 'WESNN2_INCR' , 'CATCHINCR_e' , - 'WESNN3_INCR' , 'CATCHINCR_e' , - 'HTSNNN1_INCR' , 'CATCHINCR_e' , - 'HTSNNN2_INCR' , 'CATCHINCR_e' , - 'HTSNNN3_INCR' , 'CATCHINCR_e' , - 'SNDZN1_INCR' , 'CATCHINCR_e' , - 'SNDZN2_INCR' , 'CATCHINCR_e' , - 'SNDZN3_INCR' , 'CATCHINCR_e' , -""" - -# ------------------------------------------------------------------ -# -# write file "HISTORY.rc" with nens "catch_progn_incrXXXX" collections, -# one for each ensemble member - -with open('HISTORY.rc', 'w') as f: - f.write(heads) - collection, body = hist_template.split('::\n') - collection = collection.strip('\n').strip("'") - for i in range(nens): - i = i +1 - sfx = '%04d'%(i) - ids = "'"+collection+sfx+"'" - f.write(ids+'\n') - f.write(label) - lines = body.split('\n') - for i in range(nens): - i = i+1 - sfx = '%04d'%(i) - collect= collection+sfx+"." - for line in lines: - newline = line - if ":" in line : - newline = collect+line - if "CATCHINCR_e" in newline: - sfx = '%04d'%(i) - frep = 'CATCHINCR_e'+sfx - newline = newline.replace('CATCHINCR_e',frep) - f.write(newline+'\n') - f.write('::\n') - -# ====================== EOF ===================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh deleted file mode 100755 index a52a1951..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/config/rewind_GEOSldas.csh +++ /dev/null @@ -1,117 +0,0 @@ -#!/bin/csh - -# rewind existing GEOSldas run to specified date/time - -setenv MYNAME rewind_GEOSldas.csh - -if ( $#argv < 4 ) then - echo " " - echo " NAME " - echo " " - echo " $MYNAME - rewind existing GEOSldas run to restart time of nymd nhms" - echo " " - echo " SYNOPSIS " - echo " " - echo " $MYNAME nymd nhms expid exppath " - echo " " - echo " where " - echo " nymd - restart date, as YYYYMMDD " - echo " time - restart time, as HHMMSS " - echo " expid - experiment name, e.g., ldas4coup " - echo " exppath - run directory path, e.g., /discover/nobackup/[user]/ " - echo " " - echo " DESCRIPTION " - echo " " - echo " This procedure rewinds and resets the GEOSldas experiment " - echo " specified by expid and exppath to the restart date/time " - echo " specified by nymd and nhms. " - echo " " - echo " Example of valid command line: " - echo " $MYNAME 20170829 210000 ldas4coup /discover/nobackup/qzhang " - exit(0) -endif - -set nymd = $1 -set nhms = $2 - -echo " ymd = $nymd " -echo " hms = $nhms " - -set yin = `echo $nymd | cut -c1-4` -set min = `echo $nymd | cut -c5-6` -set hin = `echo $nhms | cut -c1-4` - -set date = ${nymd}_${hin} - -set expid = $3 -set rundir = $4 -echo " expid = $expid " - -cd ${rundir}/${expid}/run -set nmem = `grep NUM_LDAS_ENSEMBLE: LDAS.rc | cut -d':' -f2` -cd ${rundir}/${expid} -set grid = `ls output` - -## rewind links to restart files - -@ NENS = $nmem - -set rsout = ${rundir}/${expid}/output/${grid}/rs -set rstin = ${rundir}/${expid}/input/restart -cd $rstin - -/bin/rm -rf catch*_internal_rst -/bin/rm -rf landpert*_internal_rst -/bin/rm -rf landassim_obspertrseed*_rst - -@ inens = 1 - -while ($inens <= $NENS) - - if ($inens < 10) then - set ENSDIR = `echo ens000${inens}` - set catin = `echo catch000${inens}` - set pertin = `echo landpert000${inens}` - set seedin = `echo obspertrseed000${inens}` - else if($inens < 100) then - set ENSDIR = `echo ens00${inens}` - set catin = `echo catch00${inens}` - set pertin = `echo landpert00${inens}` - set seedin = `echo obspertrseed00${inens}` - else if($inens < 1000) then - set ENSDIR = `echo ens0${inens}` - set catin = `echo catch0${inens}` - set pertin = `echo landpert0${inens}` - set seedin = `echo obspertrseed0${inens}` - else - set ENSDIR = `echo ens${inens}` - set catin = `echo catch${inens}` - set pertin = `echo landpert${inens}` - set seedin = `echo obspertrseed${inens}` - endif - - /bin/ln -s ${rsout}/${ENSDIR}/Y${yin}/M${min}/${expid}.catch_internal_rst.${date} ${catin}_internal_rst - - if (-e ${rsout}/${ENSDIR}/Y${yin}/M${min}/${expid}.landpert_internal_rst.${date}.gz ) then - gunzip ${rsout}/${ENSDIR}/Y${yin}/M${min}/${expid}.landpert_internal_rst.${date}.gz - endif - - /bin/ln -s ${rsout}/${ENSDIR}/Y${yin}/M${min}/${expid}.landpert_internal_rst.${date} ${pertin}_internal_rst - - /bin/ln -s ${rsout}/${ENSDIR}/Y${yin}/M${min}/${expid}.landassim_obspertrseed_rst.${date} landassim_${seedin}_rst - - @ inens ++ -end - -## -- remove records in rc_out -cd ${rundir}/${expid}/output/${grid}/rc_out/Y${yin}/M${min} -/bin/rm -rf *smapL4*${date}z.bin -/bin/rm -rf *.${date}z.txt -/bin/rm -rf *.${date}z.nml - -## -- reset cap_restart -cd ${rundir}/${expid}/run -/bin/rm -rf cap_restart -echo $nymd ${nhms} > cap_restart - -## EOF #################################################################### diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt deleted file mode 100644 index 11114b07..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/CMakeLists.txt +++ /dev/null @@ -1,4 +0,0 @@ -# build without installation - -add_executable(ascat_mask_maker.x ascat_mask_maker.F90) -target_link_libraries(ascat_mask_maker.x MAPL) diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 deleted file mode 100644 index e9b4bbd0..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/ASCAT_sm_mask/ascat_mask_maker.F90 +++ /dev/null @@ -1,242 +0,0 @@ -! This program produces a combined mask for use with the assimilation of ASCAT soil moisture retrievals in GEOSldas. -! The combined mask is based on component masks from: -! -! Lindorfer, R., Wagner, W., Hahn, S., Kim, H., Vreugdenhil, M., Gruber, A., Fischer, M., & Trnka, M. (2023). -! Global Scale Maps of Subsurface Scattering Signals Impacting ASCAT Soil Moisture Retrievals (1.0.0) [Data set]. -! TU Wien. https://doi.org/10.48436/9a2y9-e5z14 -! -! The program provides the possibility to combine different masks (default is combination of subsurface and wetland masks) -! and interpolates onto a regular grid with a (hardwired) 0.1 degree lat/lon spacing and -90/-180 degree lower left -! corner used for quick indexing in the ASCAT observation reader QC routine. -! -! Author: AM Fox, March, 2024 - -program ascat_mask_maker - - use netcdf - - implicit none - - integer :: ncid, varid, dimid, ierr, len, N_gpi, dimids(2), N_lon, N_lat - integer :: i, j, closest_index, mask_mode - integer, dimension(:), allocatable :: cold_mask, wet_mask, veg_mask, subsurface_mask, combined_mask - - integer(kind=1), dimension(:,:), allocatable :: mask_out - integer(kind=1) :: missing_value - - real, dimension(:), allocatable :: asc_lon, asc_lat - real, dimension(:), allocatable :: lon, lat, distances - real :: d_lon, d_lat, ll_lon, ll_lat - - character(200) :: fname_in, mask_description, fname_out - - ! -------------------------------------------------------------------------------- - ! - ! hardwired variables - - ! ASCAT soil moisture mask file from Lindorfer et al 2023 - - fname_in = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/ASCAT_EUMETSAT/Mask/subsurface_scattering_ASCAT_ERA5_Land.nc' - - ! Specification of how to combine the masks - ! Mask_mode = 1 (default) combines subsurface and wetland masks - ! Mask_mode = 2 uses only the subsurface mask - ! Mask_mode = 3 uses only the wetland mask - ! Mask_mode = 4 combines subsurface, wetland and vegetation masks - - mask_mode = 1 - - ! Specification of output grid and missing value - - d_lon = 0.1 - d_lat = 0.1 - ll_lon = -180.0 ! longitude of boundary of lower-left grid cell (longitude of lower left corner of grid) - ll_lat = -90.0 ! latitude of boundary of lower-left grid cell (latitude of lower left corner of grid) - - missing_value = -128 - - ! Specify the NetCDF file name for the output mask - - fname_out = 'ascat_combined_mask_p1.nc' - - ! ------------------------------- - - ! Open the NetCDF input file - ierr = nf90_open(fname_in, nf90_nowrite, ncid) - if (ierr /= nf90_noerr) stop 'Error opening file: ' // trim(fname_in) - - ! Data in original mask file are on the 12.5 km fixed Earth grid used for ASCAT (WARP5 grid) and - ! stored in the NetCDF file as 1-dimensional arrays of length N_gpi (over land only). - - ! Get the dimension ID - ierr = nf90_inq_dimid(ncid, 'gpi', dimid) - if (ierr /= nf90_noerr) stop 'Error getting dimension ID' - - ! Get the length of the dimension - ierr = nf90_inquire_dimension(ncid, dimid, len = N_gpi) - if (ierr /= nf90_noerr) stop 'Error inquiring dimension' - - print*, 'N_gpi = ', N_gpi - - ! Allocate the arrays - allocate(asc_lon( N_gpi)) - allocate(asc_lat( N_gpi)) - allocate(cold_mask( N_gpi)) - allocate(wet_mask( N_gpi)) - allocate(veg_mask( N_gpi)) - allocate(subsurface_mask(N_gpi)) - allocate(combined_mask( N_gpi)) - allocate(distances( N_gpi)) - - ! Get the variable IDs and read the variables - ierr = nf90_inq_varid(ncid, 'lon', varid) - ierr = nf90_get_var(ncid, varid, asc_lon) - ierr = nf90_inq_varid(ncid, 'lat', varid) - ierr = nf90_get_var(ncid, varid, asc_lat) - ierr = nf90_inq_varid(ncid, 'cold_mask', varid) - ierr = nf90_get_var(ncid, varid, cold_mask) - ierr = nf90_inq_varid(ncid, 'wet_mask', varid) - ierr = nf90_get_var(ncid, varid, wet_mask) - ierr = nf90_inq_varid(ncid, 'veg_mask', varid) - ierr = nf90_get_var(ncid, varid, veg_mask) - ierr = nf90_inq_varid(ncid, 'subsurface_mask', varid) - ierr = nf90_get_var(ncid, varid, subsurface_mask) - - ! Close the NetCDF file - ierr = nf90_close(ncid) - if (ierr /= nf90_noerr) stop 'Error closing file' - - ! Combine the masks (1-dim arrays) - select case (mask_mode) - case (1) - ! Combine wet_mask and subsurface_mask - mask_description = 'Combined subsurface and wetland mask' - where (wet_mask /= 0) - combined_mask = 1 - elsewhere - combined_mask = subsurface_mask - end where - case (2) - ! Use only subsurface_mask - mask_description = 'Used only subsurface mask' - combined_mask = subsurface_mask - case (3) - ! Use only wet_mask - mask_description = 'Used only wetland mask' - combined_mask = wet_mask - case (4) - ! Combine subsurface_mask, wet_mask, and veg_mask - mask_description = 'Combined subsurface, wetland, and vegetation mask' - where (wet_mask /= 0 .or. veg_mask /= 0) - combined_mask = 1 - elsewhere - combined_mask = subsurface_mask - end where - end select - - ! Re-map "combined_mask" from WARP5 input grid to regular lat/lon output grid (2-dim array) - - N_lon = nint( 360.0 / d_lon ) - N_lat = nint( 180.0 / d_lat ) - - allocate(lon(N_lon)) - allocate(lat(N_lat)) - - lon = [((ll_lon + (d_lon / 2)) + i * d_lon, i = 0, N_lon - 1)] ! NB using grid cell centers for nearest neighbor search - lat = [((ll_lat + (d_lat / 2)) + i * d_lat, i = 0, N_lat - 1)] - - allocate(mask_out( N_lon, N_lat)) - - do i = 1, N_lon - print*, lon(i) - do j = 1, N_lat - distances = (asc_lon - lon(i))**2 + (asc_lat - lat(j))**2 - closest_index = minloc(distances, dim = 1) - if (distances(closest_index) > 0.14**2) then - mask_out(i, j) = missing_value ! Note: ASCAT EUMETSAT reader masks everything .ne. 0 - else - mask_out(i, j) = combined_mask(closest_index) - end if - end do - end do - - ! Write out the mask to netcdf - ierr = nf90_create(fname_out, nf90_clobber, ncid) - if (ierr /= nf90_noerr) stop 'Error creating file: ' // fname_out - - ! Define the dimensions - ierr = nf90_def_dim(ncid, 'lon', N_lon, dimids(1)) - ierr = nf90_def_dim(ncid, 'lat', N_lat, dimids(2)) - - ! Define the global attributes - ierr = nf90_put_att(ncid, nf90_global, 'title', 'ASCAT combined mask') - ierr = nf90_put_att(ncid, nf90_global, 'source', 'Lindorfer et al 2023 doi:10.48436/9a2y9-e5z14') - ierr = nf90_put_att(ncid, nf90_global, 'description', mask_description) - - ! Define the variables - ierr = nf90_def_var(ncid, 'lat', nf90_real, dimids(2), varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'latitude') - ierr = nf90_put_att(ncid, varid, 'long_name', 'grid cell center latitude') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees_north') - ierr = nf90_put_att(ncid, varid, 'axis', 'Y') - - ierr = nf90_def_var(ncid, 'lon', nf90_real, dimids(1), varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'longitude') - ierr = nf90_put_att(ncid, varid, 'long_name', 'grid cell center longitude') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees_east') - ierr = nf90_put_att(ncid, varid, 'axis', 'X') - - ierr = nf90_def_var(ncid, 'mask', nf90_byte, dimids, varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'combined_mask') - ierr = nf90_put_att(ncid, varid, 'long_name', 'combined mask') - ierr = nf90_put_att(ncid, varid, 'units', 'boolean') - ierr = nf90_put_att(ncid, varid, '_FillValue', missing_value) - - ierr = nf90_def_var(ncid, 'll_lon', nf90_real, varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'longitude of lower left corner') - ierr = nf90_put_att(ncid, varid, 'long_name', 'longitude of lower left corner') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees_east') - ierr = nf90_put_att(ncid, varid, 'axis', 'X') - - ierr = nf90_def_var(ncid, 'll_lat', nf90_real, varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'latitude of lower left corner') - ierr = nf90_put_att(ncid, varid, 'long_name', 'latitude of lower left corner') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees_north') - ierr = nf90_put_att(ncid, varid, 'axis', 'Y') - - ierr = nf90_def_var(ncid, 'd_lon', nf90_real, varid) - ierr = nf90_put_att(ncid, varid, 'standard_name', 'longitude grid spacing') - ierr = nf90_put_att(ncid, varid, 'long_name', 'longitude grid spacing') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees') - ierr = nf90_put_att(ncid, varid, 'axis', 'X') - - ierr = nf90_def_var(ncid, 'd_lat', nf90_real, varid) - ierr = nf90_put_att(ncid, varid, 'long_name', 'latitude grid spacing') - ierr = nf90_put_att(ncid, varid, 'units', 'degrees') - ierr = nf90_put_att(ncid, varid, 'axis', 'Y') - - ! End define mode - ierr = nf90_enddef(ncid) - - ! Write the variables - ierr = nf90_inq_varid(ncid, 'lat', varid) - ierr = nf90_put_var(ncid, varid, lat) - ierr = nf90_inq_varid(ncid, 'lon', varid) - ierr = nf90_put_var(ncid, varid, lon) - ierr = nf90_inq_varid(ncid, 'mask', varid) - ierr = nf90_put_var(ncid, varid, mask_out) - if (ierr /= nf90_noerr) stop 'Error writing variable' - ierr = nf90_inq_varid(ncid, 'll_lon', varid) - ierr = nf90_put_var(ncid, varid, ll_lon) - ierr = nf90_inq_varid(ncid, 'll_lat', varid) - ierr = nf90_put_var(ncid, varid, ll_lat) - ierr = nf90_inq_varid(ncid, 'd_lon', varid) - ierr = nf90_put_var(ncid, varid, d_lon) - ierr = nf90_inq_varid(ncid, 'd_lat', varid) - ierr = nf90_put_var(ncid, varid, d_lat) - - ! Close the NetCDF file - ierr = nf90_close(ncid) - if (ierr /= nf90_noerr) stop 'Error closing file' - -end program ascat_mask_maker diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m deleted file mode 100644 index a478214b..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_mwRTM_param_file.m +++ /dev/null @@ -1,240 +0,0 @@ -% --------------------------------------------------------------------------- -% This script is to generate the mwRTM_param.nc4 file for the GEOSldas mwRTM. -% All constant mwRTM parameters are in this file. They come from 3 different -% sources: cat_param, vegcls lookup table and preprocessed L2DCA daily mat files. -% Therefore, need to run Preprocess_L2DCA_mwRTM_into_dailymat.m before running -% this script. - -% qliu + rreichle, 29 Jul 2022 - -% ---------------------------------------------------------------------------- - -clear - -% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ -addpath('../../shared/matlab/'); - -% option to fill small gaps based on neighboring grids, 1 is recommended. -fill_small_gaps = 1; - -% fill value in output file -fillValue = single(1.e15); - -% resolution of output parameters: only works with "M09" or "M36". -EASEv2_grid = 'M09'; - -% older version mwRTM_param.nc4 file for parameter names and attributes -fname_in = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_SMAP_L4SM_v004/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param.nc4']; - -% target mwRTM_param file name -fname_out = ['/home/qliu/smap/SMAP_Nature/bcs/RTM_params/RTMParam_L2_omega_H_tmp/SMAP_EASEv2_',EASEv2_grid,'/mwRTM_param_L2_omega_H_fillValue_bhbvlewt.nc4']; - -% get inputs for fill_gaps_in_tiledata() below -if fill_small_gaps - - if strcmp(EASEv2_grid,'M09') - N_cells = 5; - iscube = 0; - elseif strcmp(EASEv2_grid,'M36') - N_cells = 3; - iscube = 0; - else - error('invalid resolution, use ''M09'' or ''M36'' only') - end - - tmpstr = num2str(N_cells); - - fname_out = strrep(fname_out,'.nc4','_',tmpstr,'gx',tmpstr,'gfilled.nc4'); -end - -% Do not overwrite if file exists -if exist(fname_out,'file') - - disp(['file exist ',fname_out]) - return - -end - -% GEOSldas experiment for tilecoord and cat_params -exp_path = '/home/qliu/smap/SMAP_Nature/SMAP_Nature_v10/'; - -if strcmp(EASEv2_grid,'M09') - exp_run = 'SMAP_Nature_v10.0'; - domain = 'SMAP_EASEv2_M09_GLOBAL'; -else - exp_run = 'SMAP_Nature_v10.0_M36'; - domain = 'SMAP_EASEv2_M36_GLOBAL'; -end - -fname_tc = [exp_path,exp_run,'/output/',domain,'/rc_out/',exp_run,'.ldas_tilecoord.bin']; -fname_tg = [exp_path,exp_run,'/output/',domain,'/rc_out/',exp_run,'.ldas_tilegrids.bin']; -fname_catparam = [exp_path,exp_run,'/output/',domain,'/rc_out/Y2015/M04/',exp_run,'.ldas_catparam.20150401_0000z.bin']; - -% If use L4 products in /css/smapl4/ -if ~exist(fname_tc, 'file') - fname_tc = [exp_path,exp_run,'/rc_out/',exp_run,'.ldas_tilecoord.bin']; - fname_tg = [exp_path,exp_run,'/rc_out/',exp_run,'.ldas_tilegrids.bin']; - fname_catparam = [exp_path,exp_run,'/rc_out/Y2015/M04/',exp_run,'.ldas_catparam.20150401_0000z.bin']; -end - -tc = read_tilecoord(fname_tc); - -% double check for tile order, may not work if exp_run uses older bcs -% version -if max(abs(transpose([1:tc.N_tile])-tc.tile_id)) > 0 - error('tile order is not strictly tile_id ascending, need to modify script to reorder') - return -end - -tg = read_tilegrids(fname_tg); -cat_param = read_catparam(fname_catparam, tc.N_tile); - -% L2RTM parameter source information -L2_version = 'R18290'; -L2_start_time.year = 2015; L2_start_time.month = 4; L2_start_time.day = 1; -L2_end_time.year = 2022; L2_end_time.month = 4; L2_end_time.day = 1; - -if strcmp(EASEv2_grid,'M36') - L2_file_tag = 'L2_SM_P'; -else - L2_file_tag = 'L2_SM_P_E'; -end - -% L2DCA based parameters -L2_param = get_L2_RTM_constants_tile_data(tc,L2_file_tag,... - L2_version,L2_start_time, L2_end_time); -omega = L2_param.Albedo; -hparam = L2_param.Roughness; -clear L2_param - -% cat_param based parameters -mwRTMparam.soilcls = int32(cat_param.soilcls30); -mwRTMparam.sand = cat_param.sand30/100.; -mwRTMparam.clay = cat_param.clay30/100.; - -% there are 0 values in poros30 for unknown reasons, set 0 to next minimum -% value (0.3741) -mwRTMparam.poros = max(0.3741, cat_param.poros30); -mwRTMparam.wang_wp = cat_param.wpwet30 .* cat_param.poros30; -mwRTMparam.wang_wt = 0.49*mwRTMparam.wang_wp + 0.165; -mwRTMparam.rgh_wmin = mwRTMparam.wang_wt; -mwRTMparam.rgh_wmax = mwRTMparam.poros; - -% Initialize the input and output file interface - -netcdf.setDefaultFormat('FORMAT_NETCDF4'); - -fin_id = netcdf.open(fname_in, 'NOWRITE'); -fout_id = netcdf.create(fname_out, 'NETCDF4'); - -if fout_id < 0, error(['Creating ' fname_out 'failed']); end - -finfo = ncinfo(fname_in); netcdf.close(fin_id) - -% Define Dimension (tile) -Dim_id = netcdf.defDim(fout_id,'tile',tc.N_tile); - -nvar_in_file = length(finfo.Variables); - -for i=1: nvar_in_file - - data_name = finfo.Variables(i).Name; - data_type = finfo.Variables(i).Datatype; - - data_type = 'float'; - - data_size = finfo.Variables(i).Size; - - varid(i) = netcdf.defVar(fout_id, data_name, data_type, Dim_id ); - - netcdf.defVarFill(fout_id, varid(i), false, fillValue); - - n_attr = length(finfo.Variables(i).Attributes); - - for iv = 1:n_attr - att_name = finfo.Variables(i).Attributes(iv).Name; - att_value = finfo.Variables(i).Attributes(iv).Value; - - netcdf.putAtt(fout_id, varid(i), att_name, att_value); - end - - netcdf.endDef(fout_id); - - startVAR = repmat([0], 1, length(data_size)); - countVAR = data_size; - - % get parameter values from their respective sources - % Total of 18 mwRTM parameters: - % 8 from cat_param: SOILCLS, SOIL, CLAY, POROS, WANGWT, WANTWP, RGHWMIN, RGHWMAX - % 4 from vegcls lookup table : VEGCLS, RGHNRH, RGHNRV,POLMIX - % 3 from L2RTM: RGHHMIN, RGHHMAX, OMEGA - % 3 are set to fillValue: BH,BV, OMEGA - - if strcmp(data_name,'MWRTM_OMEGA') - if fill_small_gaps - omega_filled = fill_gaps_in_tiledata(tc, tg, transpose(omega), N_cells, iscube ); - data = omega_filled; - else - data = omega; - end - elseif contains(data_name, 'MWRTM_RGHHM') - if fill_small_gaps - hparam_filled = = fill_gaps_in_tiledata(tc, tg, transpose(hparam), N_cells, iscube ); - data = hparam_filled; - else - data = hparam; - end - elseif strcmp(data_name,'MWRTM_SOILCLS') - data = mwRTMparam.soilcls; - elseif strcmp(data_name,'MWRTM_SAND') - data = mwRTMparam.sand; - elseif strcmp(data_name,'MWRTM_CLAY') - data = mwRTMparam.clay; - elseif strcmp(data_name,'MWRTM_POROS') - data = mwRTMparam.poros; - elseif strcmp(data_name,'MWRTM_WANGWT') - data = mwRTMparam.wang_wt; - elseif strcmp(data_name,'MWRTM_WANGWP') - data = mwRTMparam.wang_wp; - elseif strcmp(data_name,'MWRTM_RGHWMIN') - data = mwRTMparam.rgh_wmin; - elseif strcmp(data_name,'MWRTM_RGHWMAX') - data = mwRTMparam.rgh_wmax; - elseif strcmp(data_name,'MWRTM_LEWT') || contains(data_name, 'MWRTM_B') - data = fillValue .* ones(data_size,1); - else - if strcmp(EASEv2_grid,'M09') - dominant_M36vegcls = 1; - else - dominant_M36vegcls = 0; - end - tmp_rtm = get_mwRTM_vegcls_based( tc, dominant_M36vegcls,['EASEv2_',EASEv2_grid]); - if strcmp(data_name,'MWRTM_RGHNRH') - data = tmp_rtm.rgh_Nrh; - elseif strcmp(data_name,'MWRTM_RGHNRV') - data = tmp_rtm.rgh_Nrv; - elseif strcmp(data_name,'MWRTM_VEGCLS') - data = tmp_rtm.vegcls; - elseif strcmp(data_name,'MWRTM_RGHPOLMIX') - data = tmp_rtm.rgh_polmix; - end - end - - % earlier fillValue was -9999. replace with new fillValue (1.e15) - data(abs(data-(-9999.)) < abs(-9999.*1e-4)) = NaN; - - data(isnan(data)) = fillValue; - - netcdf.putVar(fout_id, varid(i), startVAR, countVAR, data); clear data - - netcdf.reDef(fout_id); - -end - -netcdf.endDef(fout_id); - -netcdf.close(fout_id); - -disp(['done writing ',fname_out]) - -% --------------------------EOF-------------------------------------------- diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m deleted file mode 100644 index 19eb1336..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Create_vegopacity_8day_clim.m +++ /dev/null @@ -1,341 +0,0 @@ -% script to create 8-day climatology of vegetation opacity for L-band microwave -% radiative transfer model (mwRTM) -% -% requires pre-processing of SMAP L2 data into daily *.mat files using -% Preprocess_L2DCA_mwRTM_params_to_dailymat.m -% -% output files written in MAPL_ReadForcing format -% -% qliu + rreichle, 29 Jul 2022 -% -% ------------------------------------------------------------------------------------- - -clear - -% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ -addpath('../../shared/matlab/'); - -L2_Ascdes_all = {'_A_','_D_'}; - -out_Para = 'VOD'; - -L2_file_tag = 'L2_SM_P'; -L2_version = 'R18290'; - -if strcmp(L2_file_tag(end-1:end),'_E') - resolution = 'M09'; -else - resolution = 'M36'; -end - -out_path = '/discover/nobackup/qliu/matlab/SMAP/L2L4/VOD/QC_frozen_RFI/'; - -fill_small_gaps = 1; - -% provide a GEOSldas simulation with matching tile information -if strcmp(resolution,'M36') - L4_path = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/SMAP_Nature_v9.x/'; - L4_version = 'SMAP_Nature_v9.1_M36'; - based_on_h5 = 0; - out_Nlon = 3856/4; - out_Nlat = 1624/4; -else - L4_path = '/css/smapl4/public/L4_Products/L4_SM/'; - L4_version = 'Vv6030'; - based_on_h5 = 1; - out_Nlon = 3856; - out_Nlat = 1624; -end - -ftilecoord = [L4_path,L4_version,'/output/SMAP_EASEv2_',resolution,'_GLOBAL/rc_out/', ... - L4_version,'.ldas_tilecoord.bin']; -ftilegrids = [L4_path,L4_version,'/output/SMAP_EASEv2_',resolution,'_GLOBAL/rc_out/', ... - L4_version,'.ldas_tilegrids.bin']; - -if ~exist(ftilecoord,'file') - ftilecoord = [L4_path,L4_version,'/rc_out/SPL4SM_', L4_version,'.ldas_tilecoord.bin']; - ftilegrids = [L4_path,L4_version,'/rc_out/SPL4SM_', L4_version,'.ldas_tilegrids.bin']; -end -% read tile info for binary output -tc = read_tilecoord( ftilecoord); -tg = read_tilegrids( ftilegrids); - -int_precision = 'int32'; -float_precision = 'float32'; - -for iAD = 1:2 - - L2_Ascdes = L2_Ascdes_all{iAD}; - L2_qc_yes = 1; - - dtstep = 10800; - - % time period for computing climatology - start_time.year = 2015; - start_time.month = 4; - start_time.day = 1; - - start_time.hour = 1; - start_time.min = 30; - start_time.sec = 0; - - end_time.year = 2022; - end_time.month = 4; - end_time.day = 1; - end_time.hour = start_time.hour; - end_time.min = start_time.min; - end_time.sec = start_time.sec; - - start_time = get_dofyr_pentad(start_time); - end_time = get_dofyr_pentad(end_time); - - % lookup table of month and day of first day in 8-day average (non-leap year) - - clim_8d_m1 = [ 1 1 1 1 2 2 2 2 ... - 3 3 3 3 4 4 4 ... - 5 5 5 5 6 6 6 6 ... - 7 7 7 7 8 8 8 8 ... - 9 9 9 9 10 10 10 ... - 11 11 11 11 12 12 12 12]; - - clim_8d_d1 = [ 1 9 17 25 2 10 18 26 ... - 6 14 22 30 7 15 23 ... - 1 9 17 25 2 10 18 26 ... - 4 12 20 28 5 13 21 29 ... - 6 14 22 30 8 16 24 ... - 1 9 17 25 3 11 19 27 ]; - - clim_8d_m2 = [clim_8d_m1(2:46) 1]; - clim_8d_d2 = [clim_8d_d1(2:46) 1]; - - % ----------------------------------------------------------------------- - % read from preprocessed daily mat file - if end_time.month ==1 - time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... - '_',num2str(end_time.year-1,'%4.4d'),'12']; - else - time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... - '_',num2str(end_time.year,'%4.4d'),num2str(end_time.month-1,'%2.2d')]; - end - - fname_clim = [out_path,'/',out_Para,'_clim_L2_',L2_version,L2_Ascdes,'8d_',resolution,'tile_',time_tag,'_w24d.bin']; - - L2_tau_clim_sum = zeros(46,out_Nlon,out_Nlat); - N_L2_clim_sum = zeros(46,out_Nlon,out_Nlat); - - if exist(fname_clim,'file') - - disp(['found preprocessed climatology file ',fname_clim]) - - else - - date_time = start_time; - - while 1 - - if (date_time.year ==end_time.year && ... - date_time.month==end_time.month && ... - date_time.day ==end_time.day ) - break - end - - outfile_tag = [num2str(date_time.year,'%4.4d'), ... - num2str(date_time.month,'%2.2d'), ... - num2str(date_time.day,'%2.2d')]; - - mat_fname = [out_path,'L2DCA_RTM_',L2_file_tag,'_',L2_version,L2_Ascdes, outfile_tag,'.mat']; - - if exist(mat_fname,'file') - - disp(['loading ', mat_fname]) - if contains(fname_clim,'VOD_') - load(mat_fname,'L2_tau') - elseif contains(fname_clim,'Albedo_') - load(mat_fname,'L2_omg') - L2_tau = L2_omg; clear L2_omg - elseif contains(fname_clim,'Roughness_') - load(mat_fname,'L2_h') - L2_tau = L2_h; clear L2_h - else - error(['unknown clim fname ',fname_clim]) - end - - d_idx = find(date_time.month == clim_8d_m1 & date_time.day >= clim_8d_d1); - if ~isempty(d_idx) - d_idx = d_idx(end); - else - d_idx = find(date_time.month == clim_8d_m2 & date_time.day < clim_8d_d2); - d_idx = d_idx(1); - end - - % compute climatology - tmp = max(L2_tau,0); % make sure no negative values in tau - tmp(isnan(tmp)) = 0; - - L2_tau_clim_sum(d_idx,:,:) = squeeze(L2_tau_clim_sum(d_idx,:,:)) + tmp; clear tmp - tmp = ~isnan(L2_tau); - N_L2_clim_sum(d_idx,:,:) = squeeze(N_L2_clim_sum(d_idx,:,:)) + tmp; clear tmp - - clear L2_tau - - else - - error('daily mat file not found') - - end - - date_time = augment_date_time(86400, date_time); - - end - - L2_tau_clim = L2_tau_clim_sum ./N_L2_clim_sum; - - - % regrid to til grid - - L2_tau_tile = NaN + ones(46, tc.N_tile); - for k = 1:tc.N_tile - L2_tau_tile(:,k) = L2_tau_clim(:,tc.i_indg(k)+1, tc.j_indg(k)+1); - end - - ifp = fopen(fname_clim,'w','l'); - - for n = 1: 48 - if n == 1 - y1 = 0; - y2 = 1; - - nidx = 46; - nidx_pre = 45; - nidx_nxt = 1; - elseif n == 2 - y1 = 1; - y2 = 1; - nidx = n-1; - nidx_pre = 46; - nidx_nxt = n; - elseif n == 47 - y1 = 1; - y2 = 2; - - nidx = n-1; - nidx_pre = n-2; - nidx_nxt = 1; - elseif n == 48 - y1 = 2; - y2 = 2; - nidx = 1; - nidx_pre = 46; - nidx_nxt = 2; - else - y1 = 1; - y2 = 1; - nidx = n-1; - nidx_pre = n-2; - nidx_nxt = n; - end - m1 = clim_8d_m1(nidx); - m2 = clim_8d_m2(nidx); - d1 = clim_8d_d1(nidx); - d2 = clim_8d_d2(nidx); - - header = [y1 m1 d1 0 0 0 y2 m2 d2 0 0 0 tc.N_tile 1]; - - tile_data = mean(L2_tau_tile([nidx_pre nidx nidx_nxt],:),1,"omitnan"); - tile_data(isnan(tile_data)) = 1.e15; - - fwrite( ifp, 14*4, int_precision ); % fortran_tag - fwrite( ifp, header, float_precision ); - fwrite( ifp, 14*4, int_precision ); % fortran_tag - - fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag - fwrite( ifp, tile_data(:), float_precision ); - fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag - - clear header tile_data - end - fclose(ifp) - end - -end - -% ======================== -% The final vegopacity.bin file contains data averaged (mean) of Asc -% and Des tau climatology. VOD is climatology,the other 2 parameters are -% time constant with maximum spatial coverage -data_clim_tile = NaN + ones(48, tc.N_tile,2); -for iAD = 1:2 - - L2_Ascdes = L2_Ascdes_all{iAD}; - - fname = [out_path,'/',out_Para,'_clim_L2_',L2_version,L2_Ascdes,'8d_',resolution,'tile_',time_tag,'_w24d.bin']; - - disp(['read ',fname]) - ifp = fopen(fname,'r','l'); - - for n = 1:48 - - fortran_tag = fread( ifp, 1, int_precision ); - tmp = fread( ifp, 14, float_precision ); - header(n,:) = tmp; - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tmp = fread( ifp, tc.N_tile, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - data_clim_tile(n,:,iAD) = tmp; - - end - - fclose(ifp); -end - -data_clim_tile(data_clim_tile > 10.) = NaN; -data_clim_tile(data_clim_tile < 0.) = 0.; % set small negative values to 0 - -% averaging A, D values -tile_data = mean(data_clim_tile,3,"omitnan"); -fname_out = strrep(fname, L2_Ascdes,'_AD_'); -if fill_small_gaps - - if strcmp(resolution,'M09') - N_cells = 5; - iscube = 0; - elseif strcmp(resolution,'M36') - N_cells = 3; - iscube = 0; - else - error('invalid resolution, use ''M09'' or ''M36'' only') - end - - tmpstr = num2str(N_cells); - - fname_out = [fname_out(1:end-4),'_',tmpstr,'gx',tmpstr,'gfilled_test.bin']; - - tile_data = fill_gaps_in_tiledata(tc, tg, tile_data, N_cells, iscube ); - -end - -tile_data(isnan(tile_data)) = 1.e15; % fillValue = 1.e15 - -disp(['write ',fname_out]) - -ifp = fopen(fname_out,'w','l'); -for n = 1:48 - - % write header - - fwrite( ifp, 14*4, int_precision ); - fwrite( ifp, header(n,:), float_precision ); - fwrite( ifp, 14*4, int_precision ); - - % write science data - - fwrite( ifp, tc.N_tile*4, int_precision ); - fwrite( ifp, tile_data(n,:), float_precision ); - fwrite( ifp, tc.N_tile*4, int_precision ); -end -fclose(ifp); - -% ============================ EOF ====================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m deleted file mode 100644 index 061229b4..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/Preprocess_L2DCA_mwRTM_params_to_dailymat.m +++ /dev/null @@ -1,241 +0,0 @@ -% Script to read SMAP L2 files and extract RTM variables (albedo, vegopacity, roughness) -% to store in global EASEv2 grid daily composite (Asc and Desc separately) mat files for future use. - -% Q. Liu 18 Jul 2022 - -clear - -% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ -addpath('../../shared/matlab/'); - -L2_Ascdes = {'_A_','_D_'}; -L2_qc_yes = 1; - -% L2 file information. Use 'L2_SM_P' for M36 resolution and 'L2_SM_P_E' for M09 -SMAP_product = 'L2_SM_P'; %'L2_SM_P'; -L2_path = ['/discover/nobackup/projects/gmao/smap/SMAP_L4/SMAP/OPS/',SMAP_product,'/'] ; - -L2_version = 'R18290'; %'R17000'; - -out_path = '/discover/nobackup/qliu/matlab/SMAP/L2L4/VOD/QC_frozen_RFI/'; - -L2_dtstep = 10800; - -start_time.year = 2021; -start_time.month = 4; -start_time.day = 1; - -end_time.year = 2022; -end_time.month = 4; -end_time.day = 1; - -M09_Nlon = 3856; -M09_Nlat = 1624; - -M36_Nlon = M09_Nlon/4; -M36_Nlat = M09_Nlat/4; - -if strcmp(SMAP_product(end-1:end),'_E') - out_Nlon = M09_Nlon; - out_Nlat = M09_Nlat; -else - out_Nlon = M36_Nlon; - out_Nlat = M36_Nlat; -end - -% ----------------------------------------------------------------------- -% Read L2 data -for iorb = 1:length(L2_Ascdes) - - date_time = start_time; - date_time.hour = 0; - date_time.min = 0; - date_time.sec = 0; - - fname_L2_pre = []; - - while 1 - - if (date_time.year ==end_time.year && ... - date_time.month==end_time.month && ... - date_time.day ==end_time.day ) - break - end - - outfile_tag = [num2str(date_time.year,'%4.4d'), ... - num2str(date_time.month,'%2.2d'), ... - num2str(date_time.day,'%2.2d')]; - - mat_fname = [out_path,'L2DCA_RTM_',SMAP_product,'_',L2_version,L2_Ascdes{iorb}, outfile_tag,'.mat']; - - if exist(mat_fname,'file') - - disp(['mat file exist ',mat_fname]) - - else - - L2_tau = NaN + ones(out_Nlon,out_Nlat); - L2_omg = NaN + ones(out_Nlon,out_Nlat); - L2_h = NaN + ones(out_Nlon,out_Nlat); - - L2_data_path = [L2_path, '/Y', num2str(date_time.year,'%4.4d'), ... - '/M', num2str(date_time.month, '%2.2d'), ... - '/D', num2str(date_time.day, '%2.2d')]; - - % get list of all files in subdirectory of given date - L2_files_all = dir([L2_data_path, '/SMAP_',SMAP_product,'*',L2_Ascdes{iorb},'*_',L2_version,'_*.h5']); - - % check if multiple versions of the same half orbit file - % only keep the data with the highest version id - - L2_files = {}; - kk = 0; % counter of the final file list - % Remove duplicate files from the list when multiple versions exist - for ff = 1:length(L2_files_all) - % check if v002 or higher exist - if str2num(L2_files_all(ff).name(end-4:end-3)) > 1 - L2_files{kk} = L2_files_all(ff).name; - % if v002 or higher matches previous file in final flist, replace - % previous file in list. Only increase the final file counter when there is no duplicates - if ~strcmp(L2_files{kk}(1:end-5), L2_files_all(ff).name(1:end-5)) - kk = kk + 1; - end - else - kk = kk + 1; - L2_files{kk} = L2_files_all(ff).name; - end - end - - clear L2_fiels_all L2_fname - if ~isempty(L2_files) - - for ifile = 1:length(L2_files) - L2_fname{ifile} = [L2_data_path,'/', L2_files{ifile}]; - end - - if ~isempty(fname_L2_pre) - L2_fname((ifile+1):(ifile+length(fname_L2_pre))) = fname_L2_pre; - end - - fname_L2_pre = []; - - ii = 0; - for ifile = 1: length(L2_fname) - - fname = L2_fname{ifile}; - - disp(fname) - - L2_row = h5read(fname,'/Soil_Moisture_Retrieval_Data/EASE_row_index'); %zero-based - L2_row = L2_row + 1; - L2_col = h5read(fname,'/Soil_Moisture_Retrieval_Data/EASE_column_index'); - L2_col = L2_col + 1; - - L2_utc_seconds = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_time_seconds'); - - L2_vod = h5read(fname,'/Soil_Moisture_Retrieval_Data/vegetation_opacity_option3'); - fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/vegetation_opacity_option3','_FillValue'); - L2_vod(L2_vod == fill_value) = NaN; - - L2_alb = h5read(fname,'/Soil_Moisture_Retrieval_Data/albedo_option3'); - fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/albedo_option3','_FillValue'); - L2_alb(L2_alb == fill_value) = NaN; - - L2_rough = h5read(fname,'/Soil_Moisture_Retrieval_Data/roughness_coefficient_option3'); - fill_value = h5readatt(fname,'/Soil_Moisture_Retrieval_Data/roughness_coefficient_option3','_FillValue'); - L2_rough(L2_rough == fill_value) = NaN; - - % quality flag - L2_qf = h5read(fname,'/Soil_Moisture_Retrieval_Data/retrieval_qual_flag_option3'); - - % surface status land = 0, nonland = 1 - L2_ss = h5read(fname,'/Soil_Moisture_Retrieval_Data/grid_surface_status'); - - % surface flag - L2_sf = h5read(fname,'/Soil_Moisture_Retrieval_Data/surface_flag'); - - L2_rfi_h = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_qual_flag_h'); - L2_rfi_v = h5read(fname,'/Soil_Moisture_Retrieval_Data/tb_qual_flag_v'); - - % exclude points according to quality flag - if L2_qc_yes - - % QC based on retrieval quality flag - %L2_rt = bitget(L2_qf, 1); % only use retrieval_recommended - L2_rt = bitget(L2_qf, 3); % use retrieval_succeeded - - % QC b ased on surface flag - L2_frozen_model = bitget(L2_sf, 9); % model frozen ground - L2_snow = bitget(L2_sf,6); % snow and ice - L2_pice = bitget(L2_sf,7); % permanent snow and ice - L2_rfi_h_qf = bitget(L2_rfi_h,1); % quality flag RFI H - L2_rfi_v_qf = bitget(L2_rfi_v,1); % quality flag RFI V - idx = find(L2_rt == 0 & L2_frozen_model ==0 & ... - L2_snow == 0 & L2_pice ==0 & L2_ss == 0 & ... - L2_rfi_h_qf == 0 & L2_rfi_v_qf == 0); - - % only keep data/coord that pass QC - L2_vod = L2_vod(idx); - L2_alb = L2_alb(idx); - L2_rough = L2_rough(idx); - L2_row = L2_row(idx); - L2_col = L2_col(idx); - L2_utc_seconds = L2_utc_seconds(idx); - clear idx - end - - if ~isempty(L2_vod) - - % round date_time to nearest 3 hourly UTC - utc_t2k = round(double(L2_utc_seconds)/L2_dtstep)*L2_dtstep; - - [yr, doy, mm, dd, hr, mn] = J2000_to_DateTime( utc_t2k ); - - % use points for current UTC day only - idx = find(yr == date_time.year & mm == date_time.month & ... - dd == date_time.day); - - % points across UTC days will be saved in next daily file - if length(idx) < length(L2_utc_seconds) && ifile <= length(L2_files) - disp('L2 across UTC days') - ii = ii + 1; - fname_L2_pre{ii} = fname; - end - - L2_vod = L2_vod(idx); - L2_alb = L2_alb(idx); - L2_rough = L2_rough(idx); - L2_row = L2_row(idx); - L2_col = L2_col(idx); - L2_utc_seconds = L2_utc_seconds(idx); - hr = hr(idx); - clear idx - - % Map L2 to 2d grid - for k = 1:length(L2_vod) - this_col = L2_col(k); - this_row = L2_row(k); - - L2_tau(this_col, this_row) = L2_vod(k); - L2_omg(this_col, this_row) = L2_alb(k); - L2_h(this_col, this_row) = L2_rough(k); - end - end - end - - else - - disp(['no L2 data found in', L2_data_path]) - pause - end - - save(mat_fname,'L2_tau','L2_omg','L2_h') - clear L2_tau L2_omg L2_h - - end - - date_time = augment_date_time(86400, date_time); - end -end - -% ------------------------EOF----------------------------------------- diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m deleted file mode 100644 index 03d5ea3a..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/fill_gaps_in_tiledata.m +++ /dev/null @@ -1,94 +0,0 @@ -function [tile_data_filled] = fill_gaps_in_tiledata(tile_coord, tile_grid_g, tile_data, N_cells, iscube ) - -% Fill missing values in tile-space data with the mean value (excl. NaNs) of surrounding grid cells. -% -% N_cells is number of grid cells averaged in each linear dimension; e.g., N_cells=5 averages across -% a 5-by-5 neighborhood (-2, -1, 0, 1, 2 in each direction). -% -% Uses tile2grid() --> Should work for EASE[_v2] and lat/lon tile spaces. -% Probably needs work for cube-sphere tile space!!! -% -% iscube: required input to alert user that fn is not ready for data in cube-sphere tile space -% -% tile_data[_filled] = N_fields-by-N_tile -% -% Q. Liu, 19 Jul 2022 -% reichle, 29 Jul 2022 - minor clean-up and generalization -% -% ----------------------------------------------------------------------------------------------- - -if ~exist('iscube'), error('Must specify if data is in cube-sphere tile space.'), end - -if iscube, error('Function not ready for data in cube-sphere tile space.'), end - -tc = tile_coord; -tg = tile_grid_g; - -%if strcmp(EASEv2_grid,'M09') -% N_cells = 5; -%elseif strcmp(EASEv2_grid,'M36') -% N_cells = 3; -%else -% error('input grid invalid, use only M09 or M36') -%end - -if size(tile_data,2) ~= tc.N_tile - error('N_tile incorrect, input data size should be [N_fields,N_tile].') -end - -grid_data = tile2grid(tile_data, tc, tg); - -N_f = size(tile_data,1); -N_lon = size(grid_data,1); -N_lat = size(grid_data,2); - -tile_data_filled = tile_data; - -Nshift = floor(N_cells/2); - -for ff = 1:N_f - - grid = grid_data(:,:,ff); - d_sum = zeros(size(grid)); - N_sum = zeros(size(grid)); - - for xshift = -Nshift:Nshift - for yshift = -Nshift:Nshift - - shift = circshift(grid,[xshift, yshift]); - - if xshift < 0 - shift(end+xshift+1:end,:) = NaN; - elseif xshift > 0 - shift(1:xshift, :) = NaN; - end - if yshift < 0 - shift(:,end+yshift+1:end) = NaN; - elseif yshift > 0 - shift(:,1:yshift ) = NaN; - end - - d_sum(~isnan(shift)) = d_sum(~isnan(shift)) + shift(~isnan(shift)); - N_sum(~isnan(shift)) = N_sum(~isnan(shift)) + 1; - - clear shift - end - end - - coarse = d_sum ./ N_sum; - coarse(isinf(coarse)) = NaN; - - idx_nan = find(isnan(tile_data(ff,:))); - - for i = 1:length(idx_nan) - - tile_data_filled(ff,idx_nan(i)) ... - = ... - coarse(tc.i_indg(idx_nan(i))+1, tc.j_indg(idx_nan(i))+1); - end - - clear grid d_sum smooth N_sum - -end - -% ===================== EOF ===================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m deleted file mode 100644 index 3125e892..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_L2_RTM_constants_tile_data.m +++ /dev/null @@ -1,218 +0,0 @@ - -function out_mwRTM = ... - get_L2_RTM_constants_tile_data(tile_coord,L2_file_tag,... - L2_version,start_time, end_time) - -% function to compute the 2 RTM constant variables: Albedo and Roughness(H) based on the -% preprocessed data. Constants are taken as the long term temporal mean -% with maximum coverage across Asc/Desc passes. - -% Q. Liu 18 Jul 2022 - -L2_Ascdes_all = {'_A_','_D_'}; - -out_Para = {'Albedo','Roughness'}; - -%L2_file_tag = 'L2_SM_P_E'; -%L2_version = 'R18290'; - -if strcmp(L2_file_tag(end-1:end),'_E') - resolution = 'M09'; - out_Nlon = 3856; - out_Nlat = 1624; -else - resolution = 'M36'; - out_Nlon = 964; - out_Nlat = 406; -end - -% provide a GEOSldas with proper tile information -%if strcmp(resolution,'M36') -% L4_path = '/discover/nobackup/projects/gmao/smap/SMAP_Nature/SMAP_Nature_v9.x/'; -% L4_version = 'SMAP_Nature_v9.1_M36'; -% based_on_h5 = 0; -% out_Nlon = 3856/4; -% out_Nlat = 1624/4; -% ftilecoord = [L4_path,L4_version,'/output/SMAP_EASEv2_M36_GLOBAL/rc_out/', ... -% L4_version,'.ldas_tilecoord.bin']; -%else -% L4_path = '/css/smapl4/public/L4_Products/L4_SM/'; -% L4_version = 'Vv6030'; -% based_on_h5 = 1; -% out_Nlon = 3856; -% out_Nlat = 1624; -% ftilecoord = [L4_path,L4_version,'/rc_out/SPL4SM_', L4_version,'.ldas_tilecoord.bin']; - -%end - -% daily mat file path -mat_path = '/discover/nobackup/qliu/matlab/SMAP/L2L4/VOD/QC_frozen_RFI/'; - -int_precision = 'int32'; -float_precision = 'float32'; - -% read tile info for binary output -tc = tile_coord; -%tc = read_tilecoord( ftilecoord); - -% 2 parameters -for iPara = 1:length(out_Para) - - % 2 overpasses - for iAD = 1:2 - - L2_Ascdes = L2_Ascdes_all{iAD}; - L2_qc_yes = 1; - - dtstep = 10800; - - % time period for computing climatology - %start_time.year = 2015; - %start_time.month = 4; - %start_time.day = 1; - -% start_time.hour = 1; -% start_time.min = 30; -% start_time.sec = 0; -% -% end_time.year = 2022; -% end_time.month = 4; -% end_time.day = 1; -% end_time.hour = start_time.hour; -% end_time.min = start_time.min; -% end_time.sec = start_time.sec; -% -% start_time = get_dofyr_pentad(start_time); -% end_time = get_dofyr_pentad(end_time); - - % ----------------------------------------------------------------------- - % read time series of SMAP L2 fields - if end_time.month ==1 - time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... - '_',num2str(end_time.year-1,'%4.4d'),'12']; - else - time_tag = [num2str(start_time.year,'%4.4d'),num2str(start_time.month,'%2.2d'), ... - '_',num2str(end_time.year,'%4.4d'),num2str(end_time.month-1,'%2.2d')]; - end - - % file to save long term mean tile data - fname_clim = [mat_path,'/',out_Para{iPara},'_clim_L2_',L2_version,L2_Ascdes,resolution,'tile_',time_tag,'.bin']; - - L2_para_clim_sum = zeros(out_Nlon,out_Nlat); - N_L2_clim_sum = zeros(out_Nlon,out_Nlat); - - % only do time loop if no previously saved climatology file is found - if ~exist(fname_clim,'file') - - start_time.day = 1; - start_time.hour = 0; - start_time.min = 0; - start_time.sec = 0; - - end_time.day = 1; - date_time = start_time; - - while 1 - - if (date_time.year ==end_time.year && ... - date_time.month==end_time.month && ... - date_time.day ==end_time.day ) - break - end - - dt_tag = [num2str(date_time.year,'%4.4d'), ... - num2str(date_time.month,'%2.2d'), ... - num2str(date_time.day,'%2.2d')]; - - mat_fname = [mat_path,'L2DCA_RTM_',L2_file_tag,'_',L2_version,L2_Ascdes, dt_tag,'.mat']; - - if exist(mat_fname,'file') - - disp(['loading ', mat_fname]) - if contains(fname_clim,'Albedo_') - load(mat_fname,'L2_omg') - L2_para = L2_omg; clear L2_omg - elseif contains(fname_clim,'Roughness_') - load(mat_fname,'L2_h') - L2_para = L2_h; clear L2_h - else - error(['unknown clim fname ',fname_clim]) - end - - % compute climatology - tmp = L2_para; - tmp(isnan(tmp)) = 0; - L2_para_clim_sum(:,:) = squeeze(L2_para_clim_sum(:,:)) + tmp; clear tmp - - tmp = ~isnan(L2_para); - N_L2_clim_sum(:,:) = squeeze(N_L2_clim_sum(:,:)) + tmp; clear tmp - - clear L2_para - - else - - error('daily mat file not found') - - end - - date_time = augment_date_time(86400, date_time); - - end - - L2_para_clim = L2_para_clim_sum ./N_L2_clim_sum; - L2_para_clim(N_L2_clim_sum < 1) = NaN; - - % regrid to til grid - - L2_para_tile = NaN + ones(tc.N_tile,1); - for k = 1:tc.N_tile - L2_para_tile(k,1) = L2_para_clim(tc.i_indg(k)+1, tc.j_indg(k)+1); - end - - ifp = fopen(fname_clim,'w','l'); - - - tile_data = L2_para_tile; % should be non-negative? - - tile_data(isnan(tile_data)) = 1.e15; - - fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag - fwrite( ifp, tile_data(:), float_precision ); - fwrite( ifp, tc.N_tile*4, int_precision );% fortran_tag - - clear tile_data - - fclose(ifp) - end - - end - - % combine Asc and Desc data for maximum spatial coverage - data_clim_tile = NaN + ones(tc.N_tile,2); - for iAD = 1:2 - - L2_Ascdes = L2_Ascdes_all{iAD}; - - fname = [mat_path,'/',out_Para{iPara},'_clim_L2_',L2_version,L2_Ascdes,resolution,'tile_',time_tag,'.bin']; - - disp(['read ',fname]) - ifp = fopen(fname,'r','l'); - - fortran_tag = fread( ifp, 1, int_precision ); - tmp = fread( ifp, tc.N_tile, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - data_clim_tile(:,iAD) = tmp; - - fclose(ifp); - end - - % fllValue = 1.e15 - data_clim_tile(data_clim_tile > 10.) = NaN; - data_clim_tile(data_clim_tile < 0.) = 0.; % set small negative values to 0 - - % averaging A, D values - tile_data = mean(data_clim_tile,2,"omitnan"); - - eval(['out_mwRTM.',out_Para{iPara},'=tile_data;']) -end diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m deleted file mode 100644 index 341d05cc..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_lookup.m +++ /dev/null @@ -1,167 +0,0 @@ -function [ veg_lookup, soil_lookup ] = get_mwRTM_lookup(option); - -% Gabrielle De Lannoy, GSFC, 22Jul11 -% -% Same lookup table as in LDASsa -% -% Updated: -% GDL, 6 Sept 2011: 16 IGBP vegetation classes -% GDL, 27 Sept 2011: h=1.2 for conif forest (paper J. Grant), -% rather than h=1.6 (CMEM) -%================================================================== -% VEGETATION -%================================================================== -% -% N_vegcls = 8; -% -% ! 1 Broadleaf evergreen trees 0.1 0.1 0.12 0.14 0.10 0.30 1.0 0.0 -% ! 2 Broadleaf deciduous trees 0.1 0.1 0.12 0.14 0.10 0.2 1.0 2.0 -% ! 3 Needleleaf trees 0.1 0.1 0.12 0.12 0.08 0.1 1.75 0.0 -% ! 4 Grassland 0.1 0.1 0.05 0.11 0.09 0.15 1.0 0.0 -% ! 5 Broadleaf shrubs 0.1 0.1 0.12 0.12 0.10 0.2 1.0 1.0 -% ! 6 Dwarf trees 0.1 0.1 0.05 0.11 0.09 0.15 1.0 1.0 -% ! 7 Bare soil 0.1 0.1 0.00 0.00 0.00 0. 0.0 -1.0 -% ! 8 Desert soil 0.1 0.1 0.00 0.00 0.00 0. 0.0 -1.0 -% -% veg_lookup.rgh_hmin = [ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ]*0.5; -% veg_lookup.rgh_hmax = [ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ]*0.5; -% veg_lookup.omega = [ 0.12, 0.12, 0.12, 0.05, 0.12, 0.05, 0.00, 0.00 ]; -% veg_lookup.lewt = [ 0.30, 0.20, 0.10, 0.15, 0.20, 0.15, 0.00, 0.00 ]; -% veg_lookup.bh = [ 0.10, 0.10, 0.08, 0.09, 0.10, 0.09, 0.00, 0.00 ]; -% veg_lookup.bv = [ 0.14, 0.14, 0.12, 0.11, 0.12, 0.11, 0.00, 0.00 ]; -% veg_lookup.rgh_Nrh = [ 1.00, 1.00, 1.75, 1.00, 1.00, 1.00, 0.00, 0.00 ]; -% veg_lookup.rgh_Nrv = [ 0.00, 2.00, 0.00, 0.00, 1.00, 1.00, -1.00, -1.00 ]; -% veg_lookup.tag = {'rgh_hmin [-]', 'h_ [-]', '\omega [-]', 'lewt [-]',... -% 'b_h [-]', 'b_v [-]', 'Nr_h [-]', 'Nr_h [-]'}; - -%1 Evergreen Needleleaf Forest -%2 Evergreen Broadleaf Forest -%3 Deciduous Needleleaf Forest -%4 Deciduous Broadleaf Forest -%5 Mixed Forest -%6 Closed Shrublands -%7 Open Shrublands -%8 Woody Savannas -%9 Savannas -%10 Grasslands -%11 Permanent Wetlands -%12 Croplands -%13 Urban and Built-Up -%14 Cropland & Natural Vegetation -%15 Snow and Ice -%16 Barren or Sparsely Vegetated - - -N_vegcls = 16; -veg_lookup.tag = {'rgh_hmin [-]', 'rgh_hmax [-]', '\omega [-]', 'lewt [-]',... - 'b_h [-]', 'b_v [-]', 'Nr_h [-]', 'Nr_h [-]'}; - -if (strcmp(option,'CMEM') || strcmp(option,'Lit2')) - - %ECMWF CMEM-code - %veg_lookup.rgh_hmin = [ 1.6, 1.3, 1.6, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - %veg_lookup.rgh_hmax = [ 1.6, 1.3, 1.6, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - veg_lookup.rgh_hmin = [ 1.2, 1.3, 1.2, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - veg_lookup.rgh_hmax = [ 1.2, 1.3, 1.2, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - - veg_lookup.omega = [ 0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 ]; - veg_lookup.lewt = [ 1, 1, 1, 1, 1, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0, 0.5, 0, 0 ]; - veg_lookup.bh = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15, 0, 0.15, 0, 0 ]; - veg_lookup.bv = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15, 0, 0.15, 0, 0 ]; - veg_lookup.rgh_Nrh = [ 1, 1.75,1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 0 ]; - veg_lookup.rgh_Nrv = [ 0, 0, 0, 2, 1, 0, 0, 0, 0, 0, 0, -1, 1, -1, 1,-1 ]; - veg_lookup.st_scale = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - -elseif (strcmp(option,'CMEM_SMOS') || strcmp(option,'Lit3')) - - %ECMWF SMOS monitoring-setup - veg_lookup.rgh_hmin = [ 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 ]; - veg_lookup.rgh_hmax = [ 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 ]; - - veg_lookup.omega = [ 0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 ]; - veg_lookup.lewt = [ 1, 1, 1, 1, 1, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0, 0.5, 0, 0 ]; - veg_lookup.bh = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15,0, 0.15,0, 0 ]; - veg_lookup.bv = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15,0, 0.15,0, 0 ]; - veg_lookup.rgh_Nrh = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - veg_lookup.rgh_Nrv = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - veg_lookup.st_scale = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - -elseif (strcmp(option,'SMAP') || strcmp(option,'Lit1')) - - %Peggy O'Neill's SMAP ATBD, Table 2 - veg_lookup.rgh_hmin = [ 0.16, 0.16, 0.16, 0.16, 0.16, 0.11, 0.11, 0.125, 0.156, 0.156, 0.156, 0.108, 0, 0.13, 0, 0.15 ]; - veg_lookup.rgh_hmax = [ 0.16, 0.16, 0.16, 0.16, 0.16, 0.11, 0.11, 0.125, 0.156, 0.156, 0.156, 0.108, 0, 0.13, 0, 0.15 ]; - veg_lookup.omega = [ 0.12, 0.12, 0.12, 0.12, 0.08, 0.05, 0.05, 0.12, 0.08, 0.05, 0.05, 0.05, 0, 0.065,0, 0 ]; - veg_lookup.lewt = [ 0.3, 0.3, 0.2, 0.2, 0.2, 0.2, 0.2, 0.15, 0.15, 0.15, 0.15, 0.15, 0, 0.15, 0, 0 ]; - veg_lookup.bh = [ 0.1, 0.1, 0.12, 0.12, 0.12, 0.11, 0.11, 0.11, 0.11, 0.1, 0.1, 0.11, 0, 0.11, 0, 0 ]; - veg_lookup.bv = [ 0.1, 0.1, 0.12, 0.12, 0.12, 0.11, 0.11, 0.11, 0.11, 0.1, 0.1, 0.11, 0, 0.11, 0, 0 ]; - veg_lookup.rgh_Nrh = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - veg_lookup.rgh_Nrv = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - veg_lookup.st_scale = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - -elseif (strcmp(option,'Lit4')) - - %ECMWF CMEM-code; same as Lit2, but with new lewt values to go with new LAI values - %veg_lookup.rgh_hmin = [ 1.6, 1.3, 1.6, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - %veg_lookup.rgh_hmax = [ 1.6, 1.3, 1.6, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - veg_lookup.rgh_hmin = [ 1.2, 1.3, 1.2, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - veg_lookup.rgh_hmax = [ 1.2, 1.3, 1.2, 1, 1.3, 0.7, 0.7, 0.7, 0.5, 0.1, 0.1, 0.5, 0, 0.7, 0, 0.1 ]; - - veg_lookup.omega = [ 0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 ]; - veg_lookup.lewt = [ 1.9, 1.5, 1.5, 1.5, 1.7, 0.9, 0.8, 0.9, 0.8, 0.9, 0.8, 0.8, 0, 0.9, 0, 0 ]; - %veg_lookup.lewt = [ 1, 1, 1, 1, 1, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0, 0.5, 0, 0 ]; - veg_lookup.bh = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15, 0, 0.15, 0, 0 ]; - veg_lookup.bv = [ 0.33,0.33,0.33,0.33,0.33, 0.3, 0.3, 0.3, 0.2, 0.2, 0.2, 0.15, 0, 0.15, 0, 0 ]; - veg_lookup.rgh_Nrh = [ 1, 1.75,1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 0 ]; - veg_lookup.rgh_Nrv = [ 0, 0, 0, 2, 1, 0, 0, 0, 0, 0, 0, -1, 1, -1, 1,-1 ]; - veg_lookup.st_scale = [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; - - -elseif (strcmp(option,'Cal3c')) - - load('/hydro/gdelanno/proc_analysis/initial_lookup_3c_rgh_hmin_rgh_hmax_rgh_Nrh_rgh_Nrv_lewt_omega_bh_bv_st_scale.mat'); - -%was Cal2c before -elseif (strcmp(option,'CalD2')) - - load('/hydro/gdelanno/proc_analysis/initial_lookup_D2_rgh_hmin_rgh_hmax_rgh_Nrh_rgh_Nrv_lewt_omega_bh_bv_st_scale.mat'); - -else - - error(['ERROR: Option ',option,' does not exist']) - -end - -%================================================================== -% SOIL -%================================================================== -%1 Sand -%2 Loamy Sand -%3 Sandy Loam -%4 Loam (F) ==> Silt Loam -%5 Silt Loam (F) ==> Silt -%6 Silt (F) ==> Loam -%7 Sandy Clay Loam -%8 Clay Loam (F) ==> Silty Clay Loam -%9 Silty Clay Loam (F) ==> Clay Loam -%10 Sandy Clay Loam -%11 Silty Clay Loam -%12 Clay - - -N_soilcls = 12; - -soil_lookup.sf = [.92, .82, .58, .17, .10, .43, .58, .10, .32, .52, .06, .22]; -soil_lookup.cf = [.03, .06, .10, .13, .05, .18, .27, .34, .34, .42, .47, .58]; -soil_lookup.fc = [0.132, 0.156, 0.196, 0.27 , 0.361, 0.25 , 0.253, 0.334, 0.301, 0.288, 0.363, 0.353]; -soil_lookup.wp = [0.033, 0.051, 0.086, 0.169, 0.045, 0.148, 0.156, 0.249, 0.211, 0.199, 0.286, 0.276]; -soil_lookup.poros = [0.373, 0.386, 0.419, 0.476, 0.471, 0.437, 0.412, 0.478, 0.447, 0.415, 0.478, 0.45]; -soil_lookup.b = [3.3, 3.8, 4.34, 5.25, 3.63, 5.96, 7.32, 8.41, 8.34, 9.7, 10.78, 12.93]; -soil_lookup.PsiS = [-0.05, -0.07, -0.16, -0.65, -0.84, -0.24, -0.12, -0.63, -0.28, -0.12, -0.58, -0.27]; -soil_lookup.Ksat = [2.45E-05, 1.75E-05, 8.35E-06, 2.36E-06, 1.10E-06, 4.66E-06, 6.31E-06, 1.44E-06, 2.72E-06, 4.25E-06, 1.02E-06, 1.33E-06]; -soil_lookup.tag = {'Sand [-]', 'Clay [-]', 'Field Capacity [m3/m3]', ... - 'Wilting Point [m3/m3]', 'Porosity [m3/m3]', 'b [ ]', 'Psisat [m]', 'Ksat [m/s]'}; - -end - -%==========================EOF===================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m deleted file mode 100644 index 1e2ef028..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/get_mwRTM_vegcls_based.m +++ /dev/null @@ -1,129 +0,0 @@ -function [mwRTMparam] = get_mwRTM_vegcls_based( tile_coord, dominant_M36vegcls,resolution) - -% Helper function to get RTM parameter values based on the vegcls lookup table -% before writing in the mwRTM_params.nc4 file. The function is called in -% Write_mwRTM_nc4_file.m - -% Q. Liu 20 Jul 2022 - - -% Vegetation-based RTM-parameters -lookup_option = 'Lit4'; - -%---------------------------------------------------------------------------- - -% Vegetation classes -% read in M36 & M09 vegcls for both M36 and M09 mwRTM -vegcls_fname = '/discover/nobackup/qliu/gdelanno_RTM/SMAP_aux/EASEV2/dominantIGBP36km.406x964.uint8'; - -ifp = fopen( vegcls_fname, 'r', 'b' ); -veg_clsM36 = fread( ifp, [406 964] ,'uint8'); -fclose(ifp); - -vegcls_fname = '/discover/nobackup/qliu/gdelanno_RTM/SMAP_aux/EASEV2/dominantIGBP09km.1624x3856.uint8'; - -ifp = fopen( vegcls_fname, 'r', 'b' ); -veg_clsM09 = fread( ifp, [1624 3856] ,'uint8'); -fclose(ifp); - -% list of parameters can be based on vegcls lookup table -fn_mwRTMparam = { ... - 'vegcls', ... - 'rgh_Nrh', 'rgh_Nrv', ... - 'rgh_polmix','omega', 'bh', 'bv', 'lewt'}; - -for i=1:length(fn_mwRTMparam) - - mwRTMparam.(fn_mwRTMparam{i}) = [NaN+zeros(length(tile_coord.N_tile),1)]; - -end - -[ veg_lookup, tmp ] = get_mwRTM_lookup(lookup_option); -clear tmp - -%==================================================================== - -%order of tiles depend on LDASsa-output; tile_coord.txt -%output from this code should *always* be sorted as [1:N_tile], that is - -%even if re-ordered output from an LDASsa-run is used as input, the -%resulting mwRTMparam.xxxx(:) is always monotonically increasingly sorted - -[row_M09,col_M09] = EASEv2_latlon2ind(tile_coord.com_lat,tile_coord.com_lon,'M09',1); -row_M09 = row_M09 +1; -col_M09 = col_M09 +1; - -[row_M36,col_M36] = EASEv2_latlon2ind(tile_coord.com_lat,tile_coord.com_lon,'M36',1); -row_M36 = row_M36 + 1; -col_M36 = col_M36 + 1; - -for tile = 1 : tile_coord.N_tile - - %since m10_p3, the tile-order has changed, so tile<>tile_id ! - tileid = tile_coord.tile_id(tile); - - if contains(resolution,'_M09') && ~dominant_M36vegcls - - jj = row_M09(tile); - ii = col_M09(tile); - i_vegcls = int32(veg_clsM09(jj,ii)); - - else - - % First, rely on M36 database - jj = row_M36(tile); - ii = col_M36(tile); - i_vegcls = int32(veg_clsM36(jj,ii)); - - % Next, fill missing vegcls with the dominant vegcls of the - % M09 grids - - if (i_vegcls<=0 || i_vegcls>200 || isnan(i_vegcls)) - - if contains(resolution,'M09') - tmp_ind = find(row_M36 == jj & col_M36 == ii); - for t = 1:length(tmp_ind) - i_vegcls(t) = int32(veg_clsM09(row_M09(tmp_ind(t)),col_M09(tmp_ind(t)))); - end - else - t=0; - for j1 = ((jj-1)*4+1):(jj*4) - for i1 = ((ii-1)*4+1):(ii*4) - t = t+1; - i_vegcls(t) = int32(veg_clsM09(j1,i1)); - end - end - end - - ind_veg = find(~(i_vegcls<=0 | i_vegcls>200 | isnan(i_vegcls))); - if ~isempty(ind_veg) - i_vegcls = i_vegcls(ind_veg); - end - i_vegcls = mode(i_vegcls); - - end - end - %====for valid vegetation classes in IGBP:==== - if (i_vegcls > 0 ) - - mwRTMparam.vegcls(tileid,1) = i_vegcls; %IGBP - - mwRTMparam.rgh_Nrh(tileid,1) = veg_lookup.rgh_Nrh(i_vegcls); - mwRTMparam.rgh_Nrv(tileid,1) = veg_lookup.rgh_Nrv(i_vegcls); - - mwRTMparam.rgh_polmix(tileid,1) = 0; - mwRTMparam.omega(tileid,1) = veg_lookup.omega(i_vegcls); - mwRTMparam.bh(tileid,1) = veg_lookup.bh(i_vegcls); - mwRTMparam.bv(tileid,1) = veg_lookup.bv(i_vegcls); - mwRTMparam.lewt(tileid,1) = veg_lookup.lewt(i_vegcls); - - else - - for i = 1:length(fn_mwRTMparam) - mwRTMparam.(fn_mwRTMparam{i})(tileid,1) = NaN; - end - - end - -end - -%===============================EOF====================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 deleted file mode 100644 index 114f24b7..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/mwRTM_params/mwrtm_bin2nc4.F90 +++ /dev/null @@ -1,241 +0,0 @@ -!This program converts original mwrtm_param.bin to nc4. -!The original mwrtm_param.bin is the same order as the tile file and encode with big endian -!for example /gpfsm/dnb31/gdelanno/input/RTM_parms/EASEv2/L4SM_v001_Lit4_CalD0/SMAP_EASEv2_M36/mwRTM_param.bin -! -! Note: "mwrtm_param" file only includes time-invariant mwRTM parameters (i.e., excl. vegopacity) -! -reichle, 21 Feb 2022 -! -PROGRAM mwrtm_bin2nc4 - use mwRTM_types, only: mwRTM_param_type - use mwRTM_types, only: mwRTM_param_nodata_check - - implicit none - INCLUDE 'netcdf.inc' - - integer :: i,k, n, command_argument_count, NTILES - integer :: NCFOutID, Vid, STATUS, CellID, TimID, nVars - character(512):: Usage="mwrtm_bin2nc4.x mwrtm_BINFILE mwRTM_param.nc4" - character(512):: BINFILE, MWRTMNC4, arg(3) - real, allocatable, dimension (:) :: var - integer, allocatable,dimension (:) :: NT - character(len=:),allocatable :: shnms(:) - type(mwRTM_param_type), allocatable :: mwp(:) - integer :: unitnum - logical :: mwp_nodata - - - nVars = 18 - shnms = [ & - 'MWRTM_VEGCLS ',& - 'MWRTM_SOILCLS ',& - 'MWRTM_SAND ',& - 'MWRTM_CLAY ',& - 'MWRTM_POROS ',& - 'MWRTM_WANGWT ',& - 'MWRTM_WANGWP ',& - 'MWRTM_RGHHMIN ',& - 'MWRTM_RGHHMAX ',& - 'MWRTM_RGHWMIN ',& - 'MWRTM_RGHWMAX ',& - 'MWRTM_RGHNRH ',& - 'MWRTM_RGHNRV ',& - 'MWRTM_RGHPOLMIX',& - 'MWRTM_OMEGA ',& - 'MWRTM_BH ',& - 'MWRTM_BV ',& - 'MWRTM_LEWT '] - - ! processing command line agruments - I = command_argument_count() - - if( I /=2 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call get_command_argument(n,arg(n)) - enddo - - read(arg(1),'(a)') BINFILE - read(arg(2),'(a)') MWRTMNC4 - - print *,trim(BINFILE) - print *,trim(MWRTMNC4) - - ! reading mwrtm_bin - - unitnum = 10 - open (unitnum, file = trim(BINFILE), CONVERT='BIG_ENDIAN',form = 'unformatted', action ='read') - read (unitnum) NTILES - print*, "Ntiles", NTILES - allocate(var(NTILES)) - allocate(NT(NTILES)) - - status = NF_CREATE (trim(MWRTMNC4), NF_NETCDF4, NCFOutID) - status = NF_DEF_DIM(NCFOutID, 'tile' , NTILES, CellID) - - do n = 1, nVars - - status = NF_DEF_VAR(NCFOutID,trim(shnms(n)) , NF_FLOAT, 1 ,CellID, vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name', & - LEN_TRIM(getAttribute(shnms(n), LNAME = 1)), & - getAttribute(shnms(n), LNAME = 1) ) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & - LEN_TRIM(getAttribute(shnms(n), UNT = 1)), & - getAttribute(shnms(n), UNT = 1)) - end do - - ! reading and writing - ! tile id - read(unitnum) NT ! read off the tile id - do i= 1, NTILES - if (i /= NT(i)) stop "not original one" - enddo - - allocate(mwp(NTILES)) - - read (unitnum) NT; mwp(1:NTILES)%vegcls = NT(1:NTILES) - read (unitnum) NT; mwp(1:NTILES)%soilcls = NT(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%sand = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%clay = VAR(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%poros = VAR(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%wang_wt = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%wang_wp = VAR(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%rgh_hmin = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_hmax = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_wmin = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_wmax = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_Nrh = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_Nrv = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%rgh_polmix = VAR(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%omega = VAR(1:NTILES) - - read (unitnum) VAR; mwp(1:NTILES)%bh = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%bv = VAR(1:NTILES) - read (unitnum) VAR; mwp(1:NTILES)%lewt = VAR(1:NTILES) - - do i = 1, NTILES - call mwRTM_param_nodata_check( mwp(i), mwp_nodata ) - enddo - - VAR = real(mwp(1:NTILES)%vegcls) - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(1))) ,(/1/),(/NTILES/),var ) - VAR = real(mwp(1:NTILES)%soilcls) - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(2))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%sand - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(3))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%clay - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(4))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%poros - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(5))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%wang_wt - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(6))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%wang_wp - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(7))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%rgh_hmin - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(8))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_hmax - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(9))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_wmin - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(10))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_wmax - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(11))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_Nrh - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(12))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_Nrv - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(13))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%rgh_polmix - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(14))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%omega - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(15))) ,(/1/),(/NTILES/),var ) - - VAR = mwp(1:NTILES)%bh - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(16))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%bv - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(17))) ,(/1/),(/NTILES/),var ) - VAR = mwp(1:NTILES)%lewt - status = NF_PUT_VARA_REAL(NCFOutID,VarID(NCFOutID,trim(shnms(18))) ,(/1/),(/NTILES/),var ) - - - STATUS = NF_CLOSE (NCFOutID) - close (10) - - contains - - ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! *********************************************************************** - - FUNCTION getAttribute (SHORT_NAME, LNAME, UNT) result (str_atr) - - character(*), intent(in) :: SHORT_NAME - integer, intent (in), optional :: LNAME, UNT - character(128) :: str_atr, LONG_NAME, UNITS - - SELECT case (trim(SHORT_NAME)) - case('MWRTM_VEGCLS'); LONG_NAME = 'L-band RTM model: Vegetation class. Type is Unsigned32'; UNITS = '1' - case('MWRTM_SOILCLS'); LONG_NAME = 'L-band RTM model: Soil class. Type is Unsigned32'; UNITS = '1' - case('MWRTM_SAND'); LONG_NAME = 'L-band RTM model: Sand fraction'; UNITS = '1' - case('MWRTM_CLAY'); LONG_NAME = 'L-band RTM model: Clay fraction'; UNITS = '1' - case('MWRTM_POROS'); LONG_NAME = 'L-band RTM model: Porosity'; UNITS = 'm3 m-3' - case('MWRTM_WANGWT'); LONG_NAME = 'L-band RTM model: Wang dielectric model transition soil moisture'; UNITS = 'm3 m-3' - case('MWRTM_WANGWP'); LONG_NAME = 'L-band RTM model: Wang dielectric model wilting point soil moisture';UNITS = 'm3 m-3' - case('MWRTM_RGHHMIN'); LONG_NAME = 'L-band RTM model: Minimum microwave roughness parameter'; UNITS = '1' - case('MWRTM_RGHHMAX'); LONG_NAME = 'L-band RTM model: Maximum microwave roughness parameter'; UNITS = '1' - case('MWRTM_RGHWMIN'); LONG_NAME = 'L-band RTM model: Soil moisture value below which maximum microwave roughness parameter is used'; UNITS = 'm3 m-3' - case('MWRTM_RGHWMAX'); LONG_NAME = 'L-band RTM model: Soil moisture value above which minimum microwave roughness parameter is used'; UNITS = 'm3 m-3' - case('MWRTM_RGHNRH'); LONG_NAME = 'L-band RTM model: H-pol. Exponent for rough reflectivity parameterization'; UNITS = '1' - case('MWRTM_RGHNRV'); LONG_NAME = 'L-band RTM model: V-pol. Exponent for rough reflectivity parameterization'; UNITS = '1' - case('MWRTM_RGHPOLMIX'); LONG_NAME = 'L-band RTM model: Polarization mixing parameter'; UNITS = '1' - case('MWRTM_OMEGA'); LONG_NAME = 'L-band RTM model: Scattering albedo'; UNITS = '1' - case('MWRTM_BH'); LONG_NAME = 'L-band RTM model: H-pol. Vegetation b parameter'; UNITS = '1' - case('MWRTM_BV'); LONG_NAME = 'L-band RTM model: V-pol. Vegetation b parameter'; UNITS = '1' - case('MWRTM_LEWT'); LONG_NAME = 'L-band RTM model: Parameter to transform leaf area index into vegetation water content'; UNITS = 'kg m-2' - - case default; LONG_NAME = 'Checck_GridComp'; UNITS = 'Checck_GridComp'; - end select - - if (present(LNAME)) str_atr = trim (LONG_NAME) - if (present(UNT)) str_atr = trim (UNITS ) - - END FUNCTION getAttribute - -END PROGRAM mwrtm_bin2nc4 diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m deleted file mode 100644 index b7e914fc..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_L4_Tb_scale_SMAP.m +++ /dev/null @@ -1,178 +0,0 @@ -% Calculate scaling files for Tb-DA based on SMAP Tb -% -% GDL, 11 Sep 2012 -% QLiu, Dec 2016 -%===================================================================== - -clear - -% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ -addpath('../../shared/matlab/'); - -%====== - -run_months = [1:12 1:4]; %loop through 1:4 again to get complete pentads - -%exp_path = '/smap1/qliu/output/SMAP_Nature_v8.3/NRv8.3_innov_RTMv4/'; -%exp_run = {'SMAP_NRv8.3inv_RTMv4'}; -%exp_path = '/hydro/qliu/WORK/output/L4_SM_SMAP/'; -%exp_run = {'SPL4SM_OL4001'}; -%exp_path = '/smap1/qliu/output/SMAP_Nature_v8.3/NRv8.3_innov/S1/'; -%exp_run = {'SMAP_NRv8.3_innov'}; -exp_path = '/home/qliu/smap/SMAP_Nature/'; -exp_run = {'SPL4SM_OL7000'}; -domain = 'SMAP_EASEv2_M09_GLOBAL'; - -%Start and end year for each month -start_year = [repmat(2016,1,3) repmat(2015,1,9) repmat(2016,1,3) repmat(2015,1,1)]; %corresp to [1:12 1 2] -end_year = [repmat(2022,1,3) repmat(2021,1,9) repmat(2022,1,3) repmat(2021,1,1)]; %runs till end of run_months for end_year - -orbit = [ 2]; %1=A, 2=D !DO *NOT* USE ASC AND DESC TOGETHER! -pol = [ 1 2 ]; %1=H, 2=V -inc_ang = [ 40.0 ]; - -prefix_out = 'L4SM_OL7000_SMAPL1CR17000_zscore_stats_'; - -dt_assim = 3*60*60; % [seconds] land analysis time step, - % same as LANDASSIM_DT in GEOSldas) -t0_assim = 0; % [seconds] land analysis "reference" time (offset from 0z), - % same as LANDASSIM_T0 in GEOSldas (except for units), - % typically 0 in offline runs and 1.5*60*60 in LADAS - -%====== - -obs_param_fname = [exp_path, '/', exp_run{1}, '/output/', domain, '/rc_out/', ... - '/Y2015/M04/',exp_run{1}, '.ldas_obsparam.20150401_0000z.txt']; - -var_name = {'Tb'}; - -% added to identify SMOS or SMAP from runs that include both -descr = 'SMAP_L1C' ; % 'SMOS_fit' - -%====== -if (length(orbit) > 1) - error('ONLY pick one orbit!') -end - -if (orbit(1) == 1) int_Asc = 1; end %Asc -if (orbit(1) == 2) int_Asc = 0; end %Desc - -%====== -%TO GO FROM SMOS TO SMAP ONLY!!! -%int_Asc = abs(int_Asc - 1); -%====== - -%Spatial sampling -hscale = 0.0; % degrees lat/lon - -% Temporal sampling window(days), current hard coded and need to be divisive by 5 and be an odd number -w_days = 75; - -Ndata_min = 20; - -%To limit M09 tiles to administering M36 tiles only (smaller files), -%provide convert_grid -if isempty(strfind(prefix_out,'M09')) - convert_grid='EASEv2_M36'; -end - -if (mod(w_days,10) == 0) - disp('w_days should be 5, 15, 25, 35, ...') - error('Need an odd number of pentads |xxxxx|xxXxx|xxxxx|') -end -if (mod(w_days, 5) > 0) - error('Aiming at pentad files') -end - -% ------------------------------------------------------------------------ - -[N_obs_param, obs_param ] = read_obsparam(obs_param_fname); - -species =[]; - -for oo=1:length(orbit) - for pp=1:length(pol) - for aa=1:length(inc_ang) - - add_species = obs_param(strcmp(var_name,{obs_param.varname}) & ... - orbit(oo) == [obs_param.orbit] & ... - inc_ang(aa) == [obs_param.ang] & ... - pol(pp) == [obs_param.pol] & ... - ~cellfun(@isempty, strfind({obs_param.descr},descr))).species; - - species = union(species,add_species); - - end - end -end - -species -% ------------------ - -for n=1:length(exp_run) - - if (exist('convert_grid','var')) - - if exist('time_of_day_in_hours','var') - - - for j=1:length(time_of_day_in_hours) - - for k=1:length(run_months) - - get_model_and_obs_clim_stats( var_name, ... - run_months{k}, exp_path, exp_run{n}, domain, ... - start_year, end_year, ... - dt_assim, t0_assim, species, obs_param, ... - hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... - convert_grid, time_of_day_in_hours(j) ); - - end - - end - - else - - get_model_and_obs_clim_stats( var_name, ... - run_months, exp_path, exp_run{n}, domain, start_year, end_year, ... - dt_assim, t0_assim, species, obs_param, ... - hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... - convert_grid ); - - end - else - - if exist('time_of_day_in_hours','var') - - - for j=1:length(time_of_day_in_hours) - - for k=1:length(run_months) - - get_model_and_obs_clim_stats( var_name, ... - run_months{k}, exp_path, exp_run{n}, domain, ... - start_year, end_year, ... - dt_assim, t0_assim, species, obs_param, ... - hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out,... - time_of_day_in_hours(j) ); - - end - - end - - else - - get_model_and_obs_clim_stats( var_name, ... - run_months, exp_path, exp_run{n}, domain, start_year, end_year, ... - dt_assim, t0_assim, species, obs_param, ... - hscale, inc_ang, int_Asc, w_days, Ndata_min, prefix_out); - - end - - end -end - - -% ============= EOF ==================================================== - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m deleted file mode 100644 index 20fc3832..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/Run_get_model_and_obs_clim_stats_latlon_grid.m +++ /dev/null @@ -1,115 +0,0 @@ -clear - -% ------------------------------------------------------------------- -% Begin user-defined inputs -% ------------------------------------------------------------------- - -% addpath('../../shared/matlab/'); -addpath('/discover/nobackup/amfox/current_GEOSldas/GEOSldas/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab') - -% Define the Open Loop experiment path, run name, domain, and output prefix - -exp_path = '/discover/nobackup/amfox/Experiments/OLv7_M36_ascat'; -exp_run = {'OLv7_M36_ascat'}; -domain = 'SMAP_EASEv2_M36_GLOBAL'; -prefix_out = 'M36_zscore_stats_'; - -% Define the Open Loop experiment start and end dates - -start_month = 4; -start_year = 2015; -end_month = 3; -end_year = 2021; - -% Define the species names - -species_names = {'ASCAT_META_SM','ASCAT_METB_SM','ASCAT_METC_SM'}; - -% Define whether to combine species - -combine_species_stats = 1; % 1 to combine all species into single set of statistics - -% Define the grid resolution (degrees) - -grid_resolution = 0.25; - -% Define moving window size over which statistics are calculated, -% and minimum number of data points required to calculate statistics - -w_days = 75; -Ndata_min = 5; - -% Define the assimilation time step and initial time - -dt_assim = 3*60*60; -t0_assim = 0; - -% Define print intervals - -print_each_DOY = 1; -print_each_pentad = 0; -print_all_pentads = 1; - -% Define output directory (takes form "domain"/stats/"out_dir") -out_dir = 'z_score_clim_quarter_degree'; - -% Define the months to run over, 1:12, plus a number of months required to complete the window -run_months = [1:12 1:ceil(w_days/30)]; - -% ------------------------------------------------------------------- -% End user-defined inputs -% ------------------------------------------------------------------- - -% Calculate the earliest and latest years for each month in the experiment -earliest_year = zeros(length(run_months),1); -latest_year = zeros(length(run_months),1); - -cnt = 0; -for month = run_months - % Initialize the earliest and latest year variables - cnt = cnt + 1; - - % Check if the current year/month combination is earlier than the earliest - if datenum(start_year, month, 1) < datenum(start_year, start_month, 1) - earliest_year(cnt) = start_year+1; - else - earliest_year(cnt) = start_year; - end - - % Check if the current year/month combination is later than the latest - if datenum(end_year, month, 1) > datenum(end_year, end_month,1) - latest_year(cnt) = end_year-1; - else - latest_year(cnt) = end_year; - end -end - -% assume "ldas_obsparam" file is available at 0z on first day of start_month/start_year - -YYYY = num2str( start_year, '%4.4d' ); -MM = num2str( start_month, '%2.2d' ); - -obs_param_fname = [exp_path, '/', exp_run{1}, '/output/', domain, '/rc_out/Y', YYYY, ... - '/M', MM, '/',exp_run{1}, '.ldas_obsparam.', YYYY, MM, '01_0000z.txt']; - -[N_obs_param, obs_param ] = read_obsparam(obs_param_fname); - -species =[]; - -for i = 1:length(species_names) - add_species = obs_param(strcmp(species_names(i),{obs_param.descr})).species; - species = union(species,add_species); -end - -if combine_species_stats - disp('Calculating stats by combining multiple species'); -end - -% Calculate the climatology statistics - -get_model_and_obs_clim_stats_latlon_grid( species_names, run_months, exp_path, exp_run{1}, domain, earliest_year, ... - latest_year, dt_assim, t0_assim, species, combine_species_stats, ... - grid_resolution, w_days, Ndata_min, prefix_out, print_each_DOY, ... - print_each_pentad, print_all_pentads, out_dir ); - -% ================= EOF ========================================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m deleted file mode 100644 index 939c2e31..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/dist_km2deg.m +++ /dev/null @@ -1,26 +0,0 @@ -%========================================================================= - -function [dist_x_deg, dist_y_deg] = dist_km2deg( dist_km, lat ) - - MAPL_PI = 3.14159265358979323846; - MAPL_RADIUS = 6371.0E3; - - % distance between latitudes is equal (always full meridional radius circle) - % assumuming the Earth is a perfect ball. - % NOTE: MAPL_radius (Earth radius) is in [m] and dist_km is in [km] - - dist_y_deg = dist_km .* (180./MAPL_PI) ./ (MAPL_RADIUS./1000.); - - % distance between longitudes decreases towards the poles - % (radius of parallel circles decreases) - % NOTE: cos() needs argument in [rad], lat is in [deg] (-90:90) - - dist_x_deg = dist_y_deg ./ cos( MAPL_PI./180. .* lat ); - - if (any(dist_x_deg<0. | dist_y_deg<0.)) - disp( 'encountered negative distance' ); - end - -end - -%========================================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m deleted file mode 100644 index 9edf5ca2..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_ij_ind_from_latlon.m +++ /dev/null @@ -1,24 +0,0 @@ -%========================================================================= - -function [i_ind,j_ind] = get_ij_ind_from_latlon( tile_grid, lat, lon) - - if (strcmp(tile_grid.gridtype,'EASEv2_M36')) - %row, col - [j_indg,i_indg] = ... - EASEv2_latlon2ind(lat,lon,'M36',1); - elseif (strcmp(tile_grid.gridtype,'EASEv2_M09')) - %row, col - [j_indg,i_indg] = ... - EASEv2_latlon2ind(lat,lon,'M09',1); - else - error('not ready for this grid'); - end - - % convert to index into array defined by tile_grid_d - - i_ind = i_indg - tile_grid.i_offg - (tile_grid.ind_base - 1); - j_ind = j_indg - tile_grid.j_offg - (tile_grid.ind_base - 1); - -end - -%========================================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m deleted file mode 100644 index 8d8b242e..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats.m +++ /dev/null @@ -1,729 +0,0 @@ - -function [] = get_model_and_obs_clim_stats( varname, ... - run_months, exp_path, exp_run, domain, start_year, end_year, ... - dt_assim, t0_assim, species, obs_param, ... - hscale, inc_angle, int_Asc, w_days, Ndata_min, prefix, ... - convert_grid , time_of_day_in_hours ) - -% -% get_model_and_obs_clim_stats.m -% -% Compute mean, stdv of model and observations from tile-based -% "innov" files for a selection of species. -% -% The main purpose of this function is to aggregate the information -% from the "innov" files so that the climatology statistics can -% be used in scaling of the observations before assimilation. -% -% One file with statistics is generated for every DOY (1,...,365). -% The temporal smoothing/averaging window (w_days) is given in days. -% -% Stats output file in a similar format as the SMOS-data files -% -% ==HEADER== -% N_tiles N_angles -% angles -% -% ==DATA== -% -% %%%% tile ID --> for all tiles (1:N_tiles, not sorted by tile_id!) -% lat -% lon -% -% [for angles] -% mean_obs_H -% std_obs_H -% mean_mod_H -% std_mod_H -% N_data_H -% -% mean_obs_V -% std_obs_V -% mean_mod_V -% std_mod_V -% N_data_V -% -% H_obs -% H_mod -% V_obs -% V_mod -% [end angles] -% -% GDL, 10 sept 2012 -% -% GDL, aug 2013: added 'convert_grid' (= EASEv2_M36, EASE_M36, ...) -% to project the Obs (always M36 for SMOS) and Fcst to M36 -% M09 obs are administered by tiles (0) that could be anywhere -% around the center of the observed pixel (M36) -% ----------- -% | X X X X | -% | X O O X | -% | X O O X | -% | X X X X | -% ----------- -% GDL, jan 2014: the above issue that "any" M09 tile in the center (0) -% could potentially administer the M36 obs is not true -% anymore with later LDASsa-tags. -% => no need to pass on 'convert_grid' for tags later than -% the summer of 2013 -% reichle, qliu, 13 July 2022: -% "convert_grid" is still needed to limit the number of tiles -% in the scaling parameter file. With "convert_grid" turned on, -% only the M09 tile to the northeast of the M36 center point -% is kept in the scaling parameter file, consistent with the -% "tmp_shift_lat" and "tmp_shift_lon" operations in the SMOS -% and SMAP Fortran readers. (It is not clear if this matlab -% function works properly if there is no M09 [land] tile -% immediately to the northeast of the M36 center point. In -% such a case, the Fortran reader assigns the nearest M09 -% land tile as the tile that administers the obs.) -% Presumably, scaling parameters for all M09 tiles could be kept -% if they are stored in (compressed) nc4 format. In this case, -% the NaN values for the scaling parameters of 15 out of each 16 -% M09 tiles can be compressed to almost nothing. -% -% ------------------------------------------------------------------- -% begin user-defined inputs -% ------------------------------------------------------------------- - -% obs species to be processed (see ens_upd_inputs.nml for a list) -% -% (only observation species that represent observations of the same -% model prognostic or diagnostic can be processed together!) - -nodata = -9999; -nodata_tol = 1e-4; - -% minimum number of data points to include in window statistics - -% N_data_min = w_days/10.; % initial screening on minimum # points in a -% % window to calculate a mean or stdv -% include a final decision about "good" stats later, when merging years - -% no-data-value for points that don't have good statistics - -no_data_stats = -9999.; - -disp('ASSUMING EASEv2 M36 observations'); - -if ~isempty(strfind(domain,'M36')) && isempty(strfind(obs_param(species(1)).descr, '_E')) - tol = 1E-3; -else - tol = 2; -end - -% output specs - -overwrite = 1; - -Nf = 5; %5 fields per polarization - -N_out_fields = 2*Nf+4; %14; - -write_ind_latlon = 'latlon_id'; %'latlon'; - -N_angle = length(inc_angle); -N_pol = 2; - -tmp_shift_lon = 0.01; -tmp_shift_lat = 0.005; - -store_all_M09inM36 = 0; -print_each_DOY = 0; - -% ------------------------------------------------------------------- -% end user-defined inputs -% ------------------------------------------------------------------- - -% assemble input and output paths - -%inpath = [ exp_path, '/output/', exp_run, '/', domain ]; -inpath = [ exp_path, '/', exp_run, '/output/', domain ]; - -outpath = [ inpath, '/stats/z_score_clim/' ]; - -% create outpath if it doesn't exist - -if exist(outpath)~=2 - eval(['!mkdir -p ', outpath]); -end - -% ------------------------------------------------------------- - -% assemble output file name - -ind = find(start_year == min(start_year)); -mi_m = min(run_months(ind)); -ind = find(end_year == max(end_year)); -ma_m = max(run_months(ind)); - -D(1) = 1; -P(1) = 1; -if mi_m > 1 - D(1) = sum(days_in_month( 2014, [1:mi_m-1]))+1; - P(1) = ceil(D(1)/5); -end -if ma_m > 1 - D(2) = sum(days_in_month( 2014, [1:ma_m])); -else - D(2) = 1; -end -P(2) = floor(D(2)/5); - -if run_months(1) ~= run_months(end) && run_months(2) ~= run_months(end) - disp('WARNING: incomplete pentad-windows; loop through additional months to get complete pentads'); -end - -fname_out_base = [ outpath, '/', prefix, ... - num2str(min(start_year)),'_doy',num2str(D(1)),'_', ... - num2str(max(end_year)), '_doy',num2str(D(2)), ... - '_hscale_', num2str(hscale,'%2.2f'), '_', ... - 'W_', num2str(w_days),'d_Nmin_', num2str(Ndata_min)]; - -fname_out_base_p = [ outpath, '/', prefix, ... - num2str(min(start_year)),'_p',num2str(P(1)),'_', ... - num2str(max(end_year)), '_p',num2str(P(2)), ... - '_hscale_', num2str(hscale,'%2.2f'), '_', ... - 'W_', num2str(round(w_days/5)),'p_Nmin_', num2str(Ndata_min)]; - -%fname_out_base = [fname_out_base, spec_tag]; - -if (int_Asc == 1) - Orbit_tag = '_A'; %'_Asc'; -else - Orbit_tag = '_D'; %'_Desc'; -end - -fname_out_base = [fname_out_base, Orbit_tag]; -fname_out_base_p = [fname_out_base_p, Orbit_tag]; - -if exist( 'time_of_day_in_hours', 'var') - - fname_out_base = [fname_out_base, '_', num2str(time_of_day_in_hours,'%2.2d'), 'z']; - fname_out_base_p = [fname_out_base_p, '_', num2str(time_of_day_in_hours,'%2.2d'), 'z']; - -end - -% ------------------------------------------------------------- - -% load catchment coordinates - -fname = [inpath, '/rc_out/', exp_run, '.ldas_tilecoord.bin']; -fnameg= [inpath, '/rc_out/', exp_run, '.ldas_tilegrids.bin']; - -[ tile_coord ] = read_tilecoord( fname ); -[ tile_grid ] = read_tilegrids( fnameg ); - -N_tile = length(tile_coord.tile_id); - -% ------------------------------------------------------------- - -% determine tiles to whose statistics the current obs will contribute to - -disp('pre-computing index for regional averaging') - -central_lat = tile_coord.com_lat; -central_lon = tile_coord.com_lon; -tile_coord_tile_id = tile_coord.tile_id; - -if (exist('convert_grid')) - - %1) convert to M36 EASE indices - %2) convert back to lat/lon at center of obs - if (~isempty(strfind(convert_grid, 'M36')) && ~isempty(strfind(convert_grid, 'EASEv2'))) - gridid = 'M36'; - [central_row,central_col] = EASEv2_latlon2ind(central_lat,central_lon,gridid,1); - [central_lat,central_lon] = EASEv2_ind2latlon(central_row,central_col,gridid); - elseif (~isempty(strfind(convert_grid, 'M36')) && ~isempty(strfind(convert_grid, 'EASEv1'))) - error('Must provide smapeasev1_latlon2ind() and smapeasev1_ind2latlon()!') - gridid = 'M36'; - [central_row,central_col] = smapeasev1_latlon2ind(central_lat,central_lon,gridid); - [central_lat,central_lon] = smapeasev1_ind2latlon(central_row,central_col,gridid); - else - error(['Unable to convert to ',convert_grid]) - end - - row_col_tmp = [central_row central_col]; - [unique_rc, ia, ic] = unique(row_col_tmp,'rows'); - - max_Hx_c = length(find(mode(ic)==ic)); - - %know which exact M09 tiles are actually administering the obs - %------------------- - tmp_lon = central_lon(ia)+tmp_shift_lon; - tmp_lat = central_lat(ia)+tmp_shift_lat; - - [N_tile_in_cell_ij, tile_num_in_cell_ij] = get_tile_num_in_cell_ij( ... - tile_coord, tile_grid); - - this_FOV = 20; - option = 'FOV_in_km'; - %overwrite ia with actual administering tile number - [ia] = get_tile_num_for_obs( tile_coord, tile_grid, ... - N_tile_in_cell_ij, tile_num_in_cell_ij, ... - option, this_FOV, tmp_lat, tmp_lon); - - ia = ia(ia>0 & ~isnan(ia)); - - obsnum = NaN+zeros(length(ic),1); - obsnum(ia) = [1:length(ia)]; - - N_tile_obs = length(ia); - - %------------------- - - if store_all_M09inM36 - - %Not maintained/elaborated - tile_coord_tile_id = zeros(N_tile_obs,max_Hx_c); - - disp(['centralizing obs on ',convert_grid,' grid before doing stats: max ',num2str(max_Hx_c),'tiles per obs cell']) - - for i=1:N_tile_obs - - tmp_ind = find(row_col_tmp(:,1) == unique_rc(i,1) & row_col_tmp(:,2) == unique_rc(i,2)); - - tile_coord_tile_id(i,1:length(tmp_ind)) = tile_coord.tile_id(tmp_ind); - - end - - else - - tile_coord_tile_id = tile_coord.tile_id(ia); - - end - -else - - N_tile_obs = N_tile; - ia = 1:N_tile; - ic = 1:N_tile; - obsnum = 1:N_tile; - -end - -lon_out = tile_coord.com_lon(ia); %NaN+zeros(N_tile,1); -lat_out = tile_coord.com_lat(ia); %NaN+zeros(N_tile,1); - -if hscale>0 - - for i=1:N_tile_obs - - this_lat = lat_out(i); - this_lon = lon_out(i); - - tmp_sq_distance = ... - (central_lon - this_lon).^2 + ... - (central_lat - this_lat).^2; - - hscale_ind{i} = find( tmp_sq_distance <= hscale^2 ); - end - -else - - hscale_ind = num2cell(ia); - -end - - -% initialize output statistics -% Note: Rolf suggests to have all species as one dimension, rather than -% N_pol and N_angle be specified here. Then subsample specifically -% when the files are written out. - -o_data = NaN+zeros(N_pol,N_tile_obs,N_angle,w_days); -m_data = NaN+zeros(N_pol,N_tile_obs,N_angle,w_days); -o_data2 = NaN+zeros(N_pol,N_tile_obs,N_angle,w_days); -m_data2 = NaN+zeros(N_pol,N_tile_obs,N_angle,w_days); -N_data = NaN+zeros(N_pol,N_tile_obs,N_angle,w_days); - -data_out = NaN+zeros(N_out_fields,N_tile_obs,N_angle); - -% ------------------------------------------------------------- - -% make sure t0_assim is *first* analysis time in a day - -t0_assim = mod( t0_assim, dt_assim ); - -count = 0; - -for imonth = 1:length(run_months) - - month = run_months(imonth); - - for day = 1:days_in_month( 2014, month) %2014 = random non-leap year - - if count < w_days - count = count + 1; - else - count = w_days; - end - - for seconds_in_day = t0_assim:dt_assim:(86400-1) - - hour = floor(seconds_in_day/3600); - - % check if diurnal stats are needed - - if exist('time_of_day_in_hours','var') - tmp_hour = time_of_day_in_hours; - else - tmp_hour = hour; % all hours of day will be included - end - - if hour==tmp_hour - - minute = floor( (seconds_in_day-hour*3600)/60 ); - - seconds = seconds_in_day-hour*3600-minute*60; - - if (seconds~=0) - input('something is wrong! Ctrl-c now') - end - - for year = start_year(imonth):end_year(imonth) - - YYYYMMDD = [ num2str(year, '%4.4d'), ... - num2str(month, '%2.2d'), ... - num2str(day, '%2.2d') ]; - - HHMM = [ num2str(hour, '%2.2d'), ... - num2str(minute, '%2.2d') ]; - - % read innov files - - fname = [ inpath, '/ana/ens_avg/', ... - 'Y', YYYYMMDD(1:4), '/', ... - 'M', YYYYMMDD(5:6), '/', ... - exp_run, '.ens_avg.ldas_ObsFcstAna.', ... - YYYYMMDD, '_', HHMM, 'z.bin' ]; - - ifp = fopen( fname, 'r', 'l' ); - - if (ifp > 0) % Proceed only if file exists (e.g. irregular SMOS swaths!) - - fclose(ifp); - - [ date_time, ... - obs_assim, ... - obs_species, ... - obs_tilenum, ... - obs_lon, ... - obs_lat, ... - obs_obs, ... - obs_obsvar, ... - obs_fcst, ... - obs_fcstvar, ... - obs_ana, ... - obs_anavar ... - ] = ... - read_ObsFcstAna( fname ); - - % remove tiles where obs_fcst is no-data (note: read_ObsFcstAna() returns NaN) - - idx = isnan(obs_fcst); - - obs_assim( idx) = []; - obs_species(idx) = []; - obs_tilenum(idx) = []; - obs_lon( idx) = []; - obs_lat( idx) = []; - obs_obs( idx) = []; - obs_obsvar( idx) = []; - obs_fcst( idx) = []; - obs_fcstvar(idx) = []; - obs_ana( idx) = []; - obs_anavar( idx) = []; - - % extract species of interest - - ind = []; - - for this_species = species - - ind = find( obs_species == this_species); - - if (~isempty(ind)) - - obs_tilenum_i = obs_tilenum(ind); - obs_obs_i = obs_obs(ind); - obs_fcst_i = obs_fcst(ind); - obs_lon_i = obs_lon(ind); - obs_lat_i = obs_lat(ind); - - % Check if any location receives more than 1 obs (or 1 species) - - tmp = sort(obs_tilenum_i); - same_tile = find(diff(tmp)==0); - - if (~isempty(same_tile)) - error('multiple obs of the same species at one location? - only last one in line is used'); - end - - % Organize the data in a big matrix - - angle = obs_param(this_species == [obs_param.species]).ang; - pol = obs_param(this_species == [obs_param.species]).pol; - - % pol intrinsically gives an index - % now find the index for the angle - angle_i = find(angle(1) == inc_angle); - - % Only writes lat-lon at exact obs locations, but with - % hscale>0, these obs are spread outside their exact - % location. This allows to calculate stats at lan-lons - % where no obs are available. - - %lon_out(obs_tilenum_i) = obs_lon_i; - %lat_out(obs_tilenum_i) = obs_lat_i; - - % obs_lat/lon are the actual M36 lat/lons, *not* the - % administering tiles, so the lat/lons for the obs and those - % in the tile_coord would not be identical. - % Still, they should be in the - % neighbourhood, so check here if that is true. - if (any(abs(tile_coord.com_lat(obs_tilenum_i)-obs_lat_i) > tol) || ... - any(abs(tile_coord.com_lon(obs_tilenum_i)-obs_lon_i) > tol) ) - error('Something wrong with tile_lat/lon') - end - - % map model tiles (e.g. all M09) to observation administering - % tiles (could be a reduced subset of all M09) - % -------------------------------------------------------- - obs_i = obsnum(obs_tilenum_i); - % -------------------------------------------------------- - - if (hscale == 0) - - % 11 May 2015: sum the obs and fcst within each day; - % and across years! - % some obs can be found at multiple hours within a day - % e.g. at the poles. - % **sum(...,"omitnan") of NaNs** results in zero, this need to be - % taken care of - o_data( pol(1),obs_i,angle_i,count) = sum([o_data( pol(1),obs_i,angle_i,count); obs_obs_i' ], "omitnan"); - m_data( pol(1),obs_i,angle_i,count) = sum([m_data( pol(1),obs_i,angle_i,count); obs_fcst_i' ], "omitnan"); - - % X^2 - o_data2(pol(1),obs_i,angle_i,count) = sum([o_data2(pol(1),obs_i,angle_i,count); obs_obs_i'.^2 ], "omitnan"); - m_data2(pol(1),obs_i,angle_i,count) = sum([m_data2(pol(1),obs_i,angle_i,count); obs_fcst_i'.^2 ], "omitnan"); - - % Sum of obs or model elements at each location - N_data(pol(1), obs_i,angle_i,count) = sum([N_data( pol(1),obs_i,angle_i,count); ~isnan([obs_obs_i])'], "omitnan"); - - else - - for i_ind = 1:length(obs_obs_i) - - % introduce a spatial effect of each observation on - % neighbouring statistics (through hscale) - s_eff = unique(hscale_ind{obs_i(i_ind)}); - %hscale_ind =[obs space] % - - % Sum of X - o_data(pol(1),s_eff,angle_i,count) = ... - sum([o_data( pol(1),s_eff,angle_i,count); repmat( obs_obs_i( i_ind), 1,length(s_eff))], "omitnan"); - m_data(pol(1),s_eff,angle_i,count) = ... - sum([m_data( pol(1),s_eff,angle_i,count); repmat( obs_fcst_i(i_ind), 1,length(s_eff))], "omitnan"); - - % Sum of X^2 - o_data2(pol(1),s_eff,angle_i,count) = ... - sum([o_data2(pol(1),s_eff,angle_i,count); repmat( obs_obs_i( i_ind).^2,1,length(s_eff))], "omitnan"); - m_data2(pol(1),s_eff,angle_i,count) = ... - sum([m_data2(pol(1),s_eff,angle_i,count); repmat( obs_fcst_i(i_ind).^2,1,length(s_eff))], "omitnan"); - - % Sum of obs or model elements at each location - N_data(pol(1),s_eff,angle_i,count) = ... - sum([N_data( pol(1),s_eff,angle_i,count); repmat(~isnan([obs_obs_i(i_ind)]), 1,length(s_eff))], "omitnan"); - - end - - end % (hscale == 0) - - end % ~isempty(ind) - - end % species - - end % if file present - - end % loop over multiple years - - end % hour == tmp_hour (time_of_day_in_hours) - - end % seconds_in_day - - %count = count+1; - - if count >= w_days %wait initially until enough data is built up - - end_time.year = 2014; - end_time.month = month; - end_time.day = day; - end_time.hour = hour; - end_time.min = minute; - end_time.sec = seconds; - - start_time = augment_date_time( -floor(w_days*(24*60*60)), end_time ); - - % At the end of each day, collect the obs and fcst of the last - % w_day period, and write out a statistics-file at [w_day - floor(w_day/2)] - - o_data(abs(o_data - nodata) <= nodata_tol) = NaN; - m_data(abs(o_data - nodata) <= nodata_tol) = NaN; - - % data_out = zeros(N_out_fields,1:N_tiles,N_angle); - - for pol=[0 1] - - pp = pol*Nf; - - N_hscale_window = sum(N_data(1+pol,:,:,1:w_days), 4,"omitnan"); - - if w_days == 95 - N_hscale_inner_window = sum(N_data(1+pol,:,:,((w_days+1)/2-15):((w_days+1)/2+15)),4,"omitnan"); - end - - % OBSERVATIONS - %---------------- - % o_data is a sum over neighbouring obs above; - % here then take a sum over the time steps in the window - data_out(1+pp,:,:) = sum( o_data( 1+pol,:,:,1:w_days),4,"omitnan"); - - % then make the average, by dividing over the sum of the number of - % timesteps and influencing obs at each location - data_out(1+pp,:,:) = data_out( 1+pp, :,:)./N_hscale_window; - - %stdv_H = sqrt(E[X^2] - E[X]^2) - data_out(2+pp,:,:) = sum( o_data2( 1+pol,:,:,1:w_days),4,"omitnan"); - data_out(2+pp,:,:) = data_out( 2+pp, :,:)./N_hscale_window; - data_out(2+pp,:,:) = sqrt( data_out( 2+pp, :,:) - data_out(1+pp,:,:).^2); - - % MODEL - %---------------- - data_out(3+pp,:,:) = sum( m_data( 1+pol,:,:,1:w_days),4,"omitnan"); - data_out(3+pp,:,:) = data_out( 3+pp, :,:)./N_hscale_window; - - data_out(4+pp,:,:) = sum( m_data2( 1+pol,:,:,1:w_days),4,"omitnan"); - data_out(4+pp,:,:) = data_out( 4+pp, :,:)./N_hscale_window; - data_out(4+pp,:,:) = sqrt( data_out( 4+pp, :,:) - data_out(3+pp,:,:).^2); - - data_out(5+pp,:,:) = N_hscale_window; - - % Toss out stats that are based on too little data - - data_out( [1:5]+pp,N_hscale_window < Ndata_min ) = NaN; - - if w_days == 95 - data_out([1:5]+pp,N_hscale_inner_window < (Ndata_min/2.5)) = NaN; - end - - end - - % Get the actual obs/model at the center point (for debugging only!!) - - data_out(11,:,:) = o_data(1,:,:,w_days-floor(w_days/2.0))./N_data(1,:,:,w_days-floor(w_days/2.0)); - data_out(12,:,:) = m_data(1,:,:,w_days-floor(w_days/2.0))./N_data(1,:,:,w_days-floor(w_days/2.0)); - data_out(13,:,:) = o_data(2,:,:,w_days-floor(w_days/2.0))./N_data(2,:,:,w_days-floor(w_days/2.0)); - data_out(14,:,:) = m_data(2,:,:,w_days-floor(w_days/2.0))./N_data(2,:,:,w_days-floor(w_days/2.0)); - - % Get rid of NaN before writing a file - - data_out(isnan(data_out)) = nodata; - %lon_out(isnan(lon_out)) = nodata; - %lat_out(isnan(lat_out)) = nodata; - - % write output file - - date_time = end_time; - date_time = augment_date_time( -floor(w_days*(24*60*60)/2.0), date_time ); - - % always 365 files - - DOY = date_time.dofyr; - - if(is_leap_year(date_time.year) && DOY>=59) - - DOY = DOY-1; - - error('This code should never hit a leap year'); - - end - - - fname_out = [fname_out_base, '_DOY', num2str(DOY,'%3.3d'), '.bin']; - - % check whether output file exists - - if (exist(fname_out)==2 && overwrite) - - disp(['output file exists. overwriting', fname_out]) - - elseif (exist(fname_out)==2 && ~overwrite) - - disp(['output file exists. not overwriting. returning']) - disp(['writing ', fname_out]) - return - - else - - disp(['creating ', fname_out]) - - end - - % write output for each DOY, sorted by all tiles - - if print_each_DOY - - write_seqbin_file(fname_out, lon_out, lat_out, ... - inc_angle, data_out(:,:,:), int_Asc, 0, ... % instead of writing the version#, write Ndata_min=0 - start_time, end_time, overwrite, ... - N_out_fields, write_ind_latlon, 'scaling', ... - tile_coord_tile_id) - else - - % if DOY is at middle of pentad, then copy the DOY to a pentad file - % DOY = pentad*5 - 2; ==> pentad = (DOY + 2)/5; - - pentad = (DOY + 2)/5; - - if mod((DOY + 2),5) == 0 - - write_seqbin_file(fname_out, lon_out, lat_out, ... - inc_angle, data_out(:,:,:), int_Asc, 0, ... - start_time, end_time, overwrite, ... - N_out_fields, write_ind_latlon, 'scaling', ... - tile_coord_tile_id) - - fname_out_p = [fname_out_base_p, '_p', num2str(pentad,'%2.2d'), '.bin']; - - copyfile(fname_out,fname_out_p); - - end - - end - - %clear idx_keep lon_out_write lat_out_write data_out_write tile_coord_tile_id_write - - % shift the window by one day and make room for the next day at the end - - o_data( :,:,:,1:w_days-1) = o_data( :,:,:,2:w_days); - m_data( :,:,:,1:w_days-1) = m_data( :,:,:,2:w_days); - o_data2(:,:,:,1:w_days-1) = o_data2(:,:,:,2:w_days); - m_data2(:,:,:,1:w_days-1) = m_data2(:,:,:,2:w_days); - N_data( :,:,:,1:w_days-1) = N_data( :,:,:,2:w_days); - - o_data( :,:,:,w_days) = NaN; - m_data( :,:,:,w_days) = NaN; - o_data2(:,:,:,w_days) = NaN; - m_data2(:,:,:,w_days) = NaN; - N_data( :,:,:,w_days) = NaN; - - data_out = NaN+0.0.*data_out; - - end - - end % day -end % month - - -% ==================== EOF ============================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m deleted file mode 100644 index 1d3a0c74..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_model_and_obs_clim_stats_latlon_grid.m +++ /dev/null @@ -1,352 +0,0 @@ - -function [] = get_model_and_obs_clim_stats_latlon_grid( species_names, ... - run_months, exp_path, exp_run, domain, start_year, end_year, ... - dt_assim, t0_assim, species, combine_species_stats, ... - resol, w_days, Ndata_min, prefix, print_each_DOY, ... - print_each_pentad, print_all_pentads,out_dir ) -% -% Adapted from get_model_and_obs_clim_stats.m -% -% Compute mean, stdv of model and observations from tile-based -% "innov" files for a selection of species on an Earth-fixed global -% lat/lon grid with resolution "resol". -% -% The main purpose of this function is to aggregate the information -% from the "innov" files so that the climatology statistics can -% be used in scaling of the observations before assimilation. -% -% One file with statistics is generated for every DOY (1,...,365). -% The temporal smoothing/averaging window (w_days) is given in days. -% -% We calculate the bias correction factors (scaling parameters) and -% write on an Earth-fixed lat/lon grid as there is no Earth-fixed -% regular grid for ASCAT observations. -% -% A. M. Fox - 27 Oct 2023 -% -% ------------------------------------------------------------------- -% begin user-defined inputs -% ------------------------------------------------------------------- - -nodata = -9999; -nodata_tol = 1e-4; -overwrite = 1; -Nf = 7; -N_pentads = 73; - -disp('ASSUMING obs are not on Earth-fixed regular grid (e.g., ASCAT)'); -disp(['Calculating scaling parameters on grid with resolution = ', num2str(resol) , ' degrees']); - -if combine_species_stats - N_species = 1; -else - N_species = length(species); -end - -inpath = [ exp_path, '/', exp_run, '/output/', domain ]; - -outpath = [ inpath, '/stats/', out_dir ]; - -% create outpath if it doesn't exist -if ~exist(outpath, 'dir') - mkdir(outpath); -end - -% assemble output file name -ind = start_year == min(start_year); -mi_m = min(run_months(ind)); -ind = end_year == max(end_year); -ma_m = max(run_months(ind)); - -D(1) = 1; -P(1) = 1; -if mi_m > 1 - D(1) = sum(days_in_month(2014, 1:mi_m-1)) + 1; - P(1) = ceil(D(1) / 5); -end -D(2) = sum(days_in_month(2014, 1:ma_m)); -P(2) = floor(D(2) / 5); - -fname_out_base_d = [outpath, '/', prefix, ... - num2str(min(start_year)), '_doy', num2str(D(1)), '_', ... - num2str(max(end_year)), '_doy', num2str(D(2)), ... - '_W_', num2str(w_days), 'd_Nmin_', num2str(Ndata_min)]; - -fname_out_base_p = [outpath, '/', prefix, ... - num2str(min(start_year)), '_p', num2str(P(1)), '_', ... - num2str(max(end_year)), '_p', num2str(P(2)), ... - '_W_', num2str(round(w_days/5)), 'p_Nmin_', num2str(Ndata_min)]; - -%====================================================== - -% Define lat/lon grid (dateline-on-edge, pole-on-edge) -% Define lower-left corner coordinates and grid cell size -ll_lon = -180; -ll_lat = -90; - -d_lon = resol; -d_lat = resol; - -% Calculate number of longitude and latitude grid cells -n_lon = round(360 / d_lon); -n_lat = round(180 / d_lat); - -% Calculate longitude and latitude values for the grid -ll_lons = linspace(ll_lon, ll_lon + (n_lon-1)*d_lon, n_lon); -ll_lats = linspace(ll_lat, ll_lat + (n_lat-1)*d_lat, n_lat); - -% Create grid index -obsnum = (1:n_lon*n_lat)'; -[i_out, j_out] = ind2sub([n_lon, n_lat], obsnum); -lon_out = ll_lons(i_out)'; -lat_out = ll_lats(j_out)'; -N_gridcells = length(obsnum); - -% initialize output statistics -o_data_sum = NaN(N_species, N_gridcells, w_days); -m_data_sum = NaN(N_species, N_gridcells, w_days); -o_data_sum2 = NaN(N_species, N_gridcells, w_days); -m_data_sum2 = NaN(N_species, N_gridcells, w_days); -m_data_min = NaN(N_species, N_gridcells, w_days); -m_data_max = NaN(N_species, N_gridcells, w_days); -N_data = NaN(N_species, N_gridcells, w_days); - -data_out = NaN(N_species, Nf, N_gridcells, N_pentads); -data2D = NaN(Nf, N_gridcells); - -% ------------------------------------------------------------- - -% make sure t0_assim is *first* analysis time in a day - -t0_assim = mod( t0_assim, dt_assim ); - -count = 0; - -for imonth = 1:length(run_months) - - month = run_months(imonth); - - for day = 1:days_in_month( 2014, month) %2014 = random non-leap year - - if count < w_days - count = count + 1; - else - count = w_days; - end - - for seconds_in_day = t0_assim:dt_assim:(86400-1) - - hour = floor( seconds_in_day/3600); - minute = floor((seconds_in_day-hour*3600)/60); - seconds = seconds_in_day-hour*3600-minute*60; - - if (seconds ~= 0) - input('something is wrong! Ctrl-c now') - end - - for year = start_year(imonth):end_year(imonth) - - YYYYMMDD = [num2str(year, '%4.4d'), num2str(month, '%2.2d'), num2str(day, '%2.2d')]; - HHMM = [num2str(hour, '%2.2d'), num2str(minute, '%2.2d')]; - - % read innov files - fname = [inpath, '/ana/ens_avg/', 'Y', YYYYMMDD(1:4), '/', 'M', YYYYMMDD(5:6), '/', exp_run, '.ens_avg.ldas_ObsFcstAna.', YYYYMMDD, '_', HHMM, 'z.bin']; - ifp = fopen(fname, 'r', 'l'); - - if (ifp > 0) % Proceed only if file exists - fclose(ifp); - [date_time, obs_assim, obs_species, obs_tilenum, obs_lon, obs_lat, obs_obs, obs_obsvar, obs_fcst, obs_fcstvar, obs_ana, obs_anavar] = read_ObsFcstAna(fname); - - % remove tiles where obs_fcst is no-data (note: read_ObsFcstAna() returns NaN) - - idx = isnan(obs_fcst); - - obs_assim( idx) = []; - obs_species(idx) = []; - obs_tilenum(idx) = []; - obs_lon( idx) = []; - obs_lat( idx) = []; - obs_obs( idx) = []; - obs_obsvar( idx) = []; - obs_fcst( idx) = []; - obs_fcstvar(idx) = []; - obs_ana( idx) = []; - obs_anavar( idx) = []; - - % extract species of interest - ind = []; - for scnt = 1:N_species - - if combine_species_stats - ind = find(ismember(obs_species, species)); - else - this_species = species(scnt); - ind = find(obs_species == this_species); - end - - if ~isempty(ind) - obs_tilenum_i = obs_tilenum(ind); - obs_obs_i = obs_obs( ind); - obs_fcst_i = obs_fcst( ind); - obs_lon_i = obs_lon( ind); - obs_lat_i = obs_lat( ind); - - % Check if any location receives more than 1 obs (or 1 species) - tmp = sort(obs_tilenum_i); - same_tile = find(diff(tmp) == 0, 1); - if ~isempty(same_tile) && ~combine_species_stats - error('multiple obs of the same species at one location? - only last one in line is used'); - end - - % Put obs lat/lon on our grid and figure out obsnum/grid index - i_idx = floor((obs_lon_i - ll_lon) / d_lon) + 1; - j_idx = floor((obs_lat_i - ll_lat) / d_lat) + 1; - [~, obs_idx] = ismember([i_idx, j_idx], [i_out, j_out], 'rows'); - obs_i = obsnum(obs_idx); - - o_data_sum( scnt, obs_i, count) = sum([o_data_sum( scnt, obs_i, count); obs_obs_i' ], "omitnan"); - m_data_sum( scnt, obs_i, count) = sum([m_data_sum( scnt, obs_i, count); obs_fcst_i' ], "omitnan"); - o_data_sum2(scnt, obs_i, count) = sum([o_data_sum2(scnt, obs_i, count); obs_obs_i'.^2 ], "omitnan"); - m_data_sum2(scnt, obs_i, count) = sum([m_data_sum2(scnt, obs_i, count); obs_fcst_i'.^2 ], "omitnan"); - m_data_min( scnt, obs_i, count) = min([m_data_min( scnt, obs_i, count); obs_fcst_i' ] ); - m_data_max( scnt, obs_i, count) = max([m_data_max( scnt, obs_i, count); obs_fcst_i' ] ); - N_data( scnt, obs_i, count) = sum([N_data( scnt, obs_i, count); ~isnan(obs_obs_i)' ], "omitnan"); - end - end - end - end - end - - if count >= w_days %wait initially until enough data is built up - end_time.year = 2014; - end_time.month = month; - end_time.day = day; - end_time.hour = hour; - end_time.min = minute; - end_time.sec = seconds; - - start_time = augment_date_time( -floor(w_days*(24*60*60)), end_time ); - - % At the end of each day, collect the obs and fcst of the last - % w_day period, and write out a statistics-file at [w_day - floor(w_day/2)] - o_data_sum(abs(o_data_sum - nodata) <= nodata_tol) = NaN; - m_data_sum(abs(m_data_sum - nodata) <= nodata_tol) = NaN; - - for i = 1:N_species - - N_window = sum(N_data( i,:,1:w_days), 3,"omitnan"); - - data2D(1,:) = sum(o_data_sum( i,:,1:w_days), 3,"omitnan")./N_window; - data2D(2,:) = sqrt(sum(o_data_sum2(i,:,1:w_days), 3,"omitnan")./N_window - data2D(1,:).^2); - data2D(3,:) = sum(m_data_sum( i,:,1:w_days), 3,"omitnan")./N_window; - data2D(4,:) = sqrt(sum(m_data_sum2(i,:,1:w_days), 3,"omitnan")./N_window - data2D(3,:).^2); - data2D(5,:) = N_window; - data2D(6,:) = min(m_data_min( i,:,1:w_days),[],3); % Want to use minimum mean daily value - data2D(7,:) = max(m_data_max( i,:,1:w_days),[],3); % Want to use maximum mean daily value - - % Set NaNs where there is not enough data - data2D([1:Nf],N_window=59) - error('This code should never hit a leap year'); - end - - if print_each_DOY - pentad = floor((DOY + 2)/5); - if combine_species_stats - fname_out = [fname_out_base_d, '_sp_ALL_DOY', num2str(DOY,'%3.3d'), '.nc4']; - else - fname_out = [fname_out_base_d,'_sp_', char(species_names(i)),'_DOY', num2str(DOY,'%3.3d'), '.nc4']; - end - if (exist(fname_out)==2 && overwrite) - disp(['Output file exists. overwriting', fname_out]) - elseif (exist(fname_out)==2 && ~overwrite) - disp(['Output file exists. not overwriting. returning']) - disp(['Writing ', fname_out]) - return - else - disp(['Creating ', fname_out]) - end - - % Write out the data - write_netcdf_latlon_grid( fname_out, i_out, j_out, ll_lons, ll_lats, data2D, pentad, ... - start_time, end_time, overwrite, Nf, ll_lon, ll_lat, d_lon, d_lat) - end - - if mod((DOY + 2),5) == 0 - pentad = (DOY + 2)/5; - data_out(i,:,:,pentad) = data2D; - start_time_p(pentad) = start_time; - end_time_p(pentad) = end_time; - if print_each_pentad - if combine_species_stats - fname_out = [fname_out_base_p, '_sp_ALL_p', num2str(pentad,'%2.2d'), '.nc4']; - else - fname_out = [fname_out_base_p, '_sp_', char(species_names(i)),'_p', num2str(pentad,'%2.2d'), '.nc4']; - end - if (exist(fname_out)==2 && overwrite) - disp(['Output file exists. overwriting', fname_out]) - elseif (exist(fname_out)==2 && ~overwrite) - disp(['Output file exists. not overwriting. returning']) - disp(['Writing ', fname_out]) - return - else - disp(['Creating ', fname_out]) - end - - % Write out the data - write_netcdf_latlon_grid( fname_out, i_out, j_out, ll_lons, ll_lats, data2D, pentad, ... - start_time, end_time, overwrite, Nf, ll_lon, ll_lat, d_lon, d_lat ) - end - end - - % Shift the data in the window to make room for next day - o_data_sum( i,:,1:w_days-1) = o_data_sum( i,:,2:w_days); - m_data_sum( i,:,1:w_days-1) = m_data_sum( i,:,2:w_days); - o_data_sum2(i,:,1:w_days-1) = o_data_sum2(i,:,2:w_days); - m_data_sum2(i,:,1:w_days-1) = m_data_sum2(i,:,2:w_days); - m_data_min( i,:,1:w_days-1) = m_data_min( i,:,2:w_days); - m_data_max( i,:,1:w_days-1) = m_data_max( i,:,2:w_days); - N_data( i,:,1:w_days-1) = N_data( i,:,2:w_days); - o_data_sum( i,:,w_days ) = NaN; - m_data_sum( i,:,w_days ) = NaN; - o_data_sum2(i,:,w_days ) = NaN; - m_data_sum2(i,:,w_days ) = NaN; - m_data_min( i,:,w_days ) = NaN; - m_data_max( i,:,w_days ) = NaN; - N_data( i,:,w_days ) = NaN; - - data2D = NaN+0.0.*data2D; - end - end % count >= w_days - end % day -end % month - -if print_all_pentads - for i = 1:N_species - data_o = squeeze(data_out(i,:,:,:)); - - if combine_species_stats - fname_out = [fname_out_base_d, '_sp_ALL_all_pentads.nc4']; - else - fname_out = [fname_out_base_d,'_sp_', char(species_names(i)),'_all_pentads.nc4']; - end - - if (exist(fname_out)==2 && overwrite) - disp(['Output file exists. overwriting', fname_out]) - elseif (exist(fname_out)==2 && ~overwrite) - disp(['Output file exists. not overwriting. returning']) - disp(['Writing ', fname_out]) - return - else - disp(['Creating ', fname_out]) - end - - write_netcdf_latlon_grid( fname_out, i_out, j_out, ll_lons, ll_lats, data_o, [1:73], ... - start_time_p, end_time_p, overwrite, Nf, ll_lon, ll_lat, d_lon, d_lat ) - end -end - - -% ==================== EOF ============================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m deleted file mode 100644 index 559853cf..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_for_obs.m +++ /dev/null @@ -1,125 +0,0 @@ -%========================================================================= - -function [tile_num] = get_tile_num_for_obs(tile_coord, tile_grid,... - N_tile_in_cell_ij, tile_num_in_cell_ij, ... - option, this_FOV, lat, lon) - - N_dat = length(lat); - -% find one tile for each obs that "administers" the obs - -% get "max_dist" in deg lat/lon from field-of-view (FOV) -% -% "max_dist" = Maximum distance allowed between obs lat/lon and tile com_lat/com_lon -% when searching for a tile to which the obs will be assigned. -% -% NOTE: Subroutine get_tile_num_from_latlon() computes distances in Minkowski norm. - - if ~isempty(strfind(option,'FOV_in_deg')) - - max_dist_y = this_FOV; - max_dist_x(1:N_dat) = this_FOV; - - elseif ~isempty(strfind(option,'FOV_in_km')) - - % convert from [km] (FOV) to [deg] (max_dist_*) - - [max_dist_x, max_dist_y] = dist_km2deg( this_FOV, lat); - - else - - error('unknown FOV_option') - - end - - if (max_dist_y<0. || any(max_dist_x<0.)) - error('encountered negative max_dist'); - end - - tile_num = zeros(N_dat,1); - - for n=1:N_dat - - % make sure lat/lon is *inside* tile_grid (to within "max_dist"), - % otherwise do nothing - - if ( tile_grid.ll_lat <= (lat(n)+max_dist_y ) &&... - tile_grid.ll_lon <= (lon(n)+max_dist_x(n)) &&... - (lat(n)-max_dist_y ) <= tile_grid.ur_lat &&... - (lon(n)-max_dist_x(n)) <= tile_grid.ur_lon ) - - % min_dist = distance betw lat/lon in question and center-of-mass of - % matching tile - - min_dist_x = 1.e10; % initialize - min_dist_y = 1.e10; % initialize - - % determine grid cell that contains lat/lon - - [i_ind,j_ind] = get_ij_ind_from_latlon( tile_grid, lat(n), lon(n)); - - % make sure that i/j_ind is still within bounds - % (works in conjunction with if statement above re. ll/ur_lat/lon) - - i_ind = min( max(i_ind, 1), tile_grid.N_lon ); - j_ind = min( max(j_ind, 1), tile_grid.N_lat ); - - % map from i_ind, j_ind to tile_num - - if ( ~isempty(strfind(tile_grid.gridtype, 'EASE_M')) || ... - ~isempty(strfind(tile_grid.gridtype, 'EASE-M')) || ... - ~isempty(strfind(tile_grid.gridtype, 'EASEv2-M')) || ... - ~isempty(strfind(tile_grid.gridtype, 'EASEv2_M')) ) - - % ASSUMPTION: tiles match EASE or EASEv2 grid cells exactly - % (unless "outside" the domain, eg. water surface) - - if (N_tile_in_cell_ij(i_ind,j_ind)==1) - - tile_num(n)=tile_num_in_cell_ij(i_ind,j_ind,1); - - min_dist_x = abs(lon(n) - tile_coord.com_lon(tile_num(n))); - min_dist_y = abs(lat(n) - tile_coord.com_lat(tile_num(n))); - - elseif (N_tile_in_cell_ij(i_ind,j_ind)==0) - - % Do nothing. If given EASE or EASEv2 grid cell is not land, - % tile_num will not change from its initialized value. - - else - - error( 'something wrong for EASE grid'); - - end - - else - error('not ready'); - end - - if (tile_num(n)>0) - - outside_bbox = ( ... - lon(n) < tile_coord.min_lon(tile_num(n)) || ... - lon(n) > tile_coord.max_lon(tile_num(n)) || ... - lat(n) < tile_coord.min_lat(tile_num(n)) || ... - lat(n) > tile_coord.max_lat(tile_num(n)) ); - - too_far_away = ( ... - min_dist_x > max_dist_x(n) || ... - min_dist_y > max_dist_y ); - - % keep tile_num unless obs is outside the bounding box *and* too far away - - if (outside_bbox && too_far_away) - tile_num(n) = NaN; - end - - end - - end - - end - -end - -%========================================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m deleted file mode 100644 index 51090891..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/get_tile_num_in_cell_ij.m +++ /dev/null @@ -1,42 +0,0 @@ -%========================================================================= - -function [N_tile_in_cell_ij, tile_num_in_cell_ij] = ... - get_tile_num_in_cell_ij(tile_coord, tile_grid) - - % Initialize - - max_tile_in_cell = 10; %for EASE grids, this is really just 1 - - tile_num_in_cell_ij = NaN+zeros(tile_grid.N_lon,tile_grid.N_lat,max_tile_in_cell); - - % adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid.i_offg + (tile_grid.ind_base - 1); - off_j = tile_grid.j_offg + (tile_grid.ind_base - 1); - - % (re-)initialize - - N_tile_in_cell_ij = zeros(tile_grid.N_lon,tile_grid.N_lat); - - for n=1:tile_coord.N_tile - - i = tile_coord.i_indg(n) - off_i; - j = tile_coord.j_indg(n) - off_j; - - N_tile_in_cell_ij(i,j) = N_tile_in_cell_ij(i,j) + 1; - - k = N_tile_in_cell_ij(i,j); - - tile_num_in_cell_ij(i,j,k) = n; - - end - - max_N = max(max(N_tile_in_cell_ij)); - - disp(['Maximum number of tiles in tile def grid cell = ', num2str(max_N)]); - - tile_num_in_cell_ij = tile_num_in_cell_ij(:,:,1:max_N); - -end - -%========================================================================= \ No newline at end of file diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m deleted file mode 100644 index 49969ad5..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_netcdf_latlon_grid.m +++ /dev/null @@ -1,232 +0,0 @@ -function [] = write_netcdf_latlon_grid( fname, colind, rowind, ll_lons, ll_lats, ... - data, pentad, start_time, end_time, overwrite, N_out_fields, ll_lon, ll_lat, d_lon, d_lat ) - - int_precision = 'NC_INT'; % precision of fortran tag - float_precision = 'NC_DOUBLE'; % precision of data in input file - - % Define the compression level (0-9, where 0 is no compression and 9 is maximum compression) - compression_level = 5; - - version = 0; - - % check dimensions - if size(data,1)~=N_out_fields - error('ERROR: size of data incompatible with N_out_fields') - end - - % check for presence of optional input "overwrite" - if ~exist('overwrite','var') - overwrite = 0; % default: do NOT overwrite existing files - end - - % check if file exists - if exist(fname,'file') - if overwrite==0 - disp(['RETURNING!!! -- NOT OVERWRITING EXISTING FILE ', fname]) - return - else - disp(['OVERWRITING ', fname]) - end - else - disp(['writing ', fname]) - end - - % Convert the cell arrays to matrices using cell2mat (to deal with all_pentad case) - year_mat = cell2mat({start_time.year}'); - month_mat = cell2mat({start_time.month}'); - day_mat = cell2mat({start_time.day}'); - hour_mat = cell2mat({start_time.hour}'); - min_mat = cell2mat({start_time.min}'); - sec_mat = cell2mat({start_time.sec}'); - % Use the matrices as input to the datetime function - d = datetime(year_mat, month_mat, day_mat, hour_mat, min_mat, sec_mat); - % Convert to serial date number - serialNum = datenum(d); - % Subtract serial date number of January 1, 1950 - daysSince1950 = serialNum - datenum('January 1, 1950'); - tmp_start_time = daysSince1950; - - % Convert the cell arrays to matrices using cell2mat (to deal with all_pentad case) - year_mat = cell2mat({end_time.year}'); - month_mat = cell2mat({end_time.month}'); - day_mat = cell2mat({end_time.day}'); - hour_mat = cell2mat({end_time.hour}'); - min_mat = cell2mat({end_time.min}'); - sec_mat = cell2mat({end_time.sec}'); - % Use the matrices as input to the datetime function - d = datetime(year_mat, month_mat, day_mat, hour_mat, min_mat, sec_mat); - % Convert to serial date number - serialNum = datenum(d); - % Subtract serial date number of January 1, 1950 - daysSince1950 = serialNum - datenum('January 1, 1950'); - tmp_end_time = daysSince1950; - - N_lon = length(ll_lons); - N_lat = length(ll_lats); - - % Have we got multiple pentads - if ismatrix(data) - N_pentad = 1; - else - N_pentad = size(data,3); - end - - % create netCDF file - netcdf.setDefaultFormat('FORMAT_NETCDF4'); - ncid = netcdf.create(fname, 'NETCDF4'); - - % define dimensions - dimid_pentad = netcdf.defDim(ncid, 'pentad', N_pentad); - dimid_lon = netcdf.defDim(ncid, 'lon', N_lon); - dimid_lat = netcdf.defDim(ncid, 'lat', N_lat); - - % define variables - - varid_version = netcdf.defVar(ncid, 'version', int_precision, []); - - varid_ll_lon = netcdf.defVar(ncid, 'll_lon', float_precision, []); - netcdf.putAtt(ncid, varid_ll_lon, 'standard_name', 'longitude of lower left corner'); - netcdf.putAtt(ncid, varid_ll_lon, 'long_name', 'longitude of lower left corner'); - netcdf.putAtt(ncid, varid_ll_lon, 'units', 'degrees_east'); - netcdf.putAtt(ncid, varid_ll_lon, 'axis', 'X'); - - varid_ll_lat = netcdf.defVar(ncid, 'll_lat', float_precision, []); - netcdf.putAtt(ncid, varid_ll_lat, 'standard_name', 'latitude of lower left corner'); - netcdf.putAtt(ncid, varid_ll_lat, 'long_name', 'latitude of lower left corner'); - netcdf.putAtt(ncid, varid_ll_lat, 'units', 'degrees_north'); - netcdf.putAtt(ncid, varid_ll_lat, 'axis', 'Y'); - - varid_d_lon = netcdf.defVar(ncid, 'd_lon', float_precision, []); - netcdf.putAtt(ncid, varid_d_lon, 'standard_name', 'longitude grid spacing'); - netcdf.putAtt(ncid, varid_d_lon, 'long_name', 'longitude grid spacing'); - netcdf.putAtt(ncid, varid_d_lon, 'units', 'degrees'); - netcdf.putAtt(ncid, varid_d_lon, 'axis', 'X'); - - varid_d_lat = netcdf.defVar(ncid, 'd_lat', float_precision, []); - netcdf.putAtt(ncid, varid_d_lat, 'standard_name', 'latitude grid spacing'); - netcdf.putAtt(ncid, varid_d_lat, 'long_name', 'latitude grid spacing'); - netcdf.putAtt(ncid, varid_d_lat, 'units', 'degrees'); - netcdf.putAtt(ncid, varid_d_lat, 'axis', 'Y'); - - varid_pentad = netcdf.defVar(ncid, 'pentad', int_precision, [dimid_pentad]); - netcdf.putAtt(ncid, varid_pentad, 'standard_name', 'pentad'); - netcdf.putAtt(ncid, varid_pentad, 'long_name', 'pentad'); - netcdf.putAtt(ncid, varid_pentad, 'units', '1'); - netcdf.putAtt(ncid, varid_pentad, 'axis', 'T'); - - varid_start_time = netcdf.defVar(ncid, 'start_time', float_precision, [dimid_pentad]); - netcdf.putAtt(ncid, varid_start_time, 'standard_name', 'start time'); - netcdf.putAtt(ncid, varid_start_time, 'long_name', 'start time'); - netcdf.putAtt(ncid, varid_start_time, 'axis', 'T'); - netcdf.putAtt(ncid, varid_start_time, 'units', 'days since 1950-01-01 00:00:00.0 +0000'); - - varid_end_time = netcdf.defVar(ncid, 'end_time', float_precision, [dimid_pentad]); - netcdf.putAtt(ncid, varid_end_time, 'standard_name', 'end time'); - netcdf.putAtt(ncid, varid_end_time, 'long_name', 'end time'); - netcdf.putAtt(ncid, varid_end_time, 'axis', 'T'); - netcdf.putAtt(ncid, varid_end_time, 'units', 'days since 1950-01-01 00:00:00.0 +0000'); - - varid_om = netcdf.defVar(ncid, 'o_mean', float_precision, [dimid_lat dimid_lon dimid_pentad]); - netcdf.defVarDeflate(ncid,varid_om,true,true,compression_level); - netcdf.putAtt(ncid, varid_om, 'standard_name', 'observation mean'); - netcdf.putAtt(ncid, varid_om, 'long_name', 'Observation mean for pentad calculated over all years for window length'); - netcdf.putAtt(ncid, varid_om, 'units', 'Degree of saturation (0-1)'); - - varid_ov = netcdf.defVar(ncid, 'o_std', float_precision, [dimid_lat dimid_lon dimid_pentad]); - netcdf.defVarDeflate(ncid,varid_ov,true,true,compression_level); - netcdf.putAtt(ncid, varid_ov, 'standard_name', 'observation standard deviation'); - netcdf.putAtt(ncid, varid_ov, 'long_name', 'Observation standard deviation for pentad calculated over all years for window length'); - netcdf.putAtt(ncid, varid_ov, 'units', 'Degree of saturation (0-1)'); - - varid_mm = netcdf.defVar(ncid, 'm_mean', float_precision, [dimid_lat dimid_lon dimid_pentad]); - netcdf.defVarDeflate(ncid,varid_mm,true,true,compression_level); - netcdf.putAtt(ncid, varid_mm, 'standard_name', 'model mean'); - netcdf.putAtt(ncid, varid_mm, 'long_name', 'Model mean for pentad calculated over all years for window length'); - netcdf.putAtt(ncid, varid_mm, 'units', 'Surface soil moisture (m^3 m^-3)'); - - varid_mv = netcdf.defVar(ncid, 'm_std', float_precision, [dimid_lat dimid_lon dimid_pentad]); - netcdf.defVarDeflate(ncid,varid_mv,true,true,compression_level); - netcdf.putAtt(ncid, varid_mv, 'standard_name', 'model standard deviation'); - netcdf.putAtt(ncid, varid_mv, 'long_name', 'Model standard deviation for pentad calculated over all years for window length'); - netcdf.putAtt(ncid, varid_mv, 'units', 'Surface soil moisture (m^3 m^-3)'); - - varid_mi = netcdf.defVar(ncid, 'm_min', float_precision, [dimid_lat dimid_lon]); - netcdf.defVarDeflate(ncid,varid_mi,true,true,compression_level); - netcdf.putAtt(ncid, varid_mi, 'standard_name', 'model minimum'); - netcdf.putAtt(ncid, varid_mi, 'long_name', 'Model minimum calculated over all years'); - netcdf.putAtt(ncid, varid_mi, 'units', 'Surface soil moisture (m^3 m^-3)'); - - varid_ma = netcdf.defVar(ncid, 'm_max', float_precision, [dimid_lat dimid_lon]); - netcdf.defVarDeflate(ncid,varid_ma,true,true,compression_level); - netcdf.putAtt(ncid, varid_ma, 'standard_name', 'model maximum'); - netcdf.putAtt(ncid, varid_ma, 'long_name', 'Model maximum calculated over all years'); - netcdf.putAtt(ncid, varid_ma, 'units', 'Surface soil moisture (m^3 m^-3)'); - - varid_ndata = netcdf.defVar(ncid, 'n_data', float_precision, [dimid_lat dimid_lon dimid_pentad]); - netcdf.defVarDeflate(ncid,varid_ndata,true,true,compression_level); - netcdf.putAtt(ncid, varid_ndata, 'standard_name', 'number of data points'); - netcdf.putAtt(ncid, varid_ndata, 'long_name', 'Number of data points for pentad calculated over all years for window length'); - netcdf.putAtt(ncid, varid_ndata, 'units', '1'); - - % end define mode - netcdf.endDef(ncid); - - % write data - netcdf.putVar(ncid, varid_pentad, pentad); - netcdf.putVar(ncid, varid_start_time, tmp_start_time); - netcdf.putVar(ncid, varid_end_time, tmp_end_time); - - netcdf.putVar(ncid, varid_ll_lon, ll_lon); - netcdf.putVar(ncid, varid_ll_lat, ll_lat); - netcdf.putVar(ncid, varid_d_lon, d_lon); - netcdf.putVar(ncid, varid_d_lat, d_lat); - - if N_pentad ==1 - - data_out = ones(N_out_fields,N_lat,N_lon ) * -999.0; - - for n = 1:N_out_fields - for i = 1:length(colind) - data_out(n,rowind(i),colind(i)) = data(n,i); - end - end - - netcdf.putVar(ncid,varid_om, data_out(1,:,:) ); - netcdf.putVar(ncid,varid_ov, data_out(2,:,:) ); - netcdf.putVar(ncid,varid_mm, data_out(3,:,:) ); - netcdf.putVar(ncid,varid_mv, data_out(4,:,:) ); - netcdf.putVar(ncid,varid_mi, data_out(6,:,:) ); - netcdf.putVar(ncid,varid_ma, data_out(7,:,:) ); - netcdf.putVar(ncid,varid_ndata, data_out(5,:,:) ); - - else - - data_out = ones(N_out_fields,N_lat,N_lon,N_pentad) * -999.0; - - for n = 1:N_out_fields - for i = 1:length(colind) - data_out(n,rowind(i),colind(i),:) = data(n,i,:); - end - end - - netcdf.putVar(ncid,varid_om, data_out(1,:,:,:) ); - netcdf.putVar(ncid,varid_ov, data_out(2,:,:,:) ); - netcdf.putVar(ncid,varid_mm, data_out(3,:,:,:) ); - netcdf.putVar(ncid,varid_mv, data_out(4,:,:,:) ); - netcdf.putVar(ncid,varid_ndata, data_out(5,:,:,:) ); - netcdf.putVar(ncid,varid_ma, max(data_out(7,:,:,:),[],4)); % Max over all pentads, always only 2D - - min_data = squeeze(data_out(6, :, :,:)); - min_data(min_data < -9998) = NaN; % Switch current missing value to NaN before calculating min - min_data_out = min(min_data,[],3); - min_data_out(isnan(min_data_out)) = -9999.; - - netcdf.putVar(ncid,varid_mi, min_data_out); % Min over all pentads, always only 2D - end - - % close netCDF file - netcdf.close(ncid); - -end - -% ================ EOF ======================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m deleted file mode 100644 index 14153721..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/inputs/obs_scaling_params/write_seqbin_file.m +++ /dev/null @@ -1,305 +0,0 @@ -function [] = write_seqbin_file(fname, colind, rowind,... - av_angle_bin, data, asc_flag, ... - version, ... - start_time, end_time, overwrite, N_out_fields, ... - write_ind_latlon, data_product,... - tile_id) %last argument is optional - -% write "fortran sequential" tile tavg files (identical to LDASsa output) -% -% optional input: -% -% overwrite = 0 -- do NOT overwrite existing files, print warning -% message, return -% overwrite = 1 -- overwrite existing files, print warning message -% -% De Lannoy, 4 Oct 2010 -% De Lannoy, 26 Sep 2012: added optional argument of tile_id -% used to write scaling files, with ''latlon_id''. -% De Lannoy, 25 Oct 2012: added the processor version number, -% inserted after the Asc_flag. -% ------------------------------------------------------------------ - -%N_out_fields % 1 - Col-index, 0-based; - % 2 - Row-index, 0-based; - %OR (for nearest neighbout) - % 1 - Lon; - % 2 - Lat; - -%N_out_fields % 1 - Tbh; - % 2 - Tbv; - - % 3 - heterogeneity index Tbh - % 4 - heterogeneity index Tbv - - % 5 - # SMOS pixels in EASE grid pixel Tbh - % 6 - # SMOS pixels in EASE grid pixel Tbv - - % 7 - RA Tbh - % 8 - RA Tbv - - %=> repeated for T3 and T4 (9-16) - - %OR FOR SMUDP2: - - % 1 - SM - % 2 - ST - % 3 - opacity - % 4 - Tbh; - % 5 - Tbv; - - % 6 - SM RSTD - % 7 - ST RSTD - % 8 - opac RSTD - - % 9 - stdv in SM (grid cell averaging) - % 10 - # small SMOS pixels inside 1 EASE grid cell; - - % 11 - omega; scattering albedo - % 12 - diff_albedos (om_H-om_V) - % 13 - max_roughness - % 14 - RSTD omega - % 15 - RSTD diff_omega - % 16 - RSTD max_roughness - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -% check dimensions - -if size(data,1)~=N_out_fields - - error('ERROR: size of data incompatible with N_out_fields') - -end - -% check for presence of optional input "overwrite" - -if ~exist('overwrite','var') - - overwrite = 0; % default: do NOT overwrite existing files - -end - -% check if file exists - -if exist(fname,'file') - - if overwrite==0 - - disp(['RETURNING!!! -- NOT OVERWRITING EXISTING FILE ', fname]) - - return - - else - - disp(['OVERWRITING ', fname]) - - end - -else - disp(['writing ', fname]) - -end - -% open file - -ifp = fopen( fname, 'w', 'b' ); - -% determine number of grid cells ; further check dimensions - -N_grid = size(data,2); -N_angle= 1; - -if (length(size(data)) == 3) - N_angle = size(data,3); - data_org = data; - if (N_angle ~= length(av_angle_bin)) - disp(['ERROR in N_angle']) - return - end -end - -if (strcmp(write_ind_latlon,'latlon_id') && nargin == 14) - - if( size(tile_id,1) ~= N_grid ) - error('tile_id dimensions ??') - end - if ( size(tile_id,2) > 1) - disp(['# subgridcells per gridcell: ',num2str(size(tile_id,2))]); - end - -end - - -% write all records - -fortran_tag = 2*4; % length of each record in bytes - -count = fwrite( ifp, fortran_tag, int_precision ); -count = fwrite( ifp, [asc_flag version], int_precision ); -count = fwrite( ifp, fortran_tag, int_precision ); - -fortran_tag = 5*4; % length of each record in bytes - -count = fwrite( ifp, fortran_tag, int_precision ); -count = fwrite( ifp, [start_time.year, start_time.month, ... - start_time.day, start_time.hour, start_time.min], int_precision ); -count = fwrite( ifp, fortran_tag, int_precision ); - -count = fwrite( ifp, fortran_tag, int_precision ); -count = fwrite( ifp, [end_time.year, end_time.month, ... - end_time.day, end_time.hour, end_time.min], int_precision ); -count = fwrite( ifp, fortran_tag, int_precision ); - - -if (~(strcmp(data_product,'scaling') && strcmp(write_ind_latlon,'latlon_id') && nargin == 14)) - fortran_tag = 2*4; % length of each record in bytes - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, [N_grid N_angle], int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); -else - fortran_tag = 3*4; % length of each record in bytes - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, [N_grid N_angle size(tile_id,2)], int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); -end - -if (N_grid >= 1) - - fortran_tag = N_angle*4; %angles for which the output fields will be repeated below - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, squeeze(av_angle_bin(:)), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - fortran_tag = N_grid*4; % length of each record in bytes - - if (strcmp(write_ind_latlon,'ind') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(colind(:)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(rowind(:)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, colind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, rowind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon_id') && nargin == 14) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, colind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, rowind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - for i=1:size(tile_id,2) - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(tile_id(:,i)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - end - - else - - error('output-arguments do not line up') - - end - - fortran_tag = N_grid*4; - - for i=1:N_out_fields - - for j=1:N_angle - - if (N_angle > 1) - data = squeeze(data_org(:,:,j)); - end - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, data(i,:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - - end - - end - -else - - fortran_tag = N_angle*4; - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, squeeze(av_angle_bin(:)), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - fortran_tag = 4; % length of each record in bytes - - if (strcmp(write_ind_latlon,'ind') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon_id') && nargin == 14) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - else - - error('output-arguments do not line up') - - end - - for i=1:N_out_fields - - for j=1:N_angle - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, -999.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - end - - end - -end - -fclose(ifp); - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README deleted file mode 100644 index 0f2e3bde..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/README +++ /dev/null @@ -1,24 +0,0 @@ - -The scripts in this directory are used to generate climatology data from GEOSldas output. - -L4_SM Application: ------------------- -Post-process GEOSldas output into the soil moisture climatology nc4 file needed by the -SMAP L4SM ops system's "prcntl.py" script, which generates the soil moisture percentile -output ("sm_rootzone_pctl", "sm_profile_pctl") in the L4SM "Geophysical" (gph) file -collection. -The soil moisture climatology file needed by "prcntl.py" is created in two steps: - -1) Execute "Run_L4_sm_clim_stats.m" to create pentad binary climatology files - (73 for "sm_rootzone" + 73 for "sm_profile"). - -2) Execute "Write_L4_sm_clim_stat_bin2nc4.m" to create the single L4 input netcdf file - (*after* all binary pentad files are done). - -These jobs are memory intensive and typically take hours to run. On Discover, it is -necessary to use designated compute nodes. Step 1 may need to be run separately for -root-zone and profile soil moisture. - -Q. Liu, 29 Aug 2022 - -=========================== EOF ======================================================== \ No newline at end of file diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m deleted file mode 100644 index 2534672d..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Run_L4_sm_clim_stats.m +++ /dev/null @@ -1,82 +0,0 @@ -% Compute statistics of root-zone and profile soil moisture, which are needed to compute -% L4SM soil moisture percentile output. - -clear -addpath ../../shared/matlab -%------------------------------------------------------------------------- - -% experiment information -exp_path = {'/home/qliu/smap/SMAP_Nature/SMAP_Nature_v10/'}; -exp_run = {'SMAP_Nature_v10.0'}; - -domain = 'SMAP_EASEv2_M09_GLOBAL'; - -file_tag = {'tavg3_1d_lnr_Nt'}; - -% climatological period start and end year -start_year(1:12) = [repmat(2001,12,1)]; %start year for each month,the short start year was due to CPCU data inconsistance -end_year(1:12) = [repmat(2021,12,1)]; %end year for each month - -% only use 1 variable if running into memory issues -field_names = {'sm_rootzone','sm_profile'}; - -% convert soil moisture variables in "field_names" (if any) into -% wetness units -% (needed for L4SM because L4 ops script "prcntl.py" expects clim in -% wetness units, but clim is computed from Nature Run, which only -% outputs volumetric soil moisture) -out_wetness = 1; - -% linked to the output resolution -start_HHSS.hour = 1; -start_HHSS.min = 30; -start_HHSS.sec = 0; - -out_freq = 'pentad'; % pentad or monthly for now - -% now define the smoothing window based on the number of years of the clim period -if end_year(1) - start_year(1) > 9 - w_out_freq = 5; % smoothing window (number of pentads or months) -else - w_out_freq = 11; -end - -% minimum number of data requirement is based on number of years and window size -N_data_min = 2 * w_out_freq *(end_year(1)-start_year(1)+1); %per out_freq - -% ------------------ - -for n=1:length(exp_run) - - for ff = 1:length(field_names) - - if exist('time_of_day_in_hours','var') - - for j=1:length(time_of_day_in_hours) - - get_model_clim_stats( field_names{ff}, ... - exp_path{n}, exp_run{n}, domain, start_year, end_year, ... - out_freq, w_out_freq, file_tag{n}, ... - out_wetness, ... - N_data_min, time_of_day_in_hours(j) ) - - end - - else - - get_model_clim_stats( field_names{ff}, ... - exp_path{n}, exp_run{n}, domain, ... - start_year, end_year, start_HHSS, ... - out_freq, w_out_freq, file_tag{n}, ... - out_wetness, ... - N_data_min ) - - end - - end -end - - -% ============= EOF ==================================================== - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m deleted file mode 100644 index f476a5a4..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/Write_L4_sm_clim_stat_bin2nc4.m +++ /dev/null @@ -1,208 +0,0 @@ -%========================================================================= -% script to convert SMAPL4 SM climatology statistic binary output to nc4 -% file. -% -% The tile_ids are in the same order as in ldas_tilecoord.txt -% -% Q. Liu - Jun 20, 2016 -% G. De Lannoy - Apr 21, 2015 -%========================================================================= - -clear all - -write_GEOSldas_tileorder = 0; - -time_stamp = '2001_p1_2021_p73'; -specs_tag = '_W_5p_Nmin_210'; - -bin_fpath = '/home/qliu/smap/SMAP_Nature/SMAP_Nature_v10/SMAP_Nature_v10.0/output/SMAP_EASEv2_M09_GLOBAL/stats/cli/'; - -file_out = ['L4SM_NRv10.0_cli_',time_stamp,specs_tag,'_sm_wetness_EASEv2_M09.nc4']; - -if write_GEOSldas_tileorder - file_out = ['GEOSldas_',file_out]; -end - -fname_out = [bin_fpath, file_out]; - -% read an arbitrary file to get header info -fname = [bin_fpath, 'cli_',time_stamp,specs_tag,'_sm_rootzone_wet_p06.bin']; - -N_stat = 99 + 5; % 99 percentile values + 5 stats (mean, stdv,min, max, N_data) - -[data_tmp, tile_id, lon, lat] = ... - read_seqbin_clim_pctl_file(fname, 1, N_stat, 'latlon_id','cli'); - -N_tile = length(tile_id); - -if write_GEOSldas_tileorder - - [tile_id_out, tile_idx] = sort(tile_id,'ascend'); - lon_out = lon(tile_idx); - lat_out = lat(tile_idx); -else - tile_id_out = tile_id; - lon_out = lon; - lat_out = lat; -end - -clear data_tmp - -netcdf.setDefaultFormat('FORMAT_NETCDF4'); -fout_id = netcdf.create(fname_out, 'NETCDF4'); - -if fout_id < 0, error(['Creating ' fname_out 'failed']); end - -% Setup global attributes - -NC_GLOBAL = netcdf.getConstant('GLOBAL'); - -netcdf.putAtt(fout_id, NC_GLOBAL, 'Title', ['SMAP L4 SM pentad clim. ',time_stamp,' statistics on EASEv2 M09']); - -netcdf.putAtt(fout_id, NC_GLOBAL, 'Filename', file_out); -netcdf.putAtt(fout_id, NC_GLOBAL, 'Institution', 'NASA GMAO'); -netcdf.putAtt(fout_id, NC_GLOBAL, 'History', ['File written by matlab-r2021a on ',datestr(now)]); -netcdf.putAtt(fout_id, NC_GLOBAL, 'Contact', 'NASA/GMAO Rolf Reichle'); -netcdf.putAtt(fout_id, NC_GLOBAL, 'Comments', 'NETCDF-4'); - -% Define dimensions: - -dimid1 = netcdf.defDim(fout_id,'tile',length(tile_id_out)); -dimid2 = netcdf.defDim(fout_id,'percentile_wetness' , 99); -dimid3 = netcdf.defDim(fout_id,'pentad', netcdf.getConstant('UNLIMITED')); - -% Define global variables: - -varid = netcdf.defVar(fout_id,'tile_id','int',dimid1); -netcdf.putAtt(fout_id,varid,'standard_name','tile_id'); -netcdf.putAtt(fout_id,varid,'long_name','tile_id'); -netcdf.putAtt(fout_id,varid,'units','-'); -netcdf.putVar(fout_id,varid,tile_id_out); - -varid = netcdf.defVar(fout_id,'lon','double',dimid1); -netcdf.putAtt(fout_id,varid,'standard_name','longitude'); -netcdf.putAtt(fout_id,varid,'long_name','longitude'); -netcdf.putAtt(fout_id,varid,'units','degrees_east'); -netcdf.putVar(fout_id,varid,lon_out); - -varid = netcdf.defVar(fout_id,'lat','double',dimid1); -netcdf.putAtt(fout_id,varid,'standard_name','latitude'); -netcdf.putAtt(fout_id,varid,'long_name','latitude'); -netcdf.putAtt(fout_id,varid,'units','degrees_north'); -netcdf.putVar(fout_id,varid,lat_out); - -% Synchronize global -netcdf.sync(fout_id) - -% Define groups and variables in each group - -vars = {'mean', 'stdv', 'min', 'max', 'N_data', 'percentile_UL'}; - -da_group_id(1) = netcdf.defGrp(fout_id, 'rootzone_wetness_cli_stat'); - -da_group_id(2) = netcdf.defGrp(fout_id, 'profile_wetness_cli_stat'); - -fillValue = single(1.e15); - -DeflateLevel = 5; - -% Put data into the data group: - -% Insert data: - -for i=1:length(da_group_id) %loop through groups - - start_time = 0; - - for k = 1:73 % loop through pentad - - clear data - - if i==1 - - fname = [bin_fpath, 'cli_',time_stamp,specs_tag,'_sm_rootzone_wet_p', ... - num2str(k, '%2.2d'), '.bin']; - - else - - fname = [bin_fpath, 'cli_',time_stamp,specs_tag,'_sm_profile_wet_p', ... - num2str(k, '%2.2d'), '.bin']; - - end - - [data_tmp, tile_id_old, lon_old, lat_old] = ... - read_seqbin_clim_pctl_file(fname, 1, 104, 'latlon_id','cli'); - - clear tile_id_old lon_old lat_old - - if write_GEOSldas_tileorder - data = data_tmp(tile_idx,:); - else - data = data_tmp; - end - - clear data_tmp - - for iv = [1 3 4 6:size(data,2)] - data(data(:,iv)>1, iv) = 1.; - end - - - data(data<-9998) = fillValue; - data(isnan(data)) = fillValue; - - - for iv = 1:4 % loop through variables - - if k == 1 - - varid(iv) = netcdf.defVar(da_group_id(i),vars{iv},'float',[dimid1,dimid3]); - netcdf.putAtt(da_group_id(i),varid(iv),'name', vars{iv}); - netcdf.putAtt(da_group_id(i),varid(iv),'units','wetness'); - netcdf.defVarFill(da_group_id(i),varid(iv),false,fillValue); - netcdf.defVarDeflate(da_group_id(i),varid(iv),true,true, DeflateLevel); - - end - - netcdf.putVar(da_group_id(i),varid(iv),[0,start_time], [N_tile,1], squeeze(data(:,iv))); - - end - - if k == 1 - - varid(5) = netcdf.defVar(da_group_id(i),vars{5},'int',[dimid1,dimid3]); - netcdf.putAtt(da_group_id(i),varid(5),'name', vars{5}); - netcdf.putAtt(da_group_id(i),varid(5),'units','-'); - netcdf.defVarDeflate(da_group_id(i),varid(5),true,true, DeflateLevel); - - end - - netcdf.putVar(da_group_id(i),varid(5),[0,start_time], [N_tile,1],squeeze(data(:,5))); - - if k==1 - - varid(6) = netcdf.defVar(da_group_id(i),vars{6},'float',[dimid2,dimid1,dimid3]); - netcdf.putAtt(da_group_id(i),varid(6),'name', vars{6}); - netcdf.putAtt(da_group_id(i),varid(6),'units','wetness'); - netcdf.defVarFill(da_group_id(i),varid(6),false,fillValue); - netcdf.defVarDeflate(da_group_id(i),varid(6),true,true, DeflateLevel); - - end - - netcdf.putVar(da_group_id(i),varid(6),[0,0,start_time], [99,N_tile, 1],squeeze(data(:,6:104)')); - - start_time = start_time +1; - end - - netcdf.sync(da_group_id(i)) - - -end - -% Synchronize: -netcdf.close(fout_id) - -%====================================EOF=================================== - - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m deleted file mode 100644 index 7082a6c3..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/get_model_clim_stats.m +++ /dev/null @@ -1,433 +0,0 @@ -function [] = get_model_clim_stats( fieldname, ... - exp_path, exp_run, domain, ... - start_year, end_year, start_HHSS, ... - out_freq, w_out_freq, file_tag, ... - out_wetness, ... - N_data_min, time_of_day_in_hours ) - -%======================================================================= -% -% Compute mean, stdv and CDF-stats of simulated fields from -% - tile-based "nc4" files -% - or gridded "h5" files -% for a selection of fieldname. -% -% The main purpose of this function is to aggregate the information -% from the "cat" files so that the climatology statistics can -% be used for the computation of percentiles. -% -% -% Need to fix those file_tag-s... at some point, we had to calculate cli-files -% based on all different file types... ugly -% -% -% One file with statistics is generated for every pentad or month. -% -% fieldname: (single) model field to be processed -% start_year: start year for each month (12 entries!) -% end_year: end year for each month (12 entries!) -% start_HHSS: hour, min, sec of first file (depends on output resolution) -% out_freq: 'monthly' or 'pentad' climatology files -% w_out_freq: number of months or pentads used in the temporal smoothing -% N_data_min: minimum number of data points to calculate a good stat -% -% 'cli'-file has a similar format as the SMOS-data files and -% observation scaling files for assimilation. -% -% ==HEADER== -% N_tiles N_fields N_stat -% fields -% -% ==DATA== -% -% %%%% tile ID --> for all tiles (1:N_tiles, not sorted by tile_id!) -% lat -% lon -% -% [for fields] -% mean -% std -% min -% max -% N_data -% CDF_parameter_1 OR UL_1st_percentile -% CDF_parameter_2 UL_2st_percentile -% CDF_parameter_... UL_... -% CDF_parameter_N UL_99st_percentile -% [end fields] -% -% GDL, feb 2014 -% -% ------------------------------------------------------------------- -% begin user-defined inputs -% ------------------------------------------------------------------- - -nodata = -9999; -nodata_tol = 1e-4; - -ens_tag = 'ens0000'; - -dtstep = 3*60*60; % hardwired 3-hourly if x-hourly output is given - -% when reading h5-data - -datagroup_name = '/Geophysical_Data/'; - -% output specs - -overwrite = 1; - -percentiles = [1:99]; - -N_stat = 5; %mean, stdv, min, max, N_data -N_CDF = length(percentiles); - -N_stat_CDF = N_stat+N_CDF; - -write_ind_latlon = 'latlon_id'; %'latlon'; - -% ------------------------------------------------------------------- -% end user-defined inputs -% ------------------------------------------------------------------- - -N_fields = 1; - -fieldno = 1; - -field_tag = ['_',fieldname]; - -% ------------------------------------------------------------------- - -% determine number of entries in smoothing time window - -if (std(end_year-start_year) ~= 0) - error('same number of years should contribute to each month') -end - -if strcmp(out_freq,'pentad') - n_days = 5; -elseif strcmp(out_freq,'monthly') - n_days = 365/12.0; % could adjust this and work w/ min_days=28, max_days=31 -end - -disp(['smoothing window is ',num2str(n_days*w_out_freq),' days']); - -n_time_count = round(w_out_freq * n_days * (max(end_year-start_year)+1) *... - ((24*60*60)./dtstep)); - -% auxiliary start-end_time to get 1 year climatology: -% - loop over all days in any non-leap year (365 days) -% - make sure to loop into the next year to cover all climatology pentads -% or months w/ the complete smoothing window - -start_time = start_HHSS; -start_time.year = 2014; -start_time.month = 1; -start_time.day = 1; - -start_time = get_dofyr_pentad(start_time); %ini correct pentad - -end_time = augment_date_time((365 + w_out_freq * n_days)*24*60*60, ... - start_time); - -% effective period used in climatology calculation - -start_time_true = start_time; -start_time_true.year = min(start_year); -tmp = find(start_year==min(start_year)); -start_time_true.month = tmp(1); -start_time_true = get_dofyr_pentad( start_time_true ); - -end_time_true = end_time; -end_time_true.year = max(end_year); -tmp = find(start_year==max(start_year)); -end_time_true.month = tmp(end); -end_time_true.day = days_in_month( end_time_true.year, end_time_true.month); -end_time_true = get_dofyr_pentad( end_time_true ); - -% assemble input and output paths - -inpath = [ exp_path, '/', exp_run, '/output/', domain ]; -outpath = [ inpath, '/stats/cli/' ]; - -% create outpath if it doesn't exist - -if ~exist(outpath,'dir') - eval(['!mkdir -p ', outpath]); -end - -% ------------------------------------------------------------- - -% load catchment coordinates - -fname = [inpath, '/rc_out/', exp_run, '.ldas_tilecoord.bin']; - -[ tile_coord ] = read_tilecoord( fname ); - -N_tile = tile_coord.N_tile; - -lat_out = tile_coord.com_lat; -lon_out = tile_coord.com_lon; -tile_coord_tile_id = tile_coord.tile_id; - -% determine if conversion of soil moisture variables to wetness is -% needed; if yes, get porosity from cat_param file - -convert_to_wetness = 0; - -if contains(field_tag,'sm_') & ~contains(field_tag,'wet') & out_wetness - - field_tag = [field_tag,'_wet']; - convert_to_wetness = 1; - - catfname = [exp_path,'/',exp_run,'/output/',domain,'/rc_out/','/Y2015/M01/',... - exp_run,'.ldas_catparam.','20150101_0000','z.bin']; - - cat_param = read_catparam( catfname, N_tile ); - - poros = cat_param.poros; clear cat_param - -end - -% ------------------------------------------------------------- - -% assemble output file name - -if strcmp(out_freq,'pentad') - - fname_out_base = [ outpath, '/', 'cli_', ... - num2str(start_time_true.year), '_p', ... - num2str(start_time_true.pentad),'_', ... - num2str(end_time_true.year), '_p', ... - num2str(end_time_true.pentad), '_', ... - 'W_', num2str(w_out_freq),'p_', ... - 'Nmin_', num2str(round(N_data_min),'%d'), ... - field_tag]; - -else strcmp(out_freq,'monthly') - - fname_out_base = [ outpath, '/', 'cli_', ... - num2str(start_time_true.year), '_M', ... - num2str(start_time_true.month),'_', ... - num2str(end_time_true.year), '_M', ... - num2str(end_time_true.month), '_', ... - 'W_', num2str(w_out_freq),'M_', ... - 'Nmin_', num2str(round(N_data_min),'%d'), ... - field_tag]; - -end - -if exist( 'time_of_day_in_hours', 'var') - - fname_out_base = [fname_out_base, '_', num2str(time_of_day_in_hours,'%2.2d'), 'z']; - -end - -% ------------------------------------------------------------- - -% initialize output statistics - -hist_data = zeros(N_tile,N_fields,n_time_count); - -time_count = 0; - -data_out = NaN+zeros(N_fields,N_tile,N_stat_CDF); - -% ------------------------------------------------------------- - -disp('climatology calculation') - -time_new = start_time; - -while 1 - - if (time_new.year == end_time.year &... - time_new.month == end_time.month &... - time_new.day == end_time.day &... - time_new.hour == end_time.hour &... - time_new.min == end_time.min &... - time_new.sec == end_time.sec ) - break - end - - % augment date_time - - time_old = time_new; - pentad_old = time_new.pentad; - month_old = time_new.month; - - time_new = augment_date_time(dtstep, time_old); - pentad_new = time_new.pentad; - month_new = time_new.month; - - % check if diurnal stats are needed - - if exist('time_of_day_in_hours','var') - tmp_hour = time_of_day_in_hours; - else - tmp_hour = time_old.hour; % all hours of day will be included - end - - if time_old.hour==tmp_hour - - minute = time_old.min; % floor( (seconds_in_day-hour*3600)/60 ); - seconds = time_old.sec; % seconds_in_day-hour*3600-minute*60; - - if (seconds~=0) - error('something is wrong! (seconds~=0)') - end - - for year = start_year(time_old.month):end_year(time_old.month) - - time_count = time_count+1; - - YYYYMMDD = [ num2str(year, '%4.4d'), ... - num2str(time_old.month, '%2.2d'), ... - num2str(time_old.day, '%2.2d') ]; - - HHMM = [ num2str(time_old.hour, '%2.2d'), ... - num2str(time_old.min, '%2.2d') ]; - - fname = [ inpath, ... - '/cat/', ens_tag, ... - '/Y', num2str(year, '%4.4d'), ... - '/M', num2str(time_old.month,'%2.2d'), ... - '/', exp_run, ... - '.', file_tag, '.', YYYYMMDD, '.nc4' ]; - - if ~exist(fname,'file') - - % try again with "_[HHMM]z" inserted into file name - - fname = [ inpath, ... - '/cat/', ens_tag, ... - '/Y', num2str(year, '%4.4d'), ... - '/M', num2str(time_old.month,'%2.2d'), ... - '/', exp_run, ... - '.', file_tag, '.', YYYYMMDD, '_', HHMM, 'z.nc4' ]; - - end - - disp(['reading ',fieldname,' from ',fname]) - data_tmp = ncread(fname, fieldname); - - if size(data_tmp,2) == 8 % hard-wired 3-hourly time step?? - tile_data_tmp = data_tmp(:,ceil(time_old.hour/3.)); clear data_tmp - elseif size(data_tmp,2) == 1 - tile_data_tmp = data_tmp; clear data_tmp - else - error(['data size is incorrect from ', fname]) - end - - for s=1:N_fields - - if ~convert_to_wetness - tile_data_tmp_1D = tile_data_tmp(:); - else - tile_data_tmp_1D = tile_data_tmp(:)./poros(:); - end - - good_data = find(~(abs(tile_data_tmp_1D - nodata) < nodata_tol)); - - tile_data_tmp_1D = tile_data_tmp_1D(good_data); - - %Keep a record of time series - - total_bin_good_ind = (time_count-1).*(N_fields*N_tile) + ... - (s-1)*N_tile+good_data'; - - hist_data(total_bin_good_ind) = tile_data_tmp_1D; - - end - - end % loop through years - - end % time_of_day_in_hours - - % check if output needs to be written - - if (time_count == n_time_count ) - - % write output - - for s=1:N_fields - - %edges = edge_min(s):edge_dx(s):edge_max(s); - - for tile=1:N_tile - - tmp = reshape(squeeze(hist_data(tile, s, :)),1,[]); - - data_out(s,tile,1) = mean( tmp,"omitnan"); % mean - data_out(s,tile,2) = std( tmp,"omitnan"); % stdv - data_out(s,tile,3) = min( tmp ); % min - data_out(s,tile,4) = max( tmp ); % max - data_out(s,tile,5) = sum(~isnan(tmp) ); % N_data - - % determine the CDF-parameters, or the edges for each - % percentile - - perc = round(percentiles./100*data_out(s,tile,5)); - - tmp = sort(tmp); - - data_out(s,tile,N_stat+1:N_stat+N_CDF) = tmp(perc); - - end - - end - - bad_ind = find(data_out(:,:,5) 1) - - if (strcmp(file_type,'cli')) - - if (strcmp(read_ind_latlon,'ind')) - - fortran_tag = fread( ifp, 1, int_precision ); - col_ind = fread( ifp, [1 N_grid], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - row_ind = fread( ifp, [1 N_grid], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - elseif (strcmp(read_ind_latlon,'latlon')) - - fortran_tag = fread( ifp, 1, int_precision ); - col_ind = fread( ifp, [1 N_grid], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - row_ind = fread( ifp, [1 N_grid], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - elseif (strcmp(read_ind_latlon,'latlon_id') ) - - fortran_tag = fread( ifp, 1, int_precision ); - col_ind = fread( ifp, [1 N_grid], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - row_ind = fread( ifp, [1 N_grid], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_id = fread( ifp, [1 N_grid], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - else - - error('not sure how the file looks like, based on the combination of input-specs') - - end - - end - - data = NaN*ones(N_field,N_grid,N_stat); - - for j=1:N_stat - - for i=1:N_field - - if (j == 5 && strcmp(file_type,'cli')) - - fortran_tag = fread( ifp, 1, int_precision ); - tmp_data = fread( ifp, [1 N_grid], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - else - - fortran_tag = fread( ifp, 1, int_precision ); - tmp_data = fread( ifp, [1 N_grid], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - end - - data(i,1:N_grid,j) = tmp_data(1:N_grid); - - end - - end - - data = squeeze(data); - -else - - data = NaN*ones(N_field,1); - col_ind = NaN; - row_ind = NaN; - fieldno = NaN; - -end - -fclose(ifp); - -% ======= EOF ========================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m deleted file mode 100644 index 22f35698..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/climatology/write_seqbin_clim_pctl_file.m +++ /dev/null @@ -1,255 +0,0 @@ -function [] = write_seqbin_clim_pctl_file(fname, colind, rowind,... - data, fieldno, N_stat,... - overwrite, ... - write_ind_latlon, file_type, tile_id) %last argument is optional - -% write "fortran binary sequential" tile files with climatology info -% or percentile output -% -% optional input: -% -% overwrite = 0 -- do NOT overwrite existing files, print warning -% message, return -% overwrite = 1 -- overwrite existing files, print warning message -% -% De Lannoy, 27 Feb 2014: adopted from write_seqbin_file.m -% ------------------------------------------------------------------ - -nodata_val = -9999.0; - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -% check dimensions - -if size(data,1)~=length(fieldno) - - error('ERROR: size of data incompatible with N_fields') - -end - -N_grid = size(data,2); - -N_field = length(fieldno); - -if (length(size(data)) == 3) - - N_stat_tmp = size(data,3); - - data_org = data; - - if (N_stat_tmp ~= N_stat) - disp(['ERROR in N_stat ',num2str(N_stat_tmp),' vs ',num2str(N_stat)]) - return - end - -end - - -% check for presence of optional input "overwrite" - -if ~exist('overwrite','var') - - overwrite = 0; % default: do NOT overwrite existing files - -end - -% check if file exists - -if exist(fname,'file') - - if overwrite==0 - - disp(['RETURNING!!! -- NOT OVERWRITING EXISTING FILE ', fname]) - - return - - else - - disp(['OVERWRITING ', fname]) - - end - -else - disp(['writing ', fname]) - -end - -% open file - -ifp = fopen( fname, 'w', 'b' ); - -% determine number of grid cells ; further check dimensions - - -if (strcmp(write_ind_latlon,'latlon_id') && exist('tile_id','var')) - - if ( size(tile_id,1) ~= N_grid ) - error('tile_id dimensions ??') - end - if ( size(tile_id,2) > 1) - disp(['# subgridcells per gridcell: ',num2str(size(tile_id,2))]); - end - -end - - -% write all records - -if (strcmp(file_type,'cli')) - - % dimensions - - fortran_tag = 2*4; % length of each record in bytes - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, [N_grid N_field], int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - -end - -if (N_grid >= 1) - - if (strcmp(file_type,'cli') ) - - fortran_tag = N_grid*4; % length of each record in bytes - - if (strcmp(write_ind_latlon,'ind') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(colind(:)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(rowind(:)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, colind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, rowind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon_id') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, colind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, rowind(:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - for i=1:size(tile_id,2) - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(tile_id(:,i)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - end - - else - - error('output-arguments do not line up') - - end - - end - - fortran_tag = N_grid*4; - - for j=1:N_stat - - for i=1:N_field - - if (N_stat > 1) - data = squeeze(data_org(:,:,j)); - end - - if ( j == 5 && strcmp(file_type,'cli')) - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, round(data(i,:)), int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - else - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, data(i,:), float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - end - - end - - end - -else - - if (strcmp(file_type,'cli')) - - fortran_tag = 4; % length of each record in bytes - - if (strcmp(write_ind_latlon,'ind') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon') ) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - elseif (strcmp(write_ind_latlon,'latlon_id')) - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0.0, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - - else - - error('output-arguments do not line up') - - end - - end - - for j=1:N_stat - - for i=1:N_field - - if ( j == 5 && strcmp(file_type,'cli')) - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, 0, int_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - else - count = fwrite( ifp, fortran_tag, int_precision ); - count = fwrite( ifp, nodata_val, float_precision ); - count = fwrite( ifp, fortran_tag, int_precision ); - end - - end - - end - -end - -fclose(ifp); - -%=========================EOF==================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh deleted file mode 100644 index fb17a1bf..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/compress_bit-shaved_nc4.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/local/bin/bash -# -# lossless compression of (bit-shaved) nc4 output, operates recursively in -# -# usage: compress_bit-shaved_nc4.sh -# -# --------------------------------------------------------------- - -usage(){ - echo -e "\nUsage: $0 - = name of output directory with bit-shaved nc4 files -" - exit 1; -} - -if [[ $# -lt 1 ]]; then - usage - exits; -fi - -# deflation_level 1-9; higher level (e.g. 9) takes longer; recommended: 3 (based on L4_SM) -deflate_level=3 - -# By default, the ncks command is executed sequentially for each nc4 file -# in . Modify this script if multi-threading is needed to run -# the script on a compute node. - -for file in $(find $1 -name "*.nc4" -type f); do - #echo "Processing $file..." - # # For simple multi-threading: - ncks -L $deflate_level -O $file $file # <-- comment out this line -### ncks -L $deflate_level -O $file $file & # <-- uncomment this line -done; -###wait # <-- uncomment this line - -# ===================== EOF ======================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m deleted file mode 100644 index 55be8d47..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/postproc/write_smapL4SMqa.m +++ /dev/null @@ -1,1315 +0,0 @@ -function [] = write_smapL4SMqa( gph_aup_lmc_fnames, tilecoord_fname, tilegrids_fname ) - -% THE FOLLOWING PATH SHOULD BE ADDED IN MATLAB SCRIPT THAT CALLS THIS FUNCTION -% add path to matlab functions in src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/ -addpath('../shared/matlab/'); - -% Generate *.qa files from SMAP L4_SM "gph" or "aup" granules. -% -% Inputs: -% -% gph_and_aup_fnames : cell array of gph and/or aup granule (file) names -% tilecoord_fname : "tilecoord" file name -% tilegrids_fname : "tilegrids" file name -% -% The "tilecoord" and "tilegrids" information must work with all -% input granules that are to be converted. -% -% For each "gph" or "aup" granule, the *.qa file is written into -% the directory that holds the granule. -% -% Currently operates on binary LDASsa aup files. (Could be changed -% but would require h5 readers for "gph" and "aup" granules.) -% -% TBD: Insert official "h5" granule name into *.qa files. -% -% reichle, 12 Feb 2014 -% de lannoy, 17 Feb 2014: added lmc -% reichle, 18 Feb 2014: minor edits and clean-up -% -% ------------------------------------------------------------------------------------ - -% ######################### SAMPLE DRIVER SCRIPT ##################################### -% -% exppath = '/hydro/gdelanno/SMAP_Delivered/SMAP_L4_SM_D00500/'; -% -% expid = 'SMAP_D00500_L4_SM_synth_e001'; -% -% expdom = 'SMAP_EASEv2_M09_GLOBAL'; -% -% yyyymm = '200107'; -% -% gphpath = [exppath, '/', expid, '/', expdom, '/cat/ens_avg/', ... -% '/Y', yyyymm(1:4), '/M', yyyymm(5:6), '/']; -% -% auppath = [exppath, '/', expid, '/', expdom, '/ana/ens_avg/', ... -% '/Y', yyyymm(1:4), '/M', yyyymm(5:6), '/']; -% -% lmcpath = [exppath, '/', expid, '/', expdom, '/rc_out/', ... -% '/Y', yyyymm(1:4), '/M', yyyymm(5:6), '/']; -% -% tcpath = [exppath, '/', expid, '/', expdom, '/rc_out/']; -% -% tc_fname = [tcpath, expid, '.ldas_tilecoord.bin']; -% tg_fname = [tcpath, expid, '.ldas_tilegrids.bin']; -% -% gphnames = ... -% {[expid,'.ens_avg.ldas_tile_xhourly_out.20010725_0130z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_0430z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_0730z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_1030z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_1330z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_1630z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_1930z.bin'], ... -% [expid,'.ens_avg.ldas_tile_xhourly_out.20010725_2230z.bin']}; -% -% aupnames = ... -% {[expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_0300z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_0600z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_0900z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_1200z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_1500z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_1800z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010725_2100z.bin'], ... -% [expid,'.ens_avg.ldas_tile_inst_smapL4SMaup.20010726_0000z.bin']}; -% -% % there should only be one "lmc" file: -% -% lmcname = [expid,'.ldas_smapL4SMlmc.20010725_0000z.bin']; -% -% % concatenate all file names into one cell array -% -% for ii=1:length(gphnames) -% -% fnames{ii} = [gphpath, gphnames{ii}]; -% -% end -% -% ii_off = length(gphnames); -% -% for ii=1:length(aupnames) -% -% fnames{ii+ii_off} = [auppath, aupnames{ii}]; -% -% end -% -% ii_off = ii_off + length(aupnames); -% -% fnames{ii_off+1} = [lmcpath, lmcname]; -% -% write_smapL4SMqa( fnames, tc_fname, tg_fname ); -% -% ##################### END SAMPLE DRIVER SCRIPT ##################################### - -% ------------------------------------------------------------------------------------ -% -% make sure that list of input file names is a cell array - -if ~iscell(gph_aup_lmc_fnames) - - error('write_smapL4SMqa.m: input list of file names must be a cell array') - -end - -% ---------------------------------------------- - -% read tile coordinate information - -tile_coord = read_tilecoord(tilecoord_fname); - -% Make sure LDASsa output was for EASEv2_M09 tile space - -[ tile_grid_g, tile_grid_d ] = read_tilegrids(tilegrids_fname); - -if isempty(strfind(tile_grid_d.gridtype, 'EASEv2_M09')) - error('Expecting aup file in EASEv2_M09 tile space'); -end - -% ---------------------------------------------- - -% process each file in list of input files - -for ii=1:length(gph_aup_lmc_fnames) - - this_fname = gph_aup_lmc_fnames{ii}; - - disp(['processing: ', this_fname]) - - % parse input string name to decide whether a "gph" or "aup" granule is to be converted - - if any( findstr( this_fname , 'ldas_tile_xhourly_out' )) - - get_gph_qa( this_fname, tile_coord ); - - elseif any( findstr( this_fname , 'ldas_tile_inst_smapL4SMaup' )) - - get_aup_qa( this_fname, tile_coord ); - - elseif any( findstr( this_fname , 'ldas_smapL4SMlmc' )) - - get_lmc_qa( this_fname, tile_coord ); - - else - - error('write_smapL4SMqa.m: something wrong with input file name') - - end - - disp(['---------------------------------------------------------']) - -end - - -% ********************************************************************************************* -% ********************************************************************************************* -% ********************************************************************************************* - - -function [] = get_gph_qa( gph_fname, tile_coord ) - -%==================================================================== -% -% Matlab function to produce .qa-files for SMAP L4_SM *gph* output. -% -% 30jan14: Gabrielle De Lannoy - initial draft -% 1feb14: Gabrielle De Lannoy - use land fraction to calculate stats -% - text edits, formatting -% 7feb14: Gabrielle De Lannoy - edits -% -% - currently operates on binary LDASsa gph files -% - TBD: file name change from "bin" to official "h5" granule name -% -%==================================================================== -% -% [QA] -- SMAP_L4_SM_PSD p.29: -% -% "... -% The QA file contains statistical information that will enable users -% to better assess the quality of the associated granule. -% QA products bear exactly the same name as the products [(.h5)] -% that they represent. The only difference in names is the extension. -% The extension for all QA products is *.qa. -% ..." -% -% [gph] -- SMAP_L4_SM_PSD p.4: -% "... -% The first Collection is a series of 3-hourly time average geophysical ("gph") -% land surface fields that are output by the L4_SM algorithm. This -% Collection will be of primary interest to most users. -% ..." -% -%==================================================================== - -check_on = 1; %1 = LDASsa sanity checks, write warnings - %2 = LDASsa sanity checks, stop if check fails - -nodata_val = -9999; -nodata_tol = 1E-4; - -tablefields = {'Fieldname','Units',... - 'Mean','Std-dev','Min','Max','N'}; - -Nstat = length(tablefields)-2; - -str_l = 51; -unt_l = 16; -num_l = 13; -num_s_l = 9; - -str_f = num2str(str_l); -unt_f = num2str(unt_l); -num_f = num2str(num_l); -num_s_f = num2str(num_s_l); - -delim = ','; - -tableformat = [ '%-',str_f,'s',delim,'%-',unt_f,'s']; -tableformat_sc = [ '%-',str_f,'s',delim,'%-',unt_f,'s']; - -for f=1:Nstat - if f~=Nstat - tableformat = [tableformat, delim,'%',num_f,'.4f']; - tableformat_sc = [tableformat_sc, delim,'%',num_f,'.4e']; - else - tableformat = [tableformat, delim,'%',num_s_f,'d\n']; - tableformat_sc = [tableformat_sc, delim,'%',num_s_f,'d\n']; - end -end - -out_collection_ID = 6; - -%N_out_fields = 40; % for raw LDASsa output (EXCL. sm in pctl units) -N_out_fields = 42; % for post-processed LDASsa output (INCL. sm in pctl units) - -%==================================================================== -% -% Grid information - -N_gridcells_M09 = length(tile_coord.com_lat); - -weights = tile_coord.frac_cell; - -%==================================================================== - -% expect LDASsa *ldas_tile_xhourly_out*.bin file (not "h5" output) - -% read LDASsa binary gph file and check fieldnames - -[fn, units] = get_data_tag(out_collection_ID, N_out_fields); - -tile_data = read_tile_data(gph_fname, tile_coord.N_tile, N_out_fields); - -if tile_coord.N_tile ~= size(tile_data,2) - error('Number of land tiles does not match the length of simulated vectors'); -end - -out_fname = [gph_fname(1:end-4), '.qa' ]; - -% assemble placeholder h5 file name - -%%ind = findstr(gph_fname,'/'); - -%%h5_fname = [gph_fname(ind(end)+1:end-4), '.h5']; - -h5_fname = ''; - -%============================================================ -% OUTPUT -%============================================================ - -ofp = fopen( out_fname, 'w' ); - -disp(['writing ',out_fname]); - -% header information: 4 lines - -fprintf(ofp, ['%s\n'],... - ['Quality Assessment for SMAP L4_SM Granule ', h5_fname]); -fprintf(ofp, ['%s%8d\n\n'],... - ['Number of L4_SM EASEv2 9 km land grid cells = '], N_gridcells_M09); - -% comma-delimited table: -% - 4 header lines (observation space) -% - X variable lines -% - footnotes - -%================================================================= -% Model space -%================================================================= - -for f = 1:str_l+1+unt_l+Nstat+(Nstat-1)*num_l+num_s_l - fprintf(ofp, '%s','=' ); -end -fprintf(ofp, '\n%s\n',... - 'Geophysical variables'); -for f = 1:str_l+1+unt_l+Nstat+(Nstat-1)*num_l+num_s_l - fprintf(ofp, '%s','=' ); -end -fprintf(ofp, '\n'); - -for f = 1:Nstat+2 - if f==1 fprintf(ofp, ['%-',str_f,'s',delim,''], [tablefields{f},'' ]); end - if f==2 fprintf(ofp, ['%-',unt_f,'s',delim,''], [tablefields{f},' (*1)']); end - if f==3 || f==4 fprintf(ofp, ['%', num_f,'s',delim,''], [tablefields{f},' (*2)']); end - if f>4 && f4 && f4 && f AmF_threshold(f); - - if f==17 - subset_exclzero = tmp_subset; - else - subset_exclzero = (subset_exclzero | tmp_subset); - end - -end - -%-----Raw aup-fields---------------------------------------------- - -for f = 17:length(fn) - - var = getfield(aup, fn{f}); - var(abs(var-nodata_val)4 && f 0 || return_mean) - - if return_mean - array_out = NaN*zeros(length(ia),1); - end - - N_bad = 0; - for i=1:size(unique_rc,1) - - if check_on > 0 - if (std(array( ... - M36_row_col(:,1) == unique_rc(i,1) & ... - M36_row_col(:,2) == unique_rc(i,2) ))... - > stdv_Tbobs_tol) - N_bad = N_bad+1; - end - end - - if return_mean - array_out(i) = mean(array( ... - M36_row_col(:,1) == unique_rc(i,1) & ... - M36_row_col(:,2) == unique_rc(i,2) )); - end - - end - - if N_bad > 0 - if check_on == 2 - error([num2str(N_bad),' M36 grid cells out of ',... - num2str(length(unique_rc)),' contain M09 obs with std-dev<>0']) - else - disp(['WARNING: ',num2str(N_bad),' M36 grid cells out of ',... - num2str(length(unique_rc)),' contain M09 obs with std-dev<>0']) - end - end - -end - -if ~return_mean - array = array(ia); -else - array = array_out; -end - -% ********************************************************************************************* - -function [ stats_out ] = stats_array( array_in, weights, Nstat ) - -% calculate elementary summary statistics for array_in -% -% input: array_in = numerical array (1-dimensional) -% weights = weight for each element in array_in (1-dimensional) -% -% output: array_out = [mean stdv min max N_data frac] -% -% GDL, 16 Jan 2014 -% GDL, 30 Jan 2014: remove NaN prior to the calculation of stats -% GDL, 1 Feb 2014: - weighted statistics for mean and stdv -% - add 6th statistic (frac): -% the actual used fraction of N_data (based on weights) -% GDL, 7 Feb 2014: added Nstat as input, to limit the returned output. -% should be revised in the future to select specific output, -% rather than to limit the output fields -% --------------------------------------------------------------------- - -nodata_val = -9999; -nodata_tol = 1E-5; - -stats_out = nodata_val+zeros(6,1); -stats_out(5) = 0 ; -stats_out(6) = 0 ; - -if length(weights) ~= length(array_in) - error('input vectors need to have the same dimensions') -end - -nodata_ind = (isnan(array_in) | ... - abs(array_in - nodata_val) +180.0; lon(msk2) = lon(msk2) - 360.0; -switch projection - case 'N' - idx = lat < 0.0; - lat(idx) = NaN; - lon(idx) = NaN; - case 'S' - idx = lat > 0.0; - lat(idx) = NaN; - lon(idx) = NaN; -end - -% ========= EOF ========================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m deleted file mode 100644 index e8afdd7b..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/EASEv2_latlon2ind.m +++ /dev/null @@ -1,218 +0,0 @@ -% -% SMAPEASE2FORWARD The principal function is to perform forward transformation -% from (lat,lon)'s to (row,col)'s for a set of nested EASE -% grids defined at 1, 3, 9, and 36km grid resolutions. These -% grids are all based on the EASE-Grid 2.0 specification (WGS84 -% ellipsoid). -% -% SYNTAX [row,col] = smapease2forward(lat,lon,gridid) -% -% where gridid is a 3-character string enclosed in single -% quotes, in the form of {M|N|S}{01,03,09,36}. This subroutine -% accepts vector inputs and produce vector outputs. -% -% HISTORY This subroutine was adapted from the offical EASE-Grid-2.0 -% conversion utilities (written in IDL) developed by the -% NSIDC. -% -% Note that in NSIDC's original implementation, (row,col) are -% zero-based. In other words, the first cell is (0,0) and the -% last cell is (N-1,M-1), where N and M are the row and column -% dimensions of the array. In this MATLAB implementation, the -% same convention is used. In other words, the end point of -% the first cell is located at (r,c) = (-0.5,-0.5) whereas the -% end point of the last cell is located at (r,c) = (14615.5, -% 34703.5). Thus, -% -% [lat,lon] = smapease2inverse(-0.5,-0.5,'M01') returns: -% lat = 85.044566407398861 -% lon = 1.799999999999994e+02 -% -% [lat,lon] = smapease2inverse(14615.5,34703.5,'M01') returns: -% lat = -85.044566407398861 -% lon = -1.799999999999994e+02 -% -% The polar grids, on the other hand, are more complete in -% terms of latitude coverage: -% -% [lat,lon] = smapease2inverse(8999,8999,'N01') -% lat = 89.993669248945238 -% lon = -135 -% [lat,lon] = smapease2inverse(9000,9000,'N01') -% lat = 89.993669248945238 -% lon = 45 -% -% [lat,lon] = smapease2inverse(8999,8999,'S01') -% lat = -89.993669248945238 -% lon = -45 -% [lat,lon] = smapease2inverse(9000,9000,'S01') -% lat = -89.993669248945238 -% lon = 135 -% -% UPDATE North/south polar projections were added. (03/2012) -% -% REFERENCE Brodzik, M. J., B. Billingsley, T. Haran, B. Raup, and M. H. -% Savoie (2012): EASE-Grid 2.0: Incremental but Significant -% Improvements for Earth-Gridded Data Sets. ISPRS International -% Journal of Geo-Information, vol. 1, no. 1, pp. 32-45, -% http://www.mdpi.com/2220-9964/1/1/32/ -% -% Steven Chan, 11/2011 -% Email: steven.k.chan@jpl.nasa.gov - -function [row,col] = EASEv2_latlon2ind(lat,lon,gridid,return_rounded) - -% By design, [row, col] are real numbers, with the fractional portion indicating -% the position of the specified [lat, lon] coordinates between adjacent grid -% cell centers. E.g., col=0.5 indicates that the input longitude is on the -% boundary between grid cells associated with col=0 and col=1. -% If the [optional] input argument 'return_rounded' is present and ~=0, then -% [row, col] are rounded to the nearest integer. - -% Constants returned by EASE2_GRID_INFO.PRO -projection = gridid(1); -switch gridid - case 'M36' - map_scale_m = 36032.220840584; - cols = 964; - rows = 406; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'M09' - map_scale_m = 9008.055210146; - cols = 3856; - rows = 1624; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'M03' - map_scale_m = 3002.6850700487; - cols = 11568; - rows = 4872; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'M01' - map_scale_m = 1000.89502334956; - cols = 34704; - rows = 14616; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'N36' - map_scale_m = 36000.0; - cols = 500; - rows = 500; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'N09' - map_scale_m = 9000.0; - cols = 2000; - rows = 2000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'N03' - map_scale_m = 3000.0; - cols = 6000; - rows = 6000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'N01' - map_scale_m = 1000.0; - cols = 18000; - rows = 18000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'S36' - map_scale_m = 36000.0; - cols = 500; - rows = 500; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'S09' - map_scale_m = 9000.0; - cols = 2000; - rows = 2000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'S03' - map_scale_m = 3000.0; - cols = 6000; - rows = 6000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - case 'S01' - map_scale_m = 1000.0; - cols = 18000; - rows = 18000; - r0 = (cols-1)/2; - s0 = (rows-1)/2; - otherwise - disp(['ERROR: Incompatible grid specification.']); -end - -% Constants returned by EASE2_MAP_INFO.PRO -epsilon = 1.0e-6; -map_equatorial_radius_m = 6378137.0; -map_eccentricity = 0.081819190843; -e2 = map_eccentricity^2; -switch projection - case 'M' - map_reference_latitude = 0.0; - map_reference_longitude = 0.0; - map_second_reference_latitude = 30.0; - sin_phi1 = sin(map_second_reference_latitude*pi/180); - cos_phi1 = cos(map_second_reference_latitude*pi/180); - kz = cos_phi1/sqrt(1.0-e2*sin_phi1*sin_phi1); - case 'N' - map_reference_latitude = 90.0; - map_reference_longitude = 0.0; - case 'S' - map_reference_latitude = -90.0; - map_reference_longitude = 0.0; -end - -% Selected calculations inside WGS84_CONVERT.PRO and WGS84_CONVERT_XY.PRO -dlon = lon - map_reference_longitude; -msk1 = dlon < -180.0; dlon(msk1) = dlon(msk1) + 360.0; -msk2 = dlon > +180.0; dlon(msk2) = dlon(msk2) - 360.0; -phi = lat*pi/180.0; -lam = dlon*pi/180.0; -sin_phi = sin(phi); -q = (1.0-e2)*((sin_phi./(1.0-e2*sin_phi.*sin_phi))-(1.0/(2.0*map_eccentricity))*log((1.0-map_eccentricity*sin_phi)./(1.0+map_eccentricity*sin_phi))); -qp = 1.0-((1.0-e2)/(2.0*map_eccentricity)*log((1.0-map_eccentricity)/(1.0+map_eccentricity))); -switch projection - case 'M' - x = map_equatorial_radius_m*kz*lam; - y = (map_equatorial_radius_m*q)/(2.0*kz); - case 'N' - tmp = qp - q; - tmp(abs(tmp) < epsilon) = 0.0; - rho = map_equatorial_radius_m*sqrt(tmp); - x = rho.*sin(lam); - y = -rho.*cos(lam); - case 'S' - tmp = qp + q; - tmp(abs(tmp) < epsilon) = 0.0; - rho = map_equatorial_radius_m*sqrt(tmp); - x = rho.*sin(lam); - y = rho.*cos(lam); -end -row = s0-(y/map_scale_m); -col = r0+(x/map_scale_m); -switch projection - case 'N' - idx = lat < 0.0; - row(idx) = NaN; - col(idx) = NaN; - case 'S' - idx = lat > 0.0; - row(idx) = NaN; - col(idx) = NaN; -end - -if exist('return_rounded','var') - if return_rounded - col=round(col); - row=round(row); - end -end - -% ========= EOF ========================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m deleted file mode 100644 index d2e52d2f..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/J2000_to_DateTime.m +++ /dev/null @@ -1,111 +0,0 @@ -function [yr, mm, dd, hr, mn, ss, doy, pen] = J2000_to_DateTime( J2000_seconds, epoch_id) -% -% Convert J2000 time [seconds] into calendar date time. -% -% J2000 time is used in SMAP products (epoch_id = "TT12"). See subfunction J2000_epoch() below. -% -% See also GEOSldas module LDAS_DateTimeMod.F90 -% -% reichle, 28 Jul 2028 -% -% --------------------------------------------------------------------------- - -if ~exist( 'epoch_id', 'var' ) epoch_id = 'TT12'; end % default is what SMAP uses - -date_time_epoch = J2000_epoch( epoch_id ); - -N = length(J2000_seconds); - -yr = zeros(N,1); -mm = zeros(N,1); -dd = zeros(N,1); -hr = zeros(N,1); -mn = zeros(N,1); -ss = zeros(N,1); -doy = zeros(N,1); -pen = zeros(N,1); - -% Loop through elements of J2000_seconds for now. In future, should vectorize -% augment_date_time.m, is_leap_year.m, days_in_month.m, get_dofyr_pentad.m - -for ii = 1:N - - % add (rounded) J2000_seconds to date_time_epoch - - date_time = augment_date_time( round(J2000_seconds), date_time_epoch ); - - yr( ii) = date_time.year ; - mm( ii) = date_time.month ; - dd( ii) = date_time.day ; - hr( ii) = date_time.hour ; - mn( ii) = date_time.min ; - ss( ii) = date_time.sec ; - pen(ii) = date_time.pentad; - doy(ii) = date_time.dofyr ; - -end - -% ---------------------------------------------------------------------------------- - -function [J2000_epoch_datetime] = J2000_epoch( epoch_id ) - -% definition of J2000 epochs -% -% "J2000 seconds" are elapsed seconds since J2000 Epoch, which is either -% -% - "UT12": 11:58:55.816 on 1 Jan 2000 in Coordinated Universal Time (UTC), or -% - "TT12": 12:00:00.000 on 1 Jan 2000 in Terrestrial Time (TT), or -% - "UT00": 00:00:00.000 on 1 Jan 2000 in Coordinated Universal Time (UTC) -% -% NOTE: Per SMAP L1C_TB data products specs document, SMAP time stamps use "UT12" -% but sample granules appear to be using "TT12". -% NOTE: Per Clara Draper (30 Jun 2015), the nc4 ASCAT soil moisture retrieval -% product uses "UT00". - -J2000_UT12.year = 2000; -J2000_UT12.month = 1; -J2000_UT12.day = 1; -J2000_UT12.hour = 11; -J2000_UT12.min = 58; -J2000_UT12.sec = 55; % rounded down -J2000_UT12.pentad = 1; -J2000_UT12.dofyr = 1; - -J2000_TT12.year = 2000; -J2000_TT12.month = 1; -J2000_TT12.day = 1; -J2000_TT12.hour = 12; -J2000_TT12.min = 0; -J2000_TT12.sec = 0; -J2000_TT12.pentad = 1; -J2000_TT12.dofyr = 1; - -J2000_UT00.year = 2000; -J2000_UT00.month = 1; -J2000_UT00.day = 1; -J2000_UT00.hour = 0; -J2000_UT00.min = 0; -J2000_UT00.sec = 0; -J2000_UT00.pentad = 1; -J2000_UT00.dofyr = 1; - -% ---------------------------------- - -switch epoch_id - -case 'UT12' - J2000_epoch_datetime = J2000_UT12; - -case 'TT12' - J2000_epoch_datetime = J2000_TT12; - -case 'UT00' - J2000_epoch_datetime = J2000_UT00; - -otherwise - - error('J2000_to_DateTime: unknown J2000 epoch_id') - -end - -% ======================= EOF ================================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m deleted file mode 100644 index 14f8cc6c..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/MAPL_ReadForcing_fullfile.m +++ /dev/null @@ -1,80 +0,0 @@ -function [tile_data,N_tile,start_time,end_time] = ... - MAPL_ReadForcing_fullfile(fname,nodata,nodata_tolfrac) - -% Matlab version of MAPL_ReadForcing(). So far only reads complete file! -% -% Reads binary climatology or time series files (e.g., lai.dat, vegopacity.dat). - -% Q. Liu, 18 Jul 2022 -% rreichle, 29 Jul 2022 - -% ------------------------------------------------------------------------- -% -% check whether no-data variables are available on input - -if ~exist('nodata', 'var'), nodata = 1.e15; end % default: MAPL_UNDEF -if ~exist('nodata_tolfrac', 'var'), nodata_tolfrac = 1.e-4; end - -nodata_tol = abs( nodata*nodata_tolfrac ); - -% ------------------------------------------------------------------------- - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -disp(['reading from ', fname]) - -ifp = fopen( fname, 'r', 'l' ); - -% time loop (continue until reach end-of-file) - -nn=0; - -while 1 - - nn = nn +1; - - % read header - - fortran_tag = fread( ifp, 1, int_precision ); - header = fread( ifp, 14, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % safe way to detect end-of-file - if isempty(header) - break - end - - start_time(nn).year = header( 1); - start_time(nn).month = header( 2); - start_time(nn).day = header( 3); - start_time(nn).hour = header( 4); - start_time(nn).min = header( 5); - start_time(nn).sec = header( 6); - - end_time( nn).year = header( 7); - end_time( nn).month = header( 8); - end_time( nn).day = header( 9); - end_time( nn).hour = header(10); - end_time( nn).min = header(11); - end_time( nn).sec = header(12); - - N_tile = header(13); - - % read science data - - fortran_tag = fread( ifp, 1, int_precision ); - tmp_data = fread( ifp, [1 N_tile], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - tile_data(nn,:) = tmp_data; - -end - -% replace nodata values with NaN - -tile_data( abs( single(tile_data) - single(nodata) ) < nodata_tol ) = NaN; - -fclose(ifp); - -% ========================= EOF ============================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m deleted file mode 100644 index f3257074..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/augment_date_time.m +++ /dev/null @@ -1,149 +0,0 @@ - -function [date_time] = augment_date_time( dtstep, date_time_old ) - -% reichle, 22 Jun 2005 - -% dtstep in seconds - -date_time = date_time_old; - -dtstep_left = dtstep; - -if isnan(dtstep) - - error('ERROR: dtstep=NaN in augment_date_time.m'); - -elseif dtstep==0 % trivial case - - date_time = get_dofyr_pentad(date_time); - - return - -elseif dtstep>0 - - while (dtstep_left>0) - - % increase by one day at a time - - dtstep_tmp = min( dtstep_left, 86400 ); - - dtstep_left = round( dtstep_left - dtstep_tmp ); - - % compute secs_in_day from hh:mm:ss - - secs_in_day = date_time.hour*3600 + date_time.min*60 + date_time.sec; - - % augment - - secs_in_day = secs_in_day + dtstep_tmp; - - % compute new hh:mm:ss from secs_in_day - - date_time.hour = (floor(mod(secs_in_day,86400)/3600)); - date_time.min = (floor(mod(secs_in_day,86400)/60) - date_time.hour*60); - date_time.sec = (floor(mod(secs_in_day,86400)) ... - - date_time.hour*3600 ... - - date_time.min*60); - - % augment year/month/day and dofyr as necessary - - if ( secs_in_day >= 86400 ) - - % get number of days in month - - last_day = days_in_month( date_time.year, date_time.month); - - if (date_time.day==last_day) - - if (date_time.month==12) - - date_time.year = date_time.year + 1; - date_time.month = 1; - date_time.day = 1; - - else - - date_time.month = date_time.month + 1; - date_time.day = 1; - - end - - else - - date_time.day = date_time.day + 1; - - end - - end - - end - -else - - while (dtstep_left<0) - - % decrease by one day at a time - - dtstep_tmp = max( dtstep_left, -86400 ); - - dtstep_left = round( dtstep_left - dtstep_tmp ); - - % compute secs_in_day from hh:mm:ss - - secs_in_day = date_time.hour*3600 + date_time.min*60 + date_time.sec; - - % augment - - secs_in_day = secs_in_day + dtstep_tmp; - - % compute new hh:mm:ss from secs_in_day - - secs_in_day_tmp = secs_in_day + 86400; - - date_time.hour = (floor(mod(secs_in_day_tmp,86400)/3600)); - date_time.min = (floor(mod(secs_in_day_tmp,86400)/60)-date_time.hour*60); - date_time.sec = (floor(mod(secs_in_day_tmp,86400)) ... - - date_time.hour*3600 ... - - date_time.min*60); - - % augment year/month/day and dofyr as necessary - - if ( secs_in_day < 0 ) - - if (date_time.day==1) - - if (date_time.month==1) - - date_time.year = date_time.year - 1; - date_time.month = 12; - date_time.day = 31; - - else - - date_time.month = date_time.month - 1; - - % get number of days in previous month - - date_time.day = days_in_month( date_time.year, date_time.month); - - end - - else - - date_time.day = date_time.day - 1; - - end - - end - - end - -end - -% get dofyr and pentad - -date_time = get_dofyr_pentad(date_time); - - -% ****** EOF ******************************************************* - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m deleted file mode 100644 index 5e89e648..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/days_in_month.m +++ /dev/null @@ -1,16 +0,0 @@ - -function [n_days] = days_in_month( year, month ) - -% reichle, 22 Jun 2005 - -days_in_month_leap = [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]; - -days_in_month_nonleap = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]; - -if (is_leap_year(year)) - n_days = days_in_month_leap(month); -else - n_days = days_in_month_nonleap(month); -end - -% **************************** EOF ******************************** \ No newline at end of file diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m deleted file mode 100644 index 63432a9d..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/get_dofyr_pentad.m +++ /dev/null @@ -1,19 +0,0 @@ - -function [ date_time ] = get_dofyr_pentad( date_time ) - -% compute dofyr and pentad for date_time - -date_time.dofyr = date_time.day; - -% add up days in months prior to current month - -for i=1:(date_time.month-1) - - date_time.dofyr = date_time.dofyr + days_in_month(date_time.year,i); - -end - -date_time.pentad = pentad_of_year(date_time.dofyr, date_time.year); - - -% ======================= EOF ================================== \ No newline at end of file diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m deleted file mode 100644 index 1da1af71..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/is_leap_year.m +++ /dev/null @@ -1,30 +0,0 @@ -function [ leap ] = is_leap_year(year) - -% determine whether a given year is a leap yearb -% -% input: year, must be SCALAR ! -% -% output: leap = 0 if year is not leap year -% leap = 1 if year is leap year -% -% reichle, 1 Mar 2001 -% -% --------------------------------------------------------------------- - -if (length(year) ~= 1) - disp('error, input to is_leap_year() must be scalar, exiting...') - return -end - -if (mod(year,4) ~= 0) - leap = 0; -elseif (mod(year,400) == 0) - leap = 1; -elseif (mod(year,100) == 0) - leap = 0; -else - leap = 1; -end - -% ========= EOF ========================================================= - \ No newline at end of file diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m deleted file mode 100644 index cc827841..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/pentad_of_year.m +++ /dev/null @@ -1,14 +0,0 @@ - -function pentad = pentad_of_year(day_of_year, year) - -if (is_leap_year(year) & day_of_year>=59) - - pentad = floor((day_of_year-2)/5)+1; - -else - - pentad = floor((day_of_year-1)/5)+1; - -end - -% ======================= EOF ================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m deleted file mode 100644 index 9b3ec87d..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_ObsFcstAna.m +++ /dev/null @@ -1,192 +0,0 @@ -function [date_time, ... - obs_assim, ... - obs_species, ... - obs_tilenum, ... - obs_lon, ... - obs_lat, ... - obs_obs, ... - obs_obsvar, ... - obs_fcst, ... - obs_fcstvar, ... - obs_ana, ... - obs_anavar ... - ] = ... - read_ObsFcstAna( fname, isLDASsa ) - -% -% read_ObsFcstAna.m can be used to read "ObsFcstAna" files that -% contain Observations and observation-space model forecasts and -% analysis data -% -% data format: -% see f90 subroutine output_ObsFcstAna() in module clsm_ensupd_enkf_update -% -% reichle, 4 Oct 2011 -% -% ------------------------------------------------------------------ - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file -logical_precision = 'int32'; % precision of data in input file - -% initialize outputs in case file does not exist or is empty - -nodata = -9999; - -date_time = struct('year', nodata, ... - 'month', nodata, ... - 'day', nodata, ... - 'hour', nodata, ... - 'min', nodata, ... - 'sec', nodata, ... - 'dofyr', nodata, ... - 'pentad', nodata ); - -obs_assim = []; -obs_species = []; -obs_tilenum = []; -obs_lon = []; -obs_lat = []; -obs_obs = []; -obs_obsvar = []; -obs_fcst = []; -obs_fcstvar = []; -obs_ana = []; -obs_anavar = []; - -if exist('isLDASsa','var') && isLDASsa == 1 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -% read file if it exists - -if exist(fname)==2 - - disp(['reading from ', fname ]) - - ifp = fopen( fname, 'r', machfmt ); - - % read N_obs and time stamp entry - - fortran_tag = fread( ifp, 1, int_precision ); - N_obs = fread( ifp, 1, int_precision ); - year = fread( ifp, 1, int_precision ); - month = fread( ifp, 1, int_precision ); - day = fread( ifp, 1, int_precision ); - hour = fread( ifp, 1, int_precision ); - minute = fread( ifp, 1, int_precision ); - second = fread( ifp, 1, int_precision ); - dofyr = fread( ifp, 1, int_precision ); - pentad = fread( ifp, 1, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - date_time.year = year; - date_time.month = month; - date_time.day = day; - date_time.hour = hour; - date_time.min = minute; - date_time.sec = second; - date_time.dofyr = dofyr; - date_time.pentad = pentad; - - % read observation assim flag - - fortran_tag = fread( ifp, 1, int_precision ); - tmp_data = fread( ifp, [N_obs 1], logical_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - obs_assim = zeros( N_obs, 1); - obs_assim( tmp_data~= 0 ) = 1; - - % read species information - - fortran_tag = fread( ifp, 1, int_precision ); - obs_species = fread( ifp, [N_obs 1], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read tile number information - - fortran_tag = fread( ifp, 1, int_precision ); - obs_tilenum = fread( ifp, [N_obs 1], int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read longitude - - fortran_tag = fread( ifp, 1, int_precision ); - obs_lon = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read latitude - - fortran_tag = fread( ifp, 1, int_precision ); - obs_lat = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - - % read observation value - - fortran_tag = fread( ifp, 1, int_precision ); - obs_obs = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read observation variance - - fortran_tag = fread( ifp, 1, int_precision ); - obs_obsvar = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - - % read observation-space model forecast value - - fortran_tag = fread( ifp, 1, int_precision ); - obs_fcst = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read observation-space model forecast variance - - fortran_tag = fread( ifp, 1, int_precision ); - obs_fcstvar = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - - % read observation-space analysis value - - fortran_tag = fread( ifp, 1, int_precision ); - obs_ana = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - % read observation-space analysis variance - - fortran_tag = fread( ifp, 1, int_precision ); - obs_anavar = fread( ifp, [N_obs 1], float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - - % no-data check - % - single ensemble member integrations yield obs_obsvar==nodata) - % - in some cases obs_fcst (a.k.a. Obs_pred) is no-data-value, - % eg. SMOS Tb when snow is present) - - obs_obsvar( obs_obsvar == nodata ) = NaN; - - obs_fcst( obs_fcst == nodata ) = NaN; - obs_fcstvar( obs_fcstvar == nodata ) = NaN; - - obs_ana( obs_ana == nodata ) = NaN; - obs_anavar( obs_anavar == nodata ) = NaN; - - - % close file - - fclose(ifp); - -else % if exist(fname)==2 - - disp(['file does not exist: ', fname]) - -end - - -% ======= EOF ========================================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m deleted file mode 100644 index 394e4052..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_catparam.m +++ /dev/null @@ -1,298 +0,0 @@ - -function [ cat_param, cat_param_units ] = read_catparam( fname, N_tile, isLDASsa ); - -% reichle, 2 Jun 2006 -% reichle, 16 Jul 2010 - added vegcls lookup table -% reichle, 28 Oct 2010 - added soilcls* -% - changed cat_param structure from "vector of -% structures" to "structure of vectors" -% reichle, 1 Apr 2015 - added new soil parameter fields (file_format==3) -% - added cat_param_units -% reichle, 28 Jul 2022 - cleaned up LDASsa/GEOSldas switch for commit into GEOSldas repo - -% NOTE: For large files this reader is inefficient (slow execution, -% excessive memory demand) due to the use of a matlab structure -% array. If better performance is required, convert to reading -% data into a regular matrix (as opposed to a structure array). -% -% -% parameter "vegcls" is land cover type: -% -% vegcls = 1: broadleaf evergreen trees -% vegcls = 2: broadleaf deciduous trees -% vegcls = 3: needleleaf trees -% vegcls = 4: grassland -% vegcls = 5: broadleaf shrubs -% vegcls = 6: dwarf trees -% vegcls = 7: bare soil -% vegcls = 8: desert soil -% -% -% parameters "soilcls30" and "soilcls100" are 0-30 cm and 0-100 cm soil class: -% -% Two similar but different look-up tables were used for the MERRA and -% Fortuna versions of the Catchment model. -% -% The first look-up table is from http://www.iges.org/gswp2/. [Note that -% the GSWP-2 documentation refers to these values as "Cosby" (even though -% they are different from the Cosby et al 1984 values, see below.] -% The GSWP-2 values were used by Sarith in the Richards' equation -% pre-processing steps and are used in subroutine catchment() (via Sarith's -% Catchment model parameter files): -% -% Soil Soil B Porosity Wilting Psis *Surface* -% Class Type (v/v) Point(v/v) (m) Ks (m/s) -% -% 1 : Sand 3.30 0.373 0.089 -0.05 0.0285 -% 2 : Loamy Sand 3.80 0.386 0.132 -0.07 0.0204 -% 3 : Sandy Loam 4.34 0.419 0.205 -0.16 0.0097 -% 4 : Silt Loam 5.25 0.476 0.355 -0.65 0.0027 -% 5 : Silt -% 6 : Loam 5.96 0.437 0.339 -0.24 0.0054 -% 7 : Sandy Clay Loam 7.32 0.412 0.379 -0.12 0.0073 -% 8 : Silty Clay Loam 8.41 0.478 0.521 -0.63 0.0017 -% 9 : Clay Loam 8.34 0.447 0.472 -0.28 0.0032 -% 10 : Sandy Clay 9.70 0.415 0.480 -0.12 0.0050 -% 11 : Silty Clay 10.78 0.478 0.598 -0.58 0.0012 -% 12 : Clay 12.93 0.450 0.613 -0.27 0.0015 -% -% The second look-up table is from Cosby et al. WRR 1984. These values -% were used by Randy in some of the Catchment model paramter pre-processing -% steps (other than the Richards' equation solver): -% -% Soil Soil B Porosity Wilting Psis *Surface* -% Class Type (v/v) Point(v/v) (m) Ks (m/s) -% -% 1 : Sand 2.79 0.339 0.0218 -0.0692 0.0542931 -% 2 : Loamy Sand 4.26 0.421 0.0599 -0.0363 0.0163963 -% 3 : Sandy Loam 4.74 0.434 0.1002 -0.1413 0.00609179 -% 4 : Silt Loam 5.33 0.476 0.1772 -0.7586 0.00327148 -% 5 : Silt 5.33 0.476 0.1772 -0.7586 0.00327148 -% 6 : Loam 5.25 0.439 0.1393 -0.3548 0.00393319 -% 7 : Sandy Clay Loam 6.77 0.404 0.1438 -0.1349 0.00518495 -% 8 : Silty Clay Loam 8.72 0.464 0.2477 -0.6166 0.00236998 -% 9 : Clay Loam 8.17 0.465 0.2144 -0.2630 0.00284934 -% 10 : Sandy Clay 10.73 0.406 0.2053 -0.0977 0.00840901 -% 11 : Silty Clay 10.39 0.468 0.2597 -0.3236 0.00156583 -% 12 : Clay 11.55 0.468 0.2240 -0.0389 0.00113434 -% -% -% In both cases, the *surface* Ks that is needed as input to subroutine -% catchment() was extrapolated from the Ks provided by GSWP-2 or Cosby et al -% using the vertical conductivity decay factor "gnu" (which might be -% inconsistent with "gnu" used elsewhere). -% -% -% Starting in late 2014, revised soil parameters can be used in LDASsa. -% For details see De Lannoy et al., 2014, doi:10.1002/2014MS000330. -% -% ------------------------------------------------------------------ - -if ~exist('isLDASsa','var') isLDASsa = 0; end % default is GEOSldas output - -% for backward compatibility, back out number of parameters in file -% from file size: - -% file size = N_param * (N_tile + 2) * bytes_per_datapoint - -tmps = dir(fname); - -if isLDASsa ~= 0 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -N_param = tmps.bytes/((N_tile+2)*4); - -if N_param==40 - - file_format = 1; - - if isLDASsa ~= 0 - int_columns = 18; % vegcls - else - int_columns = []; % GEOSldas files contain only real*4 numbers - end - -elseif N_param==42 | N_param==51 | N_param==52 - - file_format = 2; - - if isLDASsa ~= 0 - int_columns = [ 18 19 20 ]; % vegcls, soilcls30, soilcls100 - else - int_columns = []; % GEOSldas files contain only real*4 numbers - end - -else - - error('read_catparam.m: something wrong with file size or format') - -end - -disp(['read_catparam.m: expecting ', num2str(N_param), ... - ' parameters in file with file_format ', num2str(file_format)]) - -% ---------------------------------------------------------------- - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -disp(['read_catparam.m: reading from ', fname]) - -ifp = fopen( fname, 'r', machfmt ); - -for i=1:N_param - - fortran_tag = fread( ifp, 1, int_precision ); - if any(i==int_columns) - tmp = fread( ifp, [1 N_tile], int_precision ); - else - tmp = fread( ifp, [1 N_tile], float_precision ); - end - fortran_tag = fread( ifp, 1, int_precision ); - - tmp_data(i,:) = tmp; - -end - -disp(['read_catparam.m: assembling structure array']) - -switch file_format - - case {1} - - cat_param.dpth = tmp_data( 1,:)'; cat_param_units.dpth = '[mm]'; - - cat_param.dzsf = tmp_data( 2,:)'; cat_param_units.dzsf = '[mm]'; - cat_param.dzrz = tmp_data( 3,:)'; cat_param_units.dzrz = '[mm]'; - cat_param.dzpr = tmp_data( 4,:)'; cat_param_units.dzpr = '[mm]'; - - cat_param.dzgt(:,1) = tmp_data( 5,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,2) = tmp_data( 6,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,3) = tmp_data( 7,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,4) = tmp_data( 8,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,5) = tmp_data( 9,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,6) = tmp_data(10,:)'; cat_param_units.dzgt = '[m]'; - - cat_param.poros = tmp_data(11,:)'; cat_param_units.poros = '[m3 m-3]'; - cat_param.cond = tmp_data(12,:)'; cat_param_units.cond = '[m s-1]'; - cat_param.psis = tmp_data(13,:)'; cat_param_units.psis = '[m H2O]'; - cat_param.bee = tmp_data(14,:)'; cat_param_units.bee = '[-]'; - - cat_param.wpwet = tmp_data(15,:)'; cat_param_units.wpwet = '[-]'; - - cat_param.gnu = tmp_data(16,:)'; cat_param_units.gnu = '[m-1]'; - - cat_param.vgwmax = tmp_data(17,:)'; cat_param_units.vgwmax = '[kg m-2]'; - - cat_param.vegcls = tmp_data(18,:)'; cat_param_units.vegcls = '[-]'; - - cat_param.bf1 = tmp_data(19,:)'; cat_param_units.bf1 = '[kg m-4]'; - cat_param.bf2 = tmp_data(20,:)'; cat_param_units.bf2 = '[m]'; - cat_param.bf3 = tmp_data(21,:)'; cat_param_units.bf3 = '[log(m)]'; - cat_param.cdcr1 = tmp_data(22,:)'; cat_param_units.cdcr1 = '[kg m-2]'; - cat_param.cdcr2 = tmp_data(23,:)'; cat_param_units.cdcr2 = '[kg m-2]'; - cat_param.ars1 = tmp_data(24,:)'; cat_param_units.ars1 = '[m2 kg-1]'; - cat_param.ars2 = tmp_data(25,:)'; cat_param_units.ars2 = '[m2 kg-1]'; - cat_param.ars3 = tmp_data(26,:)'; cat_param_units.ars3 = '[m4 kg-2]'; - cat_param.ara1 = tmp_data(27,:)'; cat_param_units.ara1 = '[m2 kg-1]'; - cat_param.ara2 = tmp_data(28,:)'; cat_param_units.ara2 = '[-]'; - cat_param.ara3 = tmp_data(29,:)'; cat_param_units.ara3 = '[m2 kg-1]'; - cat_param.ara4 = tmp_data(30,:)'; cat_param_units.ara4 = '[-]'; - cat_param.arw1 = tmp_data(31,:)'; cat_param_units.arw1 = '[m2 kg-1]'; - cat_param.arw2 = tmp_data(32,:)'; cat_param_units.arw2 = '[m2 kg-1]'; - cat_param.arw3 = tmp_data(33,:)'; cat_param_units.arw3 = '[m4 kg-2]'; - cat_param.arw4 = tmp_data(34,:)'; cat_param_units.arw4 = '[-]'; - cat_param.tsa1 = tmp_data(35,:)'; cat_param_units.tsa1 = '[-]'; - cat_param.tsa2 = tmp_data(36,:)'; cat_param_units.tsa2 = '[-]'; - cat_param.tsb1 = tmp_data(37,:)'; cat_param_units.tsb1 = '[-]'; - cat_param.tsb2 = tmp_data(38,:)'; cat_param_units.tsb2 = '[-]'; - cat_param.atau = tmp_data(39,:)'; cat_param_units.atau = '[-]'; - cat_param.btau = tmp_data(40,:)'; cat_param_units.btau = '[-]'; - - case {2} - - cat_param.dpth = tmp_data( 1,:)'; cat_param_units.dpth = '[mm]'; - - cat_param.dzsf = tmp_data( 2,:)'; cat_param_units.dzsf = '[mm]'; - cat_param.dzrz = tmp_data( 3,:)'; cat_param_units.dzrz = '[mm]'; - cat_param.dzpr = tmp_data( 4,:)'; cat_param_units.dzpr = '[mm]'; - - cat_param.dzgt(:,1) = tmp_data( 5,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,2) = tmp_data( 6,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,3) = tmp_data( 7,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,4) = tmp_data( 8,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,5) = tmp_data( 9,:)'; cat_param_units.dzgt = '[m]'; - cat_param.dzgt(:,6) = tmp_data(10,:)'; cat_param_units.dzgt = '[m]'; - - cat_param.poros = tmp_data(11,:)'; cat_param_units.poros = '[m3 m-3]'; - cat_param.cond = tmp_data(12,:)'; cat_param_units.cond = '[m s-1]'; - cat_param.psis = tmp_data(13,:)'; cat_param_units.psis = '[m H2O]'; - cat_param.bee = tmp_data(14,:)'; cat_param_units.bee = '[-]'; - - cat_param.wpwet = tmp_data(15,:)'; cat_param_units.wpwet = '[-]'; - - cat_param.gnu = tmp_data(16,:)'; cat_param_units.gnu = '[m-1]'; - - cat_param.vgwmax = tmp_data(17,:)'; cat_param_units.vgwmax = '[kg m-2]'; - - cat_param.vegcls = tmp_data(18,:)'; cat_param_units.vegcls = '[-]'; - cat_param.soilcls30 = tmp_data(19,:)'; cat_param_units.soilcls30 = '[-]'; - cat_param.soilcls100 = tmp_data(20,:)'; cat_param_units.soilcls100 = '[-]'; - - cat_param.bf1 = tmp_data(21,:)'; cat_param_units.bf1 = '[kg m-4]'; - cat_param.bf2 = tmp_data(22,:)'; cat_param_units.bf2 = '[m]'; - cat_param.bf3 = tmp_data(23,:)'; cat_param_units.bf3 = '[log(m)]'; - cat_param.cdcr1 = tmp_data(24,:)'; cat_param_units.cdcr1 = '[kg m-2]'; - cat_param.cdcr2 = tmp_data(25,:)'; cat_param_units.cdcr2 = '[kg m-2]'; - cat_param.ars1 = tmp_data(26,:)'; cat_param_units.ars1 = '[m2 kg-1]'; - cat_param.ars2 = tmp_data(27,:)'; cat_param_units.ars2 = '[m2 kg-1]'; - cat_param.ars3 = tmp_data(28,:)'; cat_param_units.ars3 = '[m4 kg-2]'; - cat_param.ara1 = tmp_data(29,:)'; cat_param_units.ara1 = '[m2 kg-1]'; - cat_param.ara2 = tmp_data(30,:)'; cat_param_units.ara2 = '[-]'; - cat_param.ara3 = tmp_data(31,:)'; cat_param_units.ara3 = '[m2 kg-1]'; - cat_param.ara4 = tmp_data(32,:)'; cat_param_units.ara4 = '[-]'; - cat_param.arw1 = tmp_data(33,:)'; cat_param_units.arw1 = '[m2 kg-1]'; - cat_param.arw2 = tmp_data(34,:)'; cat_param_units.arw2 = '[m2 kg-1]'; - cat_param.arw3 = tmp_data(35,:)'; cat_param_units.arw3 = '[m4 kg-2]'; - cat_param.arw4 = tmp_data(36,:)'; cat_param_units.arw4 = '[-]'; - cat_param.tsa1 = tmp_data(37,:)'; cat_param_units.tsa1 = '[-]'; - cat_param.tsa2 = tmp_data(38,:)'; cat_param_units.tsa2 = '[-]'; - cat_param.tsb1 = tmp_data(39,:)'; cat_param_units.tsb1 = '[-]'; - cat_param.tsb2 = tmp_data(40,:)'; cat_param_units.tsb2 = '[-]'; - cat_param.atau = tmp_data(41,:)'; cat_param_units.atau = '[-]'; - cat_param.btau = tmp_data(42,:)'; cat_param_units.btau = '[-]'; - - if N_param==51 | N_param==52 - - cat_param.gravel30 = tmp_data(43,:)'; cat_param_units.gravel30 = '[%vol]'; - cat_param.orgC30 = tmp_data(44,:)'; cat_param_units.orgC30 = '[%weight]'; - cat_param.orgC = tmp_data(45,:)'; cat_param_units.orgC = '[%weight]'; - cat_param.sand30 = tmp_data(46,:)'; cat_param_units.sand30 = '[%weight]'; - cat_param.clay30 = tmp_data(47,:)'; cat_param_units.clay30 = '[%weight]'; - cat_param.sand = tmp_data(48,:)'; cat_param_units.sand = '[%weight]'; - cat_param.clay = tmp_data(49,:)'; cat_param_units.clay = '[%weight]'; - cat_param.wpwet30 = tmp_data(50,:)'; cat_param_units.wpwet30 = '[-]'; - cat_param.poros30 = tmp_data(51,:)'; cat_param_units.poros30 = '[m3 m-3]'; - - end - - if N_param==52 - - cat_param.veghght = tmp_data(52,:)'; cat_param_units.veghght = '[m]'; - - end - - otherwise - - error('read_catparam.m: something wrong with file size or format') - -end - -fclose(ifp); - - -% =========== EOF =========================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m deleted file mode 100644 index 9e5d1fc8..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obslog.m +++ /dev/null @@ -1,51 +0,0 @@ - -function [ana_time, obs_descr, read_obs_subr, N_obs_read, obs_fname] = read_obslog(fname) - -% read LDASsa obs log files -% -% reichle, 2 Jan 2014 -% reichle, 11 Feb 2021 - corrected for post-launch file format -% -% ------------------------------------------------------------- - -% read file - -disp(['reading from ', fname]) - -fid = fopen( fname ); - -data = textscan(fid, '%s%s%s%d%s', ... - 'Delimiter', ',', ... - 'HeaderLines', 3 ); - -fclose(fid); - -disp('done reading file') - -% make sure that final line contained 'EOF', remove from data - -if strcmp(data{1}{end},'EOF') - - data{1}(end) = []; - data{2}(end) = []; - data{3}(end) = []; - data{4}(end) = []; - data{5}(end) = []; - -else - - error('read_obslog(): ERROR reading data') - -end - -% extract data into output variables - - -ana_time = data{1}; -obs_descr = data{2}; -read_obs_subr = data{3}; -N_obs_read = data{4}; -obs_fname = data{5}; - - -% ================== EOF ===================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m deleted file mode 100644 index 19e66056..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_obsparam.m +++ /dev/null @@ -1,80 +0,0 @@ -function [ N_obs_param, obs_param ] = read_obs_param( fname ) - -% Get observation parameters -% Format as in module enkf_types, subroutine write_obs_param -% -% Gabrielle De Lannoy - 26 Oct 2011 -% -% 1 Dec 2011 - reichle: minor modifications and check-in to CVS -% -% 8 Jun 2017 - reichle: added "flistpath" and "flistname" -% -% ------------------------------------------------------------------ - -fid = fopen(fname); - -disp(['Reading ',fname]); - -N_obs_param = fscanf(fid, '%d ', 1); - -for i=1:N_obs_param - - obs_param(i).descr = fscanf(fid, '%s ', 1); - obs_param(i).species = fscanf(fid, '%f ', 1); - obs_param(i).orbit = fscanf(fid, '%f ', 1); %1=A, 2=D - obs_param(i).pol = fscanf(fid, '%f ', 1); %1=H, 2=V - obs_param(i).N_ang = fscanf(fid, '%f ', 1); - - obs_param(i).ang = fscanf(fid, '%f ', obs_param(i).N_ang); - - obs_param(i).freq = fscanf(fid, '%f ', 1); - obs_param(i).FOV = fscanf(fid, '%f ', 1); - obs_param(i).FOV_units = fscanf(fid, '%s ', 1); - obs_param(i).assim = fscanf(fid, '%s ', 1); - obs_param(i).scale = fscanf(fid, '%s ', 1); - obs_param(i).getinnov = fscanf(fid, '%s ', 1); - obs_param(i).RTM_ID = fscanf(fid, '%f ', 1); - obs_param(i).bias_Npar = fscanf(fid, '%f ', 1); - obs_param(i).bias_trel = fscanf(fid, '%f ', 1); - obs_param(i).bias_tcut = fscanf(fid, '%f ', 1); - obs_param(i).nodata = fscanf(fid, '%f ', 1); - obs_param(i).varname = fscanf(fid, '%s ', 1); - obs_param(i).units = fscanf(fid, '%s ', 1); - obs_param(i).path = fscanf(fid, '%s ', 1); - obs_param(i).name = fscanf(fid, '%s ', 1); - obs_param(i).maskpath = fscanf(fid, '%s ', 1); - obs_param(i).maskname = fscanf(fid, '%s ', 1); - obs_param(i).scalepath = fscanf(fid, '%s ', 1); - obs_param(i).scalename = fscanf(fid, '%s ', 1); - obs_param(i).flistpath = fscanf(fid, '%s ', 1); - obs_param(i).flistname = fscanf(fid, '%s ', 1); - obs_param(i).errstd = fscanf(fid, '%f ', 1); - obs_param(i).std_normal_max = fscanf(fid, '%f ', 1); - obs_param(i).zeromean = fscanf(fid, '%s ', 1); - obs_param(i).coarsen_pert = fscanf(fid, '%s ', 1); - obs_param(i).xcorr = fscanf(fid, '%f ', 1); - obs_param(i).ycorr = fscanf(fid, '%f ', 1); - obs_param(i).adapt = fscanf(fid, '%f ', 1); - - % remove leading and trailing quotes from strings - - obs_param(i).descr = obs_param(i).descr( 2:end-1); - obs_param(i).FOV_units = obs_param(i).FOV_units(2:end-1); - obs_param(i).varname = obs_param(i).varname( 2:end-1); - obs_param(i).units = obs_param(i).units( 2:end-1); - obs_param(i).path = obs_param(i).path( 2:end-1); - obs_param(i).name = obs_param(i).name( 2:end-1); - obs_param(i).maskpath = obs_param(i).maskpath( 2:end-1); - obs_param(i).maskname = obs_param(i).maskname( 2:end-1); - obs_param(i).scalepath = obs_param(i).scalepath(2:end-1); - obs_param(i).scalename = obs_param(i).scalename(2:end-1); - obs_param(i).flistpath = obs_param(i).flistpath(2:end-1); - obs_param(i).flistname = obs_param(i).flistname(2:end-1); - -end - -fclose(fid); - -disp(['Done reading obs_param for ',num2str(N_obs_param),' species']); - -% =========================== EOF ==================================== diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m deleted file mode 100644 index 9418d2b5..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMaup.m +++ /dev/null @@ -1,152 +0,0 @@ - -function [ aup, units ] = read_smapL4SMaup( fname, N_tile, isLDASsa ); - -% reichle, 26 Apr 2013 -% reichle, 5 Feb 2014 - added tb_[h/v]_obs_time_sec -% reichle, 21 Mar 2015 - changed units of soil moisture output from wetness -% [dimensionless] to volumetric soil moisture [m3/m3] -% reichle, 28 Jul 2022 - cleaned up LDASsa/GEOSldas switch for commit into GEOSldas repo - -% NOTE: For large files this reader is inefficient (slow execution, -% excessive memory demand) due to the use of a matlab structure -% array. If better performance is needed, convert to reading -% data into a regular matrix (as opposed to a structure array). - -if ~exist('isLDASsa','var') is_LDASsa = 0; end % default is GEOSldas output - -N_param = 31; % number of records - -dbl_records = [1 2]; % double precision records - -int_records = [3 4 5 6]; % integer records - - -% ---------------------------------------------------------------- - -int_precision = 'int32'; % precision of fortran tag and integer data in input file -float_precision = 'float32'; % precision of real data in input file -dbl_precision = 'float64'; % precision of real*8 data in input file - -disp(['read_smapL4SMaup.m: reading from ', fname]) - -if isLDASsa ~= 0 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -ifp = fopen( fname, 'r', machfmt ); - -tmp_data = NaN*ones(N_param,N_tile); - -for i=1:N_param - - fortran_tag = fread( ifp, 1, int_precision ); - - if any(i==dbl_records) - - N_bytes = 8; - - else - - N_bytes = 4; - - end - - if (N_bytes*N_tile ~= fortran_tag) - - error('read_smapL4SMaup.m: inconsistent N_tile') - - end - - if any(i==int_records) - tmp = fread( ifp, [1 N_tile], int_precision ); - elseif any(i==dbl_records) - tmp = fread( ifp, [1 N_tile], dbl_precision ); - else - tmp = fread( ifp, [1 N_tile], float_precision ); - end - - fortran_tag = fread( ifp, 1, int_precision ); - - tmp_data(i,:) = tmp; - -end - -fclose(ifp); - -% --------------------------------------------------------- - -disp(['read_smapL4SMaup.m: assembling structure array']) - -aup.tb_h_obs_time_sec = tmp_data( 1,:)'; units{ 1} = '[s]'; -aup.tb_v_obs_time_sec = tmp_data( 2,:)'; units{ 2} = '[s]'; -aup.tb_h_resolution_flag = tmp_data( 3,:)'; units{ 3} = '[dimensionless]'; -aup.tb_v_resolution_flag = tmp_data( 4,:)'; units{ 4} = '[dimensionless]'; -aup.tb_h_orbit_flag = tmp_data( 5,:)'; units{ 5} = '[dimensionless]'; -aup.tb_v_orbit_flag = tmp_data( 6,:)'; units{ 6} = '[dimensionless]'; -aup.tb_h_obs = tmp_data( 7,:)'; units{ 7} = '[K]'; -aup.tb_v_obs = tmp_data( 8,:)'; units{ 8} = '[K]'; - -aup.tb_h_obs_assim = tmp_data( 9,:)'; units{ 9} = '[K]'; -aup.tb_v_obs_assim = tmp_data(10,:)'; units{10} = '[K]'; -aup.tb_h_obs_errstd = tmp_data(11,:)'; units{11} = '[K]'; -aup.tb_v_obs_errstd = tmp_data(12,:)'; units{12} = '[K]'; - -aup.tb_h_forecast = tmp_data(13,:)'; units{13} = '[K]'; -aup.tb_v_forecast = tmp_data(14,:)'; units{14} = '[K]'; -aup.tb_h_forecast_ensstd = tmp_data(15,:)'; units{15} = '[K]'; -aup.tb_v_forecast_ensstd = tmp_data(16,:)'; units{16} = '[K]'; - -aup.sm_surface_forecast = tmp_data(17,:)'; units{17} = '[m3 m-3]'; -aup.sm_rootzone_forecast = tmp_data(18,:)'; units{18} = '[m3 m-3]'; -aup.sm_profile_forecast = tmp_data(19,:)'; units{19} = '[m3 m-3]'; -aup.surface_temp_forecast = tmp_data(20,:)'; units{20} = '[K]'; -aup.soil_temp_layer1_forecast = tmp_data(21,:)'; units{21} = '[K]'; - -aup.sm_surface_analysis = tmp_data(22,:)'; units{22} = '[m3 m-3]'; -aup.sm_rootzone_analysis = tmp_data(23,:)'; units{23} = '[m3 m-3]'; -aup.sm_profile_analysis = tmp_data(24,:)'; units{24} = '[m3 m-3]'; -aup.surface_temp_analysis = tmp_data(25,:)'; units{25} = '[K]'; -aup.soil_temp_layer1_analysis = tmp_data(26,:)'; units{26} = '[K]'; - -aup.sm_surface_analysis_ensstd = tmp_data(27,:)'; units{27} = '[m3 m-3]'; -aup.sm_rootzone_analysis_ensstd = tmp_data(28,:)'; units{28} = '[m3 m-3]'; -aup.sm_profile_analysis_ensstd = tmp_data(29,:)'; units{29} = '[m3 m-3]'; -aup.surface_temp_analysis_ensstd = tmp_data(30,:)'; units{30} = '[K]'; -aup.soil_temp_layer1_analysis_ensstd = tmp_data(31,:)'; units{31} = '[K]'; - -% =========== EOF =========================================== - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m deleted file mode 100644 index f0cf783e..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_smapL4SMlmc.m +++ /dev/null @@ -1,139 +0,0 @@ - -function [ lmc, units ] = read_smapL4SMlmc( fname, N_tile, isLDASsa); - -% reichle, 26 Apr 2013 - -% NOTE: For large files this reader is inefficient (slow execution, -% excessive memory demand) due to the use of a matlab structure -% array. If you need better performance, convert to reading -% data into a regular matrix (as opposed to a structure array). -% -% GDL, 17 Feb 2014: - added units -% - revised fieldnames for consistency with L4_SM Product Specs Doc -% reichle, 27 May 2014: - changed wilting point output from "clsm_wpwet" to "clsm_wp" -% reichle, 17 Nov 2015: - added "veghght" output -% reichle, 28 Jul 2022 - cleaned up LDASsa/GEOSldas switch for commit into GEOSldas repo - -% ---------------------------------------------------------------- - -if ~exist('isLDASsa','var') isLDASsa = 0; end % default is GEOSldas output - -% for backward compatibility, back out number of parameters in file -% from file size: - -% file size = N_param * (N_tile + 2) * bytes_per_datapoint - -tmps = dir(fname); - -N_param = tmps.bytes/((N_tile+2)*4); - -if N_param==34 | N_param==35 - - int_records = [17 18]; - -else - - error('read_smapL4SMlmc.m: something wrong with file size or format') - -end - -disp(['read_smapL4SMlmc.m: expecting ', num2str(N_param), ' parameters in file']) - -% ---------------------------------------------------------------- - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -disp(['read_smapL4SMlmc.m: reading from ', fname]) - -if isLDASsa ~= 0 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -ifp = fopen( fname, 'r', machfmt ); - -for i=1:N_param - - fortran_tag = fread( ifp, 1, int_precision ); - - if (4*N_tile ~= fortran_tag) - - error('read_smapL4SMlmc.m: inconsistent N_tile') - - end - - if any(i==int_records) - tmp = fread( ifp, [1 N_tile], int_precision ); - else - tmp = fread( ifp, [1 N_tile], float_precision ); - end - - fortran_tag = fread( ifp, 1, int_precision ); - - tmp_data(i,:) = tmp; - -end - -fclose(ifp); - -% --------------------------------------------------------- - -disp(['read_smapL4SMlmc.m: assembling structure array']) - -lmc.cell_land_fraction = tmp_data( 1,:)'; units{ 1} = '[dimensionless]'; -lmc.cell_elevation = tmp_data( 2,:)'; units{ 2} = '[m]'; - -lmc.clsm_dzsf = tmp_data( 3,:)'; units{ 3} = '[m]'; -lmc.clsm_dzrz = tmp_data( 4,:)'; units{ 4} = '[m]'; -lmc.clsm_dzpr = tmp_data( 5,:)'; units{ 5} = '[m]'; - -lmc.clsm_dztsurf = tmp_data( 6,:)'; units{ 6} = '[m]'; - -lmc.clsm_dzgt1 = tmp_data( 7,:)'; units{ 7} = '[m]'; -lmc.clsm_dzgt2 = tmp_data( 8,:)'; units{ 8} = '[m]'; -lmc.clsm_dzgt3 = tmp_data( 9,:)'; units{ 9} = '[m]'; -lmc.clsm_dzgt4 = tmp_data(10,:)'; units{10} = '[m]'; -lmc.clsm_dzgt5 = tmp_data(11,:)'; units{11} = '[m]'; -lmc.clsm_dzgt6 = tmp_data(12,:)'; units{12} = '[m]'; - -lmc.clsm_poros = tmp_data(13,:)'; units{13} = '[m3 m-3]'; -lmc.clsm_wp = tmp_data(14,:)'; units{14} = '[m3 m-3]'; - -lmc.clsm_cdcr1 = tmp_data(15,:)'; units{15} = '[kg m-2]'; -lmc.clsm_cdcr2 = tmp_data(16,:)'; units{16} = '[kg m-2]'; - - -lmc.mwrtm_vegcls = tmp_data(17,:)'; units{17} = '[dimensionless]'; -lmc.mwrtm_soilcls = tmp_data(18,:)'; units{18} = '[dimensionless]'; - -lmc.mwrtm_sand = tmp_data(19,:)'; units{19} = '[dimensionless]'; -lmc.mwrtm_clay = tmp_data(20,:)'; units{20} = '[dimensionless]'; -lmc.mwrtm_poros = tmp_data(21,:)'; units{21} = '[m3 m-3]'; - -lmc.mwrtm_wangwt = tmp_data(22,:)'; units{22} = '[m3 m-3]'; -lmc.mwrtm_wangwp = tmp_data(23,:)'; units{23} = '[m3 m-3]'; - -lmc.mwrtm_rghhmin = tmp_data(24,:)'; units{24} = '[dimensionless]'; -lmc.mwrtm_rghhmax = tmp_data(25,:)'; units{25} = '[dimensionless]'; -lmc.mwrtm_rghwmin = tmp_data(26,:)'; units{26} = '[m3 m-3]'; -lmc.mwrtm_rghwmax = tmp_data(27,:)'; units{27} = '[m3 m-3]'; -lmc.mwrtm_rghnrh = tmp_data(28,:)'; units{28} = '[dimensionless]'; -lmc.mwrtm_rghnrv = tmp_data(29,:)'; units{29} = '[dimensionless]'; -lmc.mwrtm_rghpolmix = tmp_data(30,:)'; units{30} = '[dimensionless]'; - -lmc.mwrtm_omega = tmp_data(31,:)'; units{31} = '[dimensionless]'; - -lmc.mwrtm_bh = tmp_data(32,:)'; units{32} = '[dimensionless]'; -lmc.mwrtm_bv = tmp_data(33,:)'; units{33} = '[dimensionless]'; -lmc.mwrtm_lewt = tmp_data(34,:)'; units{34} = '[kg m-2]'; - -if N_param==35 - - lmc.clsm_veghght = tmp_data(35,:)'; units{35} = '[m]'; - -end - -% =========== EOF =========================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m deleted file mode 100644 index 422f6fb8..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilecoord.m +++ /dev/null @@ -1,240 +0,0 @@ - -function [tile_coord ] = read_tilecoord( fname, bin2txt, isLDASsa ) - -% read tile coordinates from *_tilecoord.[ext] file written by LDASsa -% -% reichle, 29 Jun 2005 -% GDL, 22 Jun 2010 - changed i_atm/j_atm/frac_atm to i_indg/j_indg/frac_cell -% reichle, 31 May 2011 - accomodate new field "elev" (elevation) -% reichle, 7 Jan 2014 - added capability to read binary "tilecoord" files -% and to convert a binary file into a txt file -% file extension: ".txt" --> ASCII file -% ".bin" --> binary file -% ASCII option maintains backward compatibility -% -% jperket, 1 Dec 2017 - added flag for LDASsa, big-endian format -% reichle, 28 Jul 2022 - cleaned up LDASsa/GEOSldas switch for commit into GEOSldas repo -% -% ------------------------------------------------------------- - -if ~exist('isLDASsa','var') isLDASsa = 0; end % default is GEOSldas output - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -% deal with "optional" bin2txt argument - -if ~exist('bin2txt','var') - - bin2txt = 0; - -end - -if isLDASsa ~= 0 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -% determine file name extension - -file_ext = deblank(fname); - -file_ext = file_ext(end-3:end); - -if strcmp(file_ext,'.txt') - - is_binary = 0; - - if bin2txt - - error('read_tilecoord.m: ERROR -- bin2txt conversion ', ... - 'requires input file name for bin file'); - - end - -elseif strcmp(file_ext,'.bin') - - is_binary = 1; - -else - - error('read_tilecoord.m: ERROR - unknown file extension') - -end - - -% --------------------------------- -% -% read file - -disp(['reading from ', fname]) - -if is_binary - - % open *_tilecoord.bin file - - ifp = fopen( fname, 'r', machfmt); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.N_tile = fread( ifp, 1, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - Nt = tile_coord.N_tile; - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.tile_id = fread( ifp, Nt, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.typ = fread( ifp, Nt, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.pfaf = fread( ifp, Nt, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.com_lon = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.com_lat = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.min_lon = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.max_lon = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.min_lat = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.max_lat = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.i_indg = fread( ifp, Nt, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.j_indg = fread( ifp, Nt, int_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.frac_cell = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.frac_pfaf = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.area = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - fortran_tag = fread( ifp, 1, int_precision ); - tile_coord.elev = fread( ifp, Nt, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - - % if requested, convert to ASCII (txt) file - - if bin2txt - - fname_out = deblank(fname); - - fname_out = [fname_out(1:end-4), '.txt']; - - % open *_tilecoord.txt file - - disp(['writing to ', fname]) - - ofp = fopen( fname_out, 'wt' ); - - fprintf( ofp, '%i\n', tile_coord.N_tile ); - - for ii=1:tile_coord.N_tile - - fprintf( ofp,['%8i%10i%9i', ... - '%10.4f%10.4f%10.4f%10.4f%10.4f%10.4f', ... - '%5i%5i%13.6f%13.6f%13.4f%13.4f\n'], ... - [tile_coord.tile_id(ii), ... - tile_coord.typ(ii), ... - tile_coord.pfaf(ii), ... - tile_coord.com_lon(ii), ... - tile_coord.com_lat(ii), ... - tile_coord.min_lon(ii), ... - tile_coord.max_lon(ii), ... - tile_coord.min_lat(ii), ... - tile_coord.max_lat(ii), ... - tile_coord.i_indg(ii), ... - tile_coord.j_indg(ii), ... - tile_coord.frac_cell(ii), ... - tile_coord.frac_pfaf(ii), ... - tile_coord.area(ii), ... - tile_coord.elev(ii) ]); - - end - - fclose(ofp); - - disp('done writing file') - - end - -else - - % open *_tilecoord.txt file - - ifp = fopen( fname, 'rt' ); - - tmpdata = fscanf( ifp, '%f' ); - - % -------------------------------------------------- - - % process data - - tile_coord.N_tile = tmpdata(1); - - N_cols = (length(tmpdata)-1)/tile_coord.N_tile; - - tmpdata = reshape(tmpdata(2:end), [N_cols, tile_coord.N_tile])'; - - tile_coord.tile_id = tmpdata(:, 1); - tile_coord.typ = tmpdata(:, 2); - tile_coord.pfaf = tmpdata(:, 3); - tile_coord.com_lon = tmpdata(:, 4); - tile_coord.com_lat = tmpdata(:, 5); - tile_coord.min_lon = tmpdata(:, 6); - tile_coord.max_lon = tmpdata(:, 7); - tile_coord.min_lat = tmpdata(:, 8); - tile_coord.max_lat = tmpdata(:, 9); - tile_coord.i_indg = tmpdata(:,10); - tile_coord.j_indg = tmpdata(:,11); - tile_coord.frac_cell = tmpdata(:,12); - tile_coord.frac_pfaf = tmpdata(:,13); - tile_coord.area = tmpdata(:,14); - - if N_cols==15 - - tile_coord.elev = tmpdata(:,15); - - end - -end - -% close file - -fclose(ifp); - -disp('done reading file') - -% =========== EOF ======================================== - - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m deleted file mode 100644 index 42997686..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/read_tilegrids.m +++ /dev/null @@ -1,136 +0,0 @@ - -function [ tile_grid_g, tile_grid_d ] = read_tilegrids( fname, isLDASsa ) - -% read tile grid definitions for "global" and "domain" grids -% from *_tilegrids.[ext] file written by LDASsa -% -% reichle, 8 July 2010 -% reichle, 7 Jan 2014 - added capability to read binary "tilegrids" files -% file extension: ".txt" --> ASCII file -% ".bin" --> binary file -% jperket, 4 Dec 2017 - added flag for LDASsa, big-endian format -% reichle, 28 Jul 2022 - cleaned up LDASsa/GEOSldas switch for commit into GEOSldas repo -% -% ------------------------------------------------------------- - -if ~exist('isLDASsa','var') isLDASsa = 0; end % default is GEOSldas output - -int_precision = 'int32'; % precision of fortran tag -float_precision = 'float32'; % precision of data in input file - -if isLDASsa ~= 0 - machfmt = 'b'; % big-endian, LDASsa -else - machfmt = 'l'; % little-endian, GEOSldas -end - -% determine file name extension - -file_ext = deblank(fname); - -file_ext = file_ext(end-3:end); - -% --------------------------------- -% -% read file - -if strcmp(file_ext,'.txt') - - % read ASCII file - - disp(['reading from ', fname]) - - % open *_tilegrids.txt file - - ifp = fopen( fname, 'rt' ); - - % read contents into cell array - - A=textscan(ifp,'%s'); - - fclose(ifp); - - disp('done reading file') - - % -------------------------------------------------- - - % re-assemble into long string and evaluate - - C=[]; - - for i=1:length(A{1}) - - C=[C, A{1}{i}]; - - end - - eval(C) % now have structures "tile_grid_g" and "tile_grid_d" - -elseif strcmp(file_ext,'.bin') - - % read binary file - - disp(['reading from ', fname]) - - % open *_tilegrids.txt file - - ifp = fopen( fname, 'r', machfmt); - - % read contents - - % first record: "global" grid (tile_grid_g) - - fortran_tag = fread( ifp, 1, int_precision ); - tile_grid_g.gridtype = fread( ifp, 40, 'uint8=>char' ); - tile_grid_g.ind_base = fread( ifp, 1, int_precision ); - tile_grid_g.i_dir = fread( ifp, 1, int_precision ); - tile_grid_g.j_dir = fread( ifp, 1, int_precision ); - tile_grid_g.N_lon = fread( ifp, 1, int_precision ); - tile_grid_g.N_lat = fread( ifp, 1, int_precision ); - tile_grid_g.i_offg = fread( ifp, 1, int_precision ); - tile_grid_g.j_offg = fread( ifp, 1, int_precision ); - tile_grid_g.ll_lon = fread( ifp, 1, float_precision ); - tile_grid_g.ll_lat = fread( ifp, 1, float_precision ); - tile_grid_g.ur_lon = fread( ifp, 1, float_precision ); - tile_grid_g.ur_lat = fread( ifp, 1, float_precision ); - tile_grid_g.dlon = fread( ifp, 1, float_precision ); - tile_grid_g.dlat = fread( ifp, 1, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - tile_grid_g.gridtype = deblank(tile_grid_g.gridtype'); - - % second record: "domain" grid (tile_grid_d) - - fortran_tag = fread( ifp, 1, int_precision ); - tile_grid_d.gridtype = fread( ifp, 40, 'uint8=>char' ); - tile_grid_d.ind_base = fread( ifp, 1, int_precision ); - tile_grid_d.i_dir = fread( ifp, 1, int_precision ); - tile_grid_d.j_dir = fread( ifp, 1, int_precision ); - tile_grid_d.N_lon = fread( ifp, 1, int_precision ); - tile_grid_d.N_lat = fread( ifp, 1, int_precision ); - tile_grid_d.i_offg = fread( ifp, 1, int_precision ); - tile_grid_d.j_offg = fread( ifp, 1, int_precision ); - tile_grid_d.ll_lon = fread( ifp, 1, float_precision ); - tile_grid_d.ll_lat = fread( ifp, 1, float_precision ); - tile_grid_d.ur_lon = fread( ifp, 1, float_precision ); - tile_grid_d.ur_lat = fread( ifp, 1, float_precision ); - tile_grid_d.dlon = fread( ifp, 1, float_precision ); - tile_grid_d.dlat = fread( ifp, 1, float_precision ); - fortran_tag = fread( ifp, 1, int_precision ); - - tile_grid_d.gridtype = deblank(tile_grid_d.gridtype'); - - % close file - - fclose(ifp); - - disp('done reading file') - -else - - error('read_tilegrids.m: ERROR - unknown file extension') - -end - -% ================== EOF ===================================== - diff --git a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m b/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m deleted file mode 100644 index 0035eb32..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSldas_App/util/shared/matlab/tile2grid.m +++ /dev/null @@ -1,87 +0,0 @@ -function [ grid_data ] = ... - tile2grid( tile_data, tile_coord, tile_grid, nodata, nodata_tol ) - -% Mapping from tile to grid is based on fields "i_indg" and -% "j_indg" of tilecoord structure which are in reference to -% the *global* grid that underlies the tile definitions. -% Therefore, the input variable "tile_grid" must refer to *global* -% grid. - -% reichle, 26 Jan 2006 -% reichle, 25 Jul 2006 - expanded for RedArk_OSSE -% GDL, 22 Jun 2010 - adapted for latest LDAS-tag -% reichle, 8 Jul 2010 - use "tile_grid" as input, not bkwd-compatible! -% -% ----------------------------------------------------------------- - -% check whether no-data variables are available on input - -if ~exist('nodata'), nodata = -9999; end -if ~exist('nodata_tol'), nodata_tol = 1e-4; end - -% ----------------------------------------------------- - -N_fields = size(tile_data,1); - -% minimal check for consistency between tile_data and tile_coord - -if (size(tile_data,2)~=tile_coord.N_tile) - - input('tile2grid.m: Something wrong with N_tile, ctrl-c now!') - -end - -% ------------------------------------------------------ - -% initialize - -grid_data = zeros( tile_grid.N_lon, tile_grid.N_lat, N_fields ); - -for k=1:N_fields - - wgrid = zeros( tile_grid.N_lon, tile_grid.N_lat); - - % loop through tile space - - for n=1:tile_coord.N_tile - - i = tile_coord.i_indg(n) - (tile_grid.i_offg - (1-tile_grid.ind_base)); - j = tile_coord.j_indg(n) - (tile_grid.j_offg - (1-tile_grid.ind_base)); - - w = tile_coord.frac_cell(n); - - if (abs(tile_data(k,n)-nodata)>nodata_tol) - - grid_data(i,j,k) = grid_data(i,j,k) + w*tile_data(k,n); - - wgrid(i,j) = wgrid(i,j) + w; - - end - - end - - % normalize and set no-data-value - - for i=1:tile_grid.N_lon - - for j=1:tile_grid.N_lat - - if (wgrid(i,j)>0.) - - grid_data(i,j,k) = grid_data(i,j,k)/wgrid(i,j); - - else - - grid_data(i,j,k) = nodata; - - end - - end - end - -end - - -grid_data(find(grid_data==nodata)) = NaN; - -% ================ EOF ========================================= diff --git a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/CMakeLists.txt b/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/CMakeLists.txt deleted file mode 100644 index fdfbd9a1..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/CMakeLists.txt +++ /dev/null @@ -1,10 +0,0 @@ -esma_set_this () - -set (SRCS - LDAS_HashTable.F90 LDAS_Forcing.F90 LDAS_Interp.F90 GEOS_MetforceGridComp.F90 - ) - -esma_add_library (${this} - SRCS ${SRCS} - DEPENDENCIES GEOS_SurfaceShared GEOSland_GridComp GEOS_LdasShared MAPL GMAO_gfio_r4 - INCLUDES ${INC_ESMF}) diff --git a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/GEOS_MetforceGridComp.F90 b/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/GEOS_MetforceGridComp.F90 deleted file mode 100644 index b306e9fd..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/GEOS_MetforceGridComp.F90 +++ /dev/null @@ -1,1306 +0,0 @@ -#include "MAPL_Generic.h" - -!BOP -! !MODULE: GEOS_LddataatmGridCompMod - Data atmosphere GridComp for Catchment. -module GEOS_MetforceGridCompMod - - ! !USES - - use ESMF - use MAPL_Mod - - use LDAS_ensdrv_Globals, only: nodata_generic, nodata_tol_generic - use LDAS_ensdrv_Globals, only: logunit,logit !,root_logit - use LDAS_DateTimeMod, only: date_time_type, date_time_print - use LDAS_TileCoordType, only: tile_coord_type - use LDAS_TileCoordType, only: TILECOORD_WRAP - use LDAS_ForceMod, only: LDAS_GetForcing => get_forcing - use LDAS_ForceMod, only: LDAS_move_new_force_to_old - use LDAS_ForceMod, only: FileOpenedHash,GEOS_closefile, set_neighbor_offset - use LDAS_ForceMod, only: im_world_cs - use LDAS_DriverTypes, only: met_force_type, assignment(=) - use LDAS_ConvertMod, only: esmf2ldas - use LDAS_InterpMod, only: LDAS_TInterpForcing=>metforcing_tinterp - !use force_and_cat_progn_pert_types, only: N_FORCE_PERT_MAX - - use StieglitzSnow, only : NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & - NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & - NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & - NUM_SUDP, NUM_SUSV, NUM_SUWT, NUM_SUSD, & - NUM_SSDP, NUM_SSSV, NUM_SSWT, NUM_SSSD - implicit none - - private - - real, parameter :: daylen = 86400. - - ! !PUBLIC MEMBER FUNCTIONS: - - public :: SetServices - - ! !DESCRIPTION: This GridComp read MetForcing files - - !EOP - include 'mpif.h' - - ! MetForcing type - type T_MET_FORCING - integer :: hinterp ! 1 => Bilin interp - ! Start/End points of forcing internal - type(ESMF_Time) :: TimePrv - type(ESMF_Time) :: TimeNxt - ! Length of forcing internal - type(ESMF_TimeInterval) :: ntrvl - ! File path/tag - character(len=ESMF_MAXSTR) :: Path - character(len=ESMF_MAXSTR) :: Tag - ! Average zenith angle over daylight path of forcing interval - real, allocatable :: zenav(:) - ! Met forcing data - type(met_force_type), pointer, contiguous :: DataPrv(:) - type(met_force_type), pointer, contiguous :: DataNxt(:) - end type T_MET_FORCING - - ! Internal state and its wrapper - type T_METFORCE_STATE - private - type(T_MET_FORCING) :: mf - end type T_METFORCE_STATE - type METFORCE_WRAP - type(T_METFORCE_STATE), pointer :: ptr=>null() - end type METFORCE_WRAP - -contains - - !BOP - - ! !IROTUINE: SetServices -- Set ESMF services for this component - - ! !INTERFACE: - - subroutine SetServices(gc, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, optional :: rc ! return code - - ! !DESCRIPTION: - ! da..da...da.... - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! Local variables - type(T_METFORCE_STATE), pointer :: internal - type(METFORCE_WRAP) :: wrap - - ! Begin... - - ! Get my name and setup traceback handle - Iam = 'SetServices' - call ESMF_GridCompGet(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::" // Iam - - ! Register services for this component - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_INITIALIZE, & - Initialize, & - rc=status & - ) - VERIFY_(status) - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_RUN, & - Run, & - rc=status & - ) - VERIFY_(status) - call MAPL_GridCompSetEntryPoint( & - gc, & - ESMF_METHOD_FINALIZE, & - Finalize, & - rc=status & - ) - VERIFY_(status) - - ! Allocate an instance of the internal state and put it in wrapper - ! Then, save the pointer to the wrapped internal state in the GridComp - allocate(internal, stat=status) - VERIFY_(status) - wrap%ptr => internal - call ESMF_UserCompSetInternalState(gc, 'METFORCE_state', wrap, status) - VERIFY_(status) - - ! Set the state variable specs - !BOS - - ! !IMPORT STATE: - - - - ! !EXPORT STATE: - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Tair", & - LONG_NAME = "air_temperature_at_RefH", & - UNITS = "K", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Qair", & - LONG_NAME = "specific_humidity_at_RefH", & - UNITS = "kg kg-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Psurf", & - LONG_NAME = "surface_pressure", & - UNITS = "Pa", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Rainf_C", & - LONG_NAME = "convective_rainfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Rainf", & - LONG_NAME = "total_liquid_water_precipitation", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Snowf", & - LONG_NAME = "total_snowfall", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "RainfSnowf", & - LONG_NAME = "rainf+snowf", & - UNITS = "kg m-2 s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "LWdown", & - LONG_NAME = "surface_absorbed_longwave_flux", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "SWdown", & - LONG_NAME = "downward_shortwave_radiation", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PARdrct", & - LONG_NAME = "photosynth_active_radiation_direct", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "PARdffs", & - LONG_NAME = "photosynth_active_radiation_diffuse", & - UNITS = "W m-2", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "Wind", & - LONG_NAME = "wind_speed_at_RefH", & - UNITS = "m s-1", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) - - call MAPL_AddExportSpec( & - gc, & - SHORT_NAME = "RefH", & - LONG_NAME = "reference_height_for_Tair_Qair_Wind", & - UNITS = "m", & - DIMS = MAPL_DimsTileOnly, & - VLOCATION = MAPL_VlocationNone, & - rc = status & - ) - VERIFY_(status) -! -! extra export for GOWIN -! - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dust_dry_depos_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'DUDP', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_DUDP/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dust_wet_depos_conv_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'DUSV', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_DUSV/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dust_wet_depos_ls_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'DUWT', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_DUWT/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dust_gravity_sett_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'DUSD', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_DUSD/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'black_carbon_dry_depos_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'BCDP', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_BCDP/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'black_carbon_wet_depos_conv_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'BCSV', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_BCSV/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'black_carbon_wet_depos_ls_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'BCWT', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_BCWT/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'black_carbon_gravity_sett_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'BCSD', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_BCSD/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'organic_carbon_dry_depos_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'OCDP', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_OCDP/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'organic_carbon_wet_depos_conv_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'OCSV', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_OCSV/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'organic_carbon_wet_depos_ls_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'OCWT', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_OCWT/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'organic_carbon_gravity_sett_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'OCSD', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_OCSD/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sulfate_dry_depos_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SUDP', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SUDP/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sulfate_wet_depos_conv_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SUSV', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SUSV/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sulfate_wet_depos_ls_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SUWT', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SUWT/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sulfate_gravity_sett_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SUSD', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SUSD/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sea_salt_dry_depos_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SSDP', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SSDP/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sea_salt_wet_depos_conv_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SSSV', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SSSV/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sea_salt_wet_depos_ls_scav_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SSWT', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SSWT/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'sea_salt_gravity_sett_all_bins', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'SSSD', & - DIMS = MAPL_DimsTileOnly, & - UNGRIDDED_DIMS = (/NUM_SSSD/), & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - !EOS - - ! Set profiling timers - call MAPL_TimerAdd(gc, name="Initialize", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Run_GetForcing", rc=status) - VERIFY_(status) - call MAPL_TimerAdd(gc, name="Run_RepairForcing", rc=status) - VERIFY_(status) - - ! Call SetServices for children - call MAPL_GenericSetServices(gc, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - - !BOP - - ! !IROTUINE: Initialize -- initialize method for LDAS GC - - ! !INTERFACE: - - subroutine Initialize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! da...da..da. - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_Time) :: CurrentTime - type(ESMF_Alarm) :: MetForcingAlarm - type(ESMF_TimeInterval) :: Forcing_DT - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - - ! LDAS variables - type(date_time_type) :: force_time_prv - - ! MetForcing variable - type(T_MET_FORCING) :: mf - - ! Internal private state variables - type(T_METFORCE_STATE), pointer :: internal=>null() - type(METFORCE_WRAP) :: wrap - type(TILECOORD_WRAP) :: tcwrap - type(tile_coord_type), pointer :: tile_coord(:)=>null() - - ! Misc variables - integer :: land_nt_local, k, NUM_ENSEMBLE - integer :: ForceDtStep - type(met_force_type) :: mf_nodata - logical :: MERRA_file_specs, ensemble_forcing - logical :: backward_looking_fluxes - - integer :: AEROSOL_DEPOSITION - type(MAPL_LocStream) :: locstream - character(len=ESMF_MAXSTR) :: grid_type, ENS_FORCING_STR, ens_forcing_path - character(len=ESMF_MAXSTR) :: gridname - character(3) :: ensid_string3 - type(ESMF_Grid) :: agrid - integer :: dims(ESMF_MAXDIM) - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Initialize" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Initialize") - - ! Get current time - call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) - VERIFY_(status) - - ! Get component's internal private state - call ESMF_UserCompGetInternalState(gc, 'METFORCE_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tile_coord => tcwrap%ptr%tile_coord - - ! Number of land tiles (on local PE) - call MAPL_Get(MAPL, LocStream=locstream) - VERIFY_(status) - call MAPL_LocStreamGet( & - locstream, & - NT_LOCAL=land_nt_local, & - rc=status & - ) - VERIFY_(status) - - call MAPL_GetResource ( MAPL, AEROSOL_DEPOSITION, Label="AEROSOL_DEPOSITION:", & - DEFAULT=0, RC=STATUS) - - call MAPL_GetResource(MAPL, grid_type,Label="GEOSldas.GRID_TYPE:",RC=STATUS) - VERIFY_(STATUS) - - if(trim(grid_type) == "Cubed-Sphere" ) then - call ESMF_GridCompGet(gc, grid=agrid, rc=status) - VERIFY_(status) - call MAPL_GridGet(agrid, globalCellCountPerDim=dims, rc=status) - VERIFY_(STATUS) - im_world_cs = dims(1) - endif - - call MAPL_GetResource(MAPL, gridname,Label="GEOSldas.GRIDNAME:",RC=STATUS) - VERIFY_(STATUS) - if( index(trim(gridname), 'EASE') /=0) call set_neighbor_offset(0.0001) - - ! Get MetForcing values and put them in Ldas' internal state - ! Get resources needed to call LDAS_ForceMod::get_forcing() - ! - hinterp=1 => Bilinear Interpolation - - call MAPL_GetResource( & - MAPL, & - mf%hinterp, & - 'MET_HINTERP:', & - default=1, & - rc=status & - ) - VERIFY_(status) - ! -previous/next-times- - mf%TimePrv = CurrentTime - mf%TimeNxt = CurrentTime - ! -time-interval- - call MAPL_GetResource( & - MAPL, & - ForceDtStep, & - 'FORCE_DTSTEP:', & - default=3600, & - rc=status & - ) - VERIFY_(status) - call ESMF_TimeIntervalSet(Forcing_DT, s=ForceDtStep, rc=status) - VERIFY_(status) - mf%ntrvl = Forcing_DT - ! -path- - call MAPL_GetResource(MAPL, mf%Path, 'MET_PATH:', rc=status) - VERIFY_(status) - ! -tag- - call MAPL_GetResource(MAPL, mf%Tag, 'MET_TAG:', rc=status) - VERIFY_(status) - ! -allocate-memory-for-metforcing-data- - mf_nodata = nodata_generic - allocate(mf%DataPrv(land_nt_local), source=mf_nodata, stat=status) - VERIFY_(status) - allocate(mf%DataNxt(land_nt_local), source=mf_nodata, stat=status) - VERIFY_(status) - ! -allocate-memory-for-avg-zenith-angle - allocate(mf%zenav(land_nt_local), source=nodata_generic, stat=status) - VERIFY_(status) - call MAPL_GetResource ( MAPL, ENS_FORCING_STR, Label="ENSEMBLE_FORCING:", DEFAULT="NO", RC=STATUS) - VERIFY_(STATUS) - ENS_FORCING_STR = ESMF_UtilStringUpperCase(ENS_FORCING_STR, rc=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - ensemble_forcing = (trim(ENS_FORCING_STR) == 'YES') - if (ensemble_forcing .and. NUM_ENSEMBLE > 1) then - ! note: comp_name ends in "_eXXXX"; for GEOS ADAS forcing, extract hard-coded 3-digit ens id string - k = len(trim(comp_name)) - ensid_string3 = comp_name(k-2:k) - call ESMF_CFIOStrTemplate(ens_forcing_path, trim(adjustl(mf%Path)),'GRADS', xid = ensid_string3, stat=status) - mf%Path = ens_forcing_path - endif - ! Put MetForcing in Ldas' pvt internal state - internal%mf = mf - ! Create alarm for MetForcing - ! -create-nonsticky-alarm- - MetForcingAlarm = ESMF_AlarmCreate( & - clock, & - name='MetForcing', & - ringTime=CurrentTime, & - ringInterval=Forcing_DT, & - ringTimeStepCount=1, & - sticky=.false., & - rc=status & - ) - VERIFY_(status) - - ! Get "prv" forcing - ! -convert-mf%TimePrv-to-LDAS-datetime- - call esmf2ldas(mf%TimePrv, force_time_prv, rc=status) - VERIFY_(status) - - ! -now-get-the-initial-forcings- - call LDAS_GetForcing( & - force_time_prv, & - ForceDtStep, & - internal%mf%Path, & - internal%mf%Tag, & - land_nt_local, & - tile_coord, & - internal%mf%hinterp, & - AEROSOL_DEPOSITION, & - MERRA_file_specs, & - backward_looking_fluxes, & - internal%mf%DataNxt, & - .true. & ! init - ) - VERIFY_(status) - - if (backward_looking_fluxes) & - call LDAS_move_new_force_to_old( & - MERRA_file_specs, AEROSOL_DEPOSITION, & - internal%mf%DataNxt, internal%mf%DataPrv ) - - ! Turn timer off - call MAPL_TimerOff(MAPL, "Initialize") - - ! Call Initialize for every child - call MAPL_GenericInitialize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! End - call MAPL_TimerOff(MAPL, "TOTAL") - RETURN_(ESMF_SUCCESS) - - end subroutine Initialize - - - !BOP - - ! !IROTUINE: Run_GetForcing - a wrapper around Rolf's get_forcing() - - ! !INTERFACE: - - subroutine Run(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! Reads met_forcing files. - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! ESMF variables - type(ESMF_VM) :: vm - type(ESMF_Time) :: ModelTimeCur, tmpTime, ModelTimeNxt - type(ESMF_Alarm) :: MetForcingAlarm - type(ESMF_TimeInterval) :: ModelTimeStep - - ! MAPL variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - type(MAPL_LocStream) :: locstream - type(MAPL_SunOrbit) :: orbit - - ! LDAS variables - type(date_time_type) :: force_time_prv, force_time_nxt, model_time_nxt - - ! Private internal state variables - type(T_METFORCE_STATE), pointer :: internal=>null() - type(METFORCE_WRAP) :: wrap - type(TILECOORD_WRAP) :: tcwrap ! LDAS' tile_coord variable - type(tile_coord_type), pointer :: tile_coord(:) - - ! Misc variables - integer :: land_nt_local ! number of LAND tiles in local PE - integer :: comm - logical :: IAmRoot - integer :: fdtstep - integer :: YEAR, DAY_OF_YEAR, SEC_OF_DAY,n - real, pointer :: LandTileLats(:) - real, pointer :: LandTileLons(:) - real, allocatable :: zth(:), slr(:), zth_tmp(:) - type(met_force_type), allocatable :: mfDataNtp(:) - type(met_force_type), pointer, contiguous :: DataTmp(:)=>null() - real, allocatable :: tmpreal(:) - type(met_force_type) :: mf_nodata - - logical :: MERRA_file_specs - logical :: backward_looking_fluxes - integer :: AEROSOL_DEPOSITION - ! Export pointers - real, pointer :: Tair(:)=>null() - real, pointer :: Qair(:)=>null() - real, pointer :: Psurf(:)=>null() - real, pointer :: Rainf_C(:)=>null() - real, pointer :: Rainf(:)=>null() - real, pointer :: Snowf(:)=>null() - real, pointer :: RainfSnowf(:)=>null() - real, pointer :: LWdown(:)=>null() - real, pointer :: SWdown(:)=>null() - real, pointer :: PARdrct(:)=>null() - real, pointer :: PARdffs(:)=>null() - real, pointer :: Wind(:)=>null() - real, pointer :: RefH(:)=>null() - - real,pointer :: DUDP(:,:)=>null() - real,pointer :: DUSV(:,:)=>null() - real,pointer :: DUWT(:,:)=>null() - real,pointer :: DUSD(:,:)=>null() - real,pointer :: BCDP(:,:)=>null() - real,pointer :: BCSV(:,:)=>null() - real,pointer :: BCWT(:,:)=>null() - real,pointer :: BCSD(:,:)=>null() - real,pointer :: OCDP(:,:)=>null() - real,pointer :: OCSV(:,:)=>null() - real,pointer :: OCWT(:,:)=>null() - real,pointer :: OCSD(:,:)=>null() - real,pointer :: SUDP(:,:)=>null() - real,pointer :: SUSV(:,:)=>null() - real,pointer :: SUWT(:,:)=>null() - real,pointer :: SUSD(:,:)=>null() - real,pointer :: SSDP(:,:)=>null() - real,pointer :: SSSV(:,:)=>null() - real,pointer :: SSWT(:,:)=>null() - real,pointer :: SSSD(:,:)=>null() - ! Begin... - - ! Get my name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Run_GetForcing" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Turn timers on - call MAPL_TimerOn(MAPL, "TOTAL") - call MAPL_TimerOn(MAPL, "Run_GetForcing") - - ! MPI stuff - communicator, root etc. - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - call ESMF_VmGet(vm, mpicommunicator=comm, rc=status) - VERIFY_(status) - IAmRoot = MAPL_Am_I_Root(vm) - - ! Get current time - call ESMF_ClockGet(clock, currTime=ModelTimeCur, rc=status) - VERIFY_(status) - - ! Get component's internal private state - call ESMF_UserCompGetInternalState(gc, 'METFORCE_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - call MAPL_GetResource ( MAPL, AEROSOL_DEPOSITION, Label="AEROSOL_DEPOSITION:", & - DEFAULT=1, RC=STATUS) - - ! Get number of tiles, tile lats/lons from LocStream - call MAPL_Get(MAPL, LocStream=locstream) - VERIFY_(status) - call MAPL_LocStreamGet( & - locstream, & - NT_LOCAL=land_nt_local, & - TILELATS=LandTileLats, & - TILELONS=LandTileLons, & - rc=status & - ) - VERIFY_(status) - - ! Sun's orbit - call MAPL_Get(MAPL, orbit=orbit) - - ! Allocate memory for zenith angle - allocate(zth(land_nt_local), source=nodata_generic, stat=status) - VERIFY_(status) - allocate(slr(land_nt_local), source=nodata_generic, stat=status) - VERIFY_(status) - allocate(zth_tmp(land_nt_local), source=nodata_generic, stat=status) - VERIFY_(status) - - ! Convert forcing time interval to seconds - call ESMF_TimeIntervalGet(internal%mf%ntrvl, s=fdtstep, rc=status) - - ! MetForcing alarm - call ESMF_ClockGetAlarm(clock, 'MetForcing', MetForcingAlarm, rc=status) - VERIFY_(status) - - ! Get component's internal tile_coord variable - call ESMF_UserCompGetInternalState(gc, 'TILE_COORD', tcwrap, status) - VERIFY_(status) - tile_coord => tcwrap%ptr%tile_coord - - ! Time stamp of next model step - ! -get-model-time-step- - call ESMF_ClockGet(clock, timeStep=ModelTimeStep) - VERIFY_(status) - ! -time-stamp- - ModelTimeNxt = ModelTimeCur + ModelTimeStep - - ! Get forcing data if MetForcing alarm is ringing - if (ESMF_AlarmIsRinging(MetForcingAlarm)) then - - ! -update-forcing-times- - tmpTime = internal%mf%TimeNxt - internal%mf%TimePrv = tmpTime - internal%mf%TimeNxt = tmpTime + internal%mf%ntrvl - - ! -update-forcing-data- - ! -swap-DataPrv-and-DataNxt- - DataTmp => internal%mf%DataPrv - internal%mf%DataPrv => internal%mf%DataNxt - internal%mf%DataNxt => DataTmp - nullify(DataTmp) - - ! -convert-mf%TimeNxt-to-LDAS-datetime- - call esmf2ldas(internal%mf%TimeNxt, force_time_nxt, rc=status) - VERIFY_(status) - - call LDAS_GetForcing( & - force_time_nxt, & - fdtstep, & - internal%mf%Path, & - internal%mf%Tag, & - land_nt_local, & - tile_coord, & - internal%mf%hinterp, & - AEROSOL_DEPOSITION, & - MERRA_file_specs, & - backward_looking_fluxes, & - internal%mf%DataNxt, & - .false. & ! init - ) - VERIFY_(status) - - if (backward_looking_fluxes) & - call LDAS_move_new_force_to_old( & - MERRA_file_specs, AEROSOL_DEPOSITION, & - internal%mf%DataNxt, internal%mf%DataPrv ) - - ! -compute-average-zenith-angle-over-daylight-part-of-forcing-interval- - call MAPL_SunGetInsolation( & - LandTileLons, & - LandTileLats, & - orbit, & - zth_tmp, & - slr, & - currTime=internal%mf%TimePrv, & - INTV=internal%mf%ntrvl, & - ZTHB=internal%mf%zenav, & - STEPSIZE=150.0, & - rc=status & - ) - VERIFY_(STATUS) - - ! call ESMF_TimeGet(internal%mf%TimePrv, YY=YEAR, S=SEC_OF_DAY, & - ! dayOfYear=DAY_OF_YEAR, RC=STATUS) - ! VERIFY_(STATUS) - - ! call zenith(DAY_OF_YEAR,SEC_OF_DAY,fdtstep,ModelTimeStep,land_nt_local,tile_coord%com_lon, & - ! tile_coord%com_lat,internal%mf%zenav) - - - ! -checks-on-computed-zenith-angles- - if (any(internal%mf%zenav<0)) then - RETURN_(ESMF_FAILURE) - end if - - end if - - !if(root_logit) write(logunit,*) trim(Iam)//'::zenav max/min: ', maxval(internal%mf%zenav), minval(internal%mf%zenav) - !if(logit) write(logunit,*) trim(Iam)//'::zenav max/min: ', maxval(internal%mf%zenav), minval(internal%mf%zenav) - - ! Compute zenith angle at the next time step - call MAPL_SunGetInsolation( & - LandTileLons, & - LandTileLats, & - orbit, & - zth_tmp, & - slr, & - INTV=ModelTimeStep, & - ZTHB=zth, & - currTime=ModelTimeCur, & - STEPSIZE=150.0, & - rc=status & - ) - VERIFY_(status) - - !call ESMF_TimeGet(ModelTimeNxt, YY=YEAR, S=SEC_OF_DAY, & - ! dayOfYear=DAY_OF_YEAR, RC=STATUS) - !VERIFY_(STATUS) - !do n=1, land_nt_local - ! call solar(tile_coord(n)%com_lon,tile_coord(n)%com_lat, DAY_OF_YEAR,SEC_OF_DAY,zth(n),slr(n)) - !enddo - - if (any(zth<0.)) then - RETURN_(ESMF_FAILURE) - end if - - !if(root_logit) write(logunit,*) trim(Iam)//'::zth max/min: ', maxval(zth), minval(zth) - - ! -convert-mf%TimePrv-to-LDAS-datetime- - call esmf2ldas(internal%mf%TimePrv, force_time_prv, rc=status) - VERIFY_(status) - - ! -convert-ModelTimeNxt-to-LDAS-datetime- - call esmf2ldas(ModelTimeNxt, model_time_nxt, rc=status) - - !if(root_logit) write(logunit,*) trim(Iam)//'::force_time_prv: ', date_time_print(force_time_prv) - - !if(root_logit) write(logunit,*) trim(Iam)//'::model_time_nxt: ', date_time_print(model_time_nxt) - - ! Allocate memory for interpolated MetForcing data - mf_nodata = nodata_generic - allocate(mfDataNtp(land_nt_local), source=mf_nodata, stat=status) - VERIFY_(status) - - ! Interpolate MetForcing data to the end of model integration time step - call LDAS_TInterpForcing( & - tile_coord%com_lon, & - tile_coord%com_lat, & - zth, & - internal%mf%zenav, & - force_time_prv, & - model_time_nxt, & - fdtstep, & - internal%mf%DataPrv, & - internal%mf%DataNxt, & - mfDataNtp, & - AEROSOL_DEPOSITION, & - rc=status & - ) - VERIFY_(status) - !if(root_logit) write(logunit,*) trim(Iam)//'::mf_ntp%tair max/min: ', maxval(mfDataNtp%Tair), minval(mfDataNtp%Tair) - - ! Pointers to exports (allocate memory) - call MAPL_GetPointer(export, Tair, 'Tair', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Qair, 'Qair', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Psurf, 'Psurf', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Rainf_C, 'Rainf_C', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Rainf, 'Rainf', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Snowf, 'Snowf', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RainfSnowf, 'RainfSnowf', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, LWdown, 'LWdown', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SWdown, 'SWdown', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PARdrct, 'PARdrct', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, PARdffs, 'PARdffs', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, Wind, 'Wind', alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, RefH, 'RefH', alloc=.true., rc=status) - VERIFY_(status) - - if (AEROSOL_DEPOSITION /=0 ) then - call MAPL_GetPointer(export, DUDP, 'DUDP' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DUSV, 'DUSV' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DUWT, 'DUWT' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, DUSD, 'DUSD' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, BCDP, 'BCDP' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, BCSV, 'BCSV' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, BCWT, 'BCWT' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, BCSD, 'BCSD' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, OCDP, 'OCDP' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, OCSV, 'OCSV' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, OCWT, 'OCWT' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, OCSD, 'OCSD' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SUDP, 'SUDP' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SUSV, 'SUSV' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SUWT, 'SUWT' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SUSD, 'SUSD' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SSDP, 'SSDP' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SSSV, 'SSSV' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SSWT, 'SSWT' , alloc=.true., rc=status) - VERIFY_(status) - call MAPL_GetPointer(export, SSSD, 'SSSD' , alloc=.true., rc=status) - VERIFY_(status) - endif ! AEROSOL_DEPOSITION /=0 - - - ! Set exports - Tair = mfDataNtp%Tair - Qair = mfDataNtp%Qair - Psurf = mfDataNtp%Psurf - Rainf_C = mfDataNtp%Rainf_C - Rainf = mfDataNtp%Rainf - Snowf = mfDataNtp%Snowf - ! *daylen convert [kg/m2/s] into [kg/m2/day] - !RainfSnowf= (Rainf+Snowf)*daylen - RainfSnowf= Rainf+Snowf - LWdown = mfDataNtp%LWdown - SWdown = mfDataNtp%SWdown - PARdrct = mfDataNtp%PARdrct - PARdffs = mfDataNtp%PARdffs - Wind = mfDataNtp%Wind - RefH = mfDataNtp%RefH - - - if(AEROSOL_DEPOSITION /=0) then - DUDP(:, 1) = mfDataNtp%DUDP001 - DUDP(:, 2) = mfDataNtp%DUDP002 - DUDP(:, 3) = mfDataNtp%DUDP003 - DUDP(:, 4) = mfDataNtp%DUDP004 - DUDP(:, 5) = mfDataNtp%DUDP005 - DUSV(:, 1) = mfDataNtp%DUSV001 - DUSV(:, 2) = mfDataNtp%DUSV002 - DUSV(:, 3) = mfDataNtp%DUSV003 - DUSV(:, 4) = mfDataNtp%DUSV004 - DUSV(:, 5) = mfDataNtp%DUSV005 - DUWT(:, 1) = mfDataNtp%DUWT001 - DUWT(:, 2) = mfDataNtp%DUWT002 - DUWT(:, 3) = mfDataNtp%DUWT003 - DUWT(:, 4) = mfDataNtp%DUWT004 - DUWT(:, 5) = mfDataNtp%DUWT005 - DUSD(:, 1) = mfDataNtp%DUSD001 - DUSD(:, 2) = mfDataNtp%DUSD002 - DUSD(:, 3) = mfDataNtp%DUSD003 - DUSD(:, 4) = mfDataNtp%DUSD004 - DUSD(:, 5) = mfDataNtp%DUSD005 - BCDP(:, 1) = mfDataNtp%BCDP001 - BCDP(:, 2) = mfDataNtp%BCDP002 - BCSV(:, 1) = mfDataNtp%BCSV001 - BCSV(:, 2) = mfDataNtp%BCSV002 - BCWT(:, 1) = mfDataNtp%BCWT001 - BCWT(:, 2) = mfDataNtp%BCWT002 - BCSD(:, 1) = mfDataNtp%BCSD001 - BCSD(:, 2) = mfDataNtp%BCSD002 - OCDP(:, 1) = mfDataNtp%OCDP001 - OCDP(:, 2) = mfDataNtp%OCDP002 - OCSV(:, 1) = mfDataNtp%OCSV001 - OCSV(:, 2) = mfDataNtp%OCSV002 - OCWT(:, 1) = mfDataNtp%OCWT001 - OCWT(:, 2) = mfDataNtp%OCWT002 - OCSD(:, 1) = mfDataNtp%OCSD001 - OCSD(:, 2) = mfDataNtp%OCSD002 - SUDP(:, 1) = mfDataNtp%SUDP003 - SUSV(:, 1) = mfDataNtp%SUSV003 - SUWT(:, 1) = mfDataNtp%SUWT003 - SUSD(:, 1) = mfDataNtp%SUSD003 - SSDP(:, 1) = mfDataNtp%SSDP001 - SSDP(:, 2) = mfDataNtp%SSDP002 - SSDP(:, 3) = mfDataNtp%SSDP003 - SSDP(:, 4) = mfDataNtp%SSDP004 - SSDP(:, 5) = mfDataNtp%SSDP005 - SSSV(:, 1) = mfDataNtp%SSSV001 - SSSV(:, 2) = mfDataNtp%SSSV002 - SSSV(:, 3) = mfDataNtp%SSSV003 - SSSV(:, 4) = mfDataNtp%SSSV004 - SSSV(:, 5) = mfDataNtp%SSSV005 - SSWT(:, 1) = mfDataNtp%SSWT001 - SSWT(:, 2) = mfDataNtp%SSWT002 - SSWT(:, 3) = mfDataNtp%SSWT003 - SSWT(:, 4) = mfDataNtp%SSWT004 - SSWT(:, 5) = mfDataNtp%SSWT005 - SSSD(:, 1) = mfDataNtp%SSSD001 - SSSD(:, 2) = mfDataNtp%SSSD002 - SSSD(:, 3) = mfDataNtp%SSSD003 - SSSD(:, 4) = mfDataNtp%SSSD004 - SSSD(:, 5) = mfDataNtp%SSSD005 - endif ! AEROSOL_DEPOSITION /=0 - ! Clean up - if (allocated(mfDataNtp)) then - deallocate(mfDataNtp, stat=status) - VERIFY_(status) - end if - if (allocated(zth)) then - deallocate(zth, stat=status) - VERIFY_(status) - end if - if (allocated(slr)) then - deallocate(slr, stat=status) - VERIFY_(status) - end if - - ! Turn timers off - call MAPL_TimerOff(MAPL, "Run_GetForcing") - call MAPL_TimerOff(MAPL, "TOTAL") - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Run - - - !BOP - - ! !IROTUINE: Finalize -- Finalize method for LDAS GridComp - - ! !INTERFACE: - - subroutine Finalize(gc, import, export, clock, rc) - - ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! Gridded component - type(ESMF_State), intent(inout) :: import ! Import state - type(ESMF_State), intent(inout) :: export ! Export state - type(ESMF_Clock), intent(inout) :: clock ! The clock - integer, optional, intent( out) :: rc ! Error code - - ! !DESCRIPTION: - ! This Finalize routine cleans up the Ldas GridComp - - !EOP - - ! ErrLog variables - integer :: status - character(len=ESMF_MAXSTR) :: Iam - character(len=ESMF_MAXSTR) :: comp_name - - ! Local variables - type(MAPL_MetaComp), pointer :: MAPL=>null() ! MAPL obj - type(T_METFORCE_STATE), pointer :: internal - type(METFORCE_WRAP) :: wrap - type(ESMF_Alarm) :: MetForcing - !external :: GEOS_closefile - ! Begin... - - ! Get component's name and setup traceback handle - call ESMF_GridCompget(gc, name=comp_name, rc=status) - VERIFY_(status) - Iam = trim(comp_name) // "::Initialize" - - ! Get MAPL obj - call MAPL_GetObjectFromGC(gc, MAPL, rc=status) - VERIFY_(status) - - ! Get component's internal private state - call ESMF_UserCompGetInternalState(gc, 'METFORCE_state', wrap, status) - VERIFY_(status) - internal => wrap%ptr - - call FileOpenedHash%free(GEOS_closefile,.true.) - - ! Clean-up private internal state - if (allocated(internal%mf%zenav)) then - deallocate(internal%mf%zenav) - end if - if (associated(internal%mf%DataPrv)) then - deallocate(internal%mf%DataPrv) - end if - if (associated(internal%mf%DataNxt)) then - deallocate(internal%mf%DataNxt) - end if - - ! Destroy MetForcingAlarm - ! -get-the-alarm - call ESMF_ClockGetAlarm(clock, 'MetForcing', MetForcing, rc=status) - VERIFY_(status) - ! -destroy-it- - call ESMF_AlarmDestroy(MetForcing, rc=status) - VERIFY_(status) - - ! Call Finalize for every child - call MAPL_GenericFinalize(gc, import, export, clock, rc=status) - VERIFY_(status) - - ! End - RETURN_(ESMF_SUCCESS) - - end subroutine Finalize - -end module GEOS_MetforceGridCompMod diff --git a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Forcing.F90 b/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Forcing.F90 deleted file mode 100755 index b87e6734..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Forcing.F90 +++ /dev/null @@ -1,6427 +0,0 @@ -#include "MAPL_Generic.h" - -module LDAS_ForceMod - - ! collection of *forcing* subroutines for enkf_driver - ! (originally these routines were in clsm_ensdrv_drv_routines.F90) - - ! reichle, 13 Aug 2008 - use, intrinsic :: iso_c_binding - use ESMF - use MAPL_Mod - use MAPL_ShmemMod - - use LDAS_ensdrv_Globals, ONLY: & - logunit, & - logit, & - root_logit, & - nodata_generic, & - nodata_tol_generic, & - nodata_tolfrac_generic - - use MAPL_ConstantsMod, ONLY: & - stefan_boltzmann => MAPL_STFBOL, & - Tzero => MAPL_TICE - - use MAPL_SatVaporMod, ONLY: & - MAPL_EQsat - - use LDAS_DriverTypes, ONLY: & - met_force_type - - use LDAS_TileCoordType, ONLY: & - tile_coord_type - - use LDAS_DateTimeMod, ONLY: & - date_time_type, & - augment_date_time, & - datetime_lt_refdatetime, & - datetime_le_refdatetime, & - is_leap_year, & - get_dofyr_pentad - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use RepairForcingMod, ONLY: & - repair_forcing - use LDAS_HashTable, only: & - Hash_Table - implicit none - - include 'netcdf.inc' - - ! everything is private by default unless made public - - private - - public :: get_forcing - public :: LDAS_move_new_force_to_old - public :: GEOS_closefile - - type(Hash_Table), public :: FileOpenedHash - - real, parameter :: DEFAULT_REFH = 10. ! m - - ! Jun 2021: Revised length of unformatted string from 10 to 100 (must be >= 12 for integer). - character(100), private :: tmpstring100 - - real, contiguous, pointer :: ptrShForce(:,:)=>null() - - type local_grid - integer :: N_lon = 0 - integer :: N_lat = 0 - integer :: N_cat = 0 - integer, allocatable :: i1(:),i2(:),j1(:),j2(:) - real, allocatable :: x1(:),x2(:),y1(:),y2(:) - end type local_grid - - type(local_grid), target :: local_info - - ! for cubed sphere forcing checking, initialized by GEOS_MetforceGridComp - ! - integer, public :: im_world_cs = 0 - - ! For (mostly) regularly spaced tiles (such as in the EASE tile spaces), - ! add a small offset to each tile's center-of-mass lat/lon when looking - ! for the nearest neighbor. This is done to avoid the unpredictable assignment - ! of tiles to forcing grid cells, which would otherwise happen along certain - ! lat/lon values (that is, make it possible for post-processing scripts in - ! other languages to exactly reproduce the nearest-neighbor mapping that is - ! done here). - ! Default offset is 0.0. Offset is changed to 0.0001 by GEOS_MetforceGridComp - ! during initialization if tile space is based on EASE grid. - ! - public :: set_neighbor_offset - real, private :: neighbor_offset = 0.0 - -contains - - ! ******************************************************************** - - subroutine get_forcing( date_time, force_dtstep, met_path, met_tag, & - N_catd, tile_coord, MET_HINTERP, AEROSOL_DEPOSITION, & - MERRA_file_specs, bkwd_looking_fluxes, met_force_obs_tile_new, & - init ) - - ! Read and check meteorological forcing data for the domain. - ! - ! forcing readers must provide ALL of the surface meteorological fields in the - ! met_force_type structure EXCEPT: - ! - PARdrct, PARdffs : if not available, will be backfilled as fraction of SWdown - ! - aerosol forcing : currently defunct - ! - ! time convention: - ! - forcing states (such as Tair) are snapshots at date_time - ! - forcing fluxes (such as SWdn) are time avg over *subsequent* (*forward-looking*) - ! forcing interval (date_time:date_time+force_dtstep) - ! - ! The above time convention was inherited from older versions of the - ! off-line driver and creates problems with "operational" forcing - ! data from GEOS. For "operational" integrations, the forward-looking - ! forcing fluxes are not available for "met_force_obs_tile_new". - ! - ! For datasets that provide fluxes over the forcing interval that *precedes* - ! date_time_new, the output parameter "bkwd_looking_fluxes" must be set to .true., - ! so that subroutine LDAS_move_new_force_to_old() can time-shift the fields - ! accordingly. - ! - ! When LDASsa is integrated within the coupled GEOS5 DAS, initial (time-avg) - ! "tavg1_2d_*_Nx" files are not available. Use optional "init" flag to - ! deal with this situation. - ! - ! reichle, 28 March 2006 - ! reichle, 13 March 2008 - added optional "init" flag - ! qliu+reichle, 12 Aug 2008 - new field RefH (reference height) in met_force_type - ! reichle, 25 Sep 2009 - removed unneeded inputs - ! reichle, 23 Feb 2016 - new and more efficient work-around to make GEOS-5 - ! forcing work with LDASsa time convention for forcing data - ! borescan, 01 Feb 2021 - added ERA5_LIS forcing - ! reichle, 12 Apr 2021 - removed obsolete optional input "alb_from_SWnet" - ! - replaced "GEOS_forcing" switch with "bkwd_looking_fluxes" - ! - added checks for supported options of MET_HINTERP and - ! AEROSOL_DEPOSITION - ! reichle, 22 Apr 2021 - clean up: - ! - calls to check_forcing_nodata() and repair_forcing() - ! - handling nodata-values in PARdrct, PARdffs - ! reichle, 23 Apr 2021 - clean up: - ! - removed SWnet from met_force_type - - implicit none - - ! intent in: - - type(date_time_type), intent(in) :: date_time - - integer, intent(in) :: force_dtstep - - character(*), intent(in) :: met_path - character(*), intent(in) :: met_tag - - integer, intent(in) :: N_catd, MET_HINTERP, AEROSOL_DEPOSITION - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - ! intent out: - - logical, intent(out) :: MERRA_file_specs - logical, intent(out) :: bkwd_looking_fluxes - - type(met_force_type), dimension(N_catd), intent(out) :: & - met_force_obs_tile_new - - ! optional: - - logical, intent(in), optional :: init - - ! ------------------- - - ! local variables - - real :: nodata_forcing, tol - - logical :: PAR_available ! indicate whether reader provides PARdrct, PARdffs - - logical :: supported_option_MET_HINTERP ! for consistency check of resource parameter settings - logical :: supported_option_AEROSOL_DEPOSITION ! for consistency check of resource parameter settings - - logical :: unlimited_Qair, unlimited_LWdown ! options for repair_forcing() - - type(date_time_type) :: date_time_tmp - - character(len=*), parameter :: Iam = 'get_forcing' - character(len=400) :: err_msg - - ! -------------------------------------------------------------- - ! - ! shift forcing date if so indicated by met_tag (for twin experiments, - ! see function shift_forcing_date for details) - reichle, 6 Apr 2007 - - date_time_tmp = shift_forcing_date(met_tag, date_time) - - ! set reference height to default value (if appropriate, will be overwriten - ! within specific subroutine) - - met_force_obs_tile_new%RefH = DEFAULT_REFH - - ! Note that "nodata_forcing" is set to the native nodata-value - ! in the individual get_*() subroutines and used to communicate with - ! check_forcing_nodata. AFTER the call to check_forcing_nodata all forcing - ! fields must NOT be nodata values. - ! - ! reichle+qliu, 8 Oct 2008 - ! reichle, 23 Feb 2009 -- same goes for ParDrct, ParDffs - ! reichle, 5 Mar 2009 -- deleted ParDrct, ParDffs after testing found no impact - ! reichle, 22 Jul 2010 -- fixed treatment of SWnet nodata values - ! reichle, 20 Dec 2011 -- reinstated PARdrct and PARdffs for MERRA-Land file specs - - ! --------------------------------------------------------------------------------- - ! - ! initialize - - MERRA_file_specs = .false. - - bkwd_looking_fluxes = .false. - - PAR_available = .false. ! default; so far, only GEOS forcing provides PAR - - unlimited_Qair = .false. ! default for call to repair_forcing - unlimited_LWdown = .false. ! default for call to repair_forcing - - ! every forcing data reader must support the default settings: - ! - ! MET_HINTER = 0 : nearest neighbor - ! AEROSOL_DEPOSITION = 0 : *no* aerosol deposition - ! - ! initialize "supported_option_*" to .true. for defaults and .false. otherwise; then - ! set to .true. in individual forcing readers for any non-default options that are - ! supported for the selected met_tag - - supported_option_MET_HINTERP = (MET_HINTERP == 0) - - supported_option_AEROSOL_DEPOSITION = (AEROSOL_DEPOSITION == 0) - - ! --------------------------------------------------------------------------------- - ! - ! get forcing in tile space - - if (index(met_tag, 'Berg_netcdf')/=0) then - - call get_Berg_netcdf( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'GLDAS_2x2_5_netcdf')/=0) then - - call get_GLDAS_2x2_5_netcdf(date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'Viviana_OK')/=0) then - - ! vmaggion & reichle, 17 July 2008 - ! - ! use 2x2.5 deg GLDAS for all forcing fields except precip - - call get_GLDAS_2x2_5_netcdf(date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - if (index(met_tag, 'Viviana_OK_nopert')/=0) then - - call get_Viviana_OK_precip(10, date_time_tmp, met_path, met_tag, & - N_catd, tile_coord, met_force_obs_tile_new) - - end if - - elseif (index(met_tag, 'GSWP2_1x1_netcdf')/=0) then - - call get_GSWP2_1x1_netcdf( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'RedArk_ASCII')/=0) then - - call get_RedArk_ASCII( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'RedArk_GOLD')/=0) then - - call get_RedArk_GOLD( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'RedArk_Princeton')/=0) then - - call get_RedArk_Princeton( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'Princeton_netcdf')/=0) then ! tyamada+reichle, 17 Jul 2007 - - call get_Princeton_netcdf( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'conus_0.5d_netcdf')/=0) then ! sarith+reichle, 17 Jul 2007 - - call get_conus_netcdf( date_time_tmp, met_path, N_catd, tile_coord, & - met_force_obs_tile_new, nodata_forcing) - - elseif (index(met_tag, 'ERA5_LIS')/=0) then - - call get_ERA5_LIS( date_time_tmp, met_path, N_catd, tile_coord, & - MET_HINTERP, & - supported_option_MET_HINTERP, & - met_force_obs_tile_new, nodata_forcing) - - ! Subroutine get_ERA5_LIS() provided backward-looking fluxes. - ! The time convention stated above is restored through a later call to subroutine - ! LDAS_move_new_force_to_old(). - - bkwd_looking_fluxes = .true. - - ! model-based dataset; call repair_forcing() below without certain limitations - - unlimited_Qair = .true. - unlimited_LWdown = .true. - - elseif (index(met_tag(1:7), 'GEOSs2s')/=0) then - - call get_GEOSs2s( date_time_tmp, met_path, met_tag, N_catd, tile_coord, & - MET_HINTERP, met_force_obs_tile_new, nodata_forcing, PAR_available) - - else ! assume forcing from GEOS5 GCM ("DAS" or "MERRA") output - - if(root_logit) write (logunit,*) 'get_forcing(): assuming GEOS-5 forcing data set' - - call get_GEOS( date_time_tmp, force_dtstep, met_path, met_tag, & - N_catd, tile_coord, MET_HINTERP, AEROSOL_DEPOSITION, & - supported_option_MET_HINTERP, & - supported_option_AEROSOL_DEPOSITION, & - met_force_obs_tile_new, nodata_forcing, PAR_available, MERRA_file_specs, & - init ) - - ! subroutine get_GEOS() provided backward-looking fluxes. - ! The time convention is restored through a later call to subroutine - ! LDAS_move_new_force_to_old(). - ! - ! Subroutine get_GEOS() reads forcing fluxes from "previous" - ! interval, not from "subsequent" interval, because in operational - ! applications the "subsequent" fluxes for "met_force_new" are not - ! available. Note that only "old" fluxes are needed in time interpolation - ! (module LDAS_InterpMod). - - bkwd_looking_fluxes = .true. - - ! model-based dataset; call repair_forcing() below without certain limitations - ! - ! call repair_forcing with switch "unlimited_Qair=.true." - ! (default is to limit Qair so that it does not exceed Qair_sat) - ! reichle+qliu, 8 Oct 2008 - ! - ! likewise for "unlimited_LWdown=.true." - ! reichle, 11 Feb 2009 - - unlimited_Qair = .true. - unlimited_LWdown = .true. - - end if - - ! ------------------ - ! - ! backfill PAR: - ! - ! PAR might be missing for one of the following reasons: - ! - the reader did not provide PAR - ! - the reader provides PAR but owing to a land mask difference between - ! the forcing data and the LDAS simulation, some tiles may not have PAR - ! - the reader provides PAR but there are gaps in the original dataset - ! - ! if PAR was not available at all from the forcing reader, assign "nodata_forcing" - - if (.not. PAR_available) then - met_force_obs_tile_new%PARdrct = nodata_forcing - met_force_obs_tile_new%PARdffs = nodata_forcing - end if - - ! the nodata-value for all forcing fields is now "nodata_forcing" - - ! where PAR is not available for any of the above reasons: - ! - assume half of SWdown is photosynthetically active - ! - assume half of PAR is direct, half diffuse - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - where ( & - (abs(met_force_obs_tile_new%PARdrct-nodata_forcing) < tol) .and. & - (abs(met_force_obs_tile_new%SWdown -nodata_forcing) > tol) ) - met_force_obs_tile_new%PARdrct = 0.5*0.5*met_force_obs_tile_new%SWdown - met_force_obs_tile_new%PARdffs = met_force_obs_tile_new%PARdrct - end where - - ! ------------------ - ! - ! check for nodata values and fill with neighboring data if sensible; - ! otherwise, check_forcing_nodata() will abort - - call check_forcing_nodata( N_catd, tile_coord, nodata_forcing, & - met_force_obs_tile_new ) - - ! ------------------ - ! - ! reset unphysical or inconsistent forcing values - - call repair_forcing( N_catd, met_force_obs_tile_new, & - echo=.true., tile_coord=tile_coord, & - fieldname='all', & - unlimited_Qair=unlimited_Qair, unlimited_LWdown=unlimited_LWdown ) - - ! ------------------ - ! - ! stop if a supported_option_* switch remains .false. - - if (.not. supported_option_MET_HINTERP) then - err_msg = 'selected MET_HINTERP option not supported for met_tag ' & - // trim(met_tag) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (.not. supported_option_AEROSOL_DEPOSITION) then - err_msg = 'selected AEROSOL_DEPOSITION option not supported for met_tag ' & - // trim(met_tag) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end subroutine get_forcing - - !************************************************************************************** - - subroutine LDAS_move_new_force_to_old( MERRA_file_specs, AEROSOL_DEPOSITION, & - new_force, old_force ) - - ! move *flux*-type forcing data from "new" to "old"; - ! call this subroutine ONLY if the forcing reader provides backward-looking fluxes - ! - reichle, 14 Apr 2021 - - implicit none - - logical, intent(in) :: MERRA_file_specs - integer, intent(in) :: AEROSOL_DEPOSITION - - type(met_force_type), dimension(:), intent(inout) :: new_force - type(met_force_type), dimension(:), intent(inout) :: old_force - - old_force%Rainf_C = new_force%Rainf_C - old_force%Rainf = new_force%Rainf - old_force%Snowf = new_force%Snowf - old_force%LWdown = new_force%LWdown - old_force%SWdown = new_force%SWdown - old_force%PARdrct = new_force%PARdrct - old_force%PARdffs = new_force%PARdffs - - new_force%Rainf_C = nodata_generic - new_force%Rainf = nodata_generic - new_force%Snowf = nodata_generic - new_force%LWdown = nodata_generic - new_force%SWdown = nodata_generic - new_force%PARdrct = nodata_generic - new_force%PARdffs = nodata_generic - - ! [moved here from below, reichle, 28 Jan 2021] - ! treat Wind as flux when forcing with MERRA - if (MERRA_file_specs) then - old_force%Wind = new_force%Wind - new_force%Wind = nodata_generic - endif - - ! not sure what exactly the following fields are and - ! whether it makes sense to include them here - ! - reichle, 28 Jan 2021 - ! - if( AEROSOL_DEPOSITION /=0) then - - old_force%DUDP001 = new_force%DUDP001 - old_force%DUDP002 = new_force%DUDP002 - old_force%DUDP003 = new_force%DUDP003 - old_force%DUDP004 = new_force%DUDP004 - old_force%DUDP005 = new_force%DUDP005 - old_force%DUSV001 = new_force%DUSV001 - old_force%DUSV002 = new_force%DUSV002 - old_force%DUSV003 = new_force%DUSV003 - old_force%DUSV004 = new_force%DUSV004 - old_force%DUSV005 = new_force%DUSV005 - old_force%DUWT001 = new_force%DUWT001 - old_force%DUWT002 = new_force%DUWT002 - old_force%DUWT003 = new_force%DUWT003 - old_force%DUWT004 = new_force%DUWT004 - old_force%DUWT005 = new_force%DUWT005 - old_force%DUSD001 = new_force%DUSD001 - old_force%DUSD002 = new_force%DUSD002 - old_force%DUSD003 = new_force%DUSD003 - old_force%DUSD004 = new_force%DUSD004 - old_force%DUSD005 = new_force%DUSD005 - old_force%BCDP001 = new_force%BCDP001 - old_force%BCDP002 = new_force%BCDP002 - old_force%BCSV001 = new_force%BCSV001 - old_force%BCSV002 = new_force%BCSV002 - old_force%BCWT001 = new_force%BCWT001 - old_force%BCWT002 = new_force%BCWT002 - old_force%BCSD001 = new_force%BCSD001 - old_force%BCSD002 = new_force%BCSD002 - old_force%OCDP001 = new_force%OCDP001 - old_force%OCDP002 = new_force%OCDP002 - old_force%OCSV001 = new_force%OCSV001 - old_force%OCSV002 = new_force%OCSV002 - old_force%OCWT001 = new_force%OCWT001 - old_force%OCWT002 = new_force%OCWT002 - old_force%OCSD001 = new_force%OCSD001 - old_force%OCSD002 = new_force%OCSD002 - old_force%SUDP003 = new_force%SUDP003 - old_force%SUSV003 = new_force%SUSV003 - old_force%SUWT003 = new_force%SUWT003 - old_force%SUSD003 = new_force%SUSD003 - old_force%SSDP001 = new_force%SSDP001 - old_force%SSDP002 = new_force%SSDP002 - old_force%SSDP003 = new_force%SSDP003 - old_force%SSDP004 = new_force%SSDP004 - old_force%SSDP005 = new_force%SSDP005 - old_force%SSSV001 = new_force%SSSV001 - old_force%SSSV002 = new_force%SSSV002 - old_force%SSSV003 = new_force%SSSV003 - old_force%SSSV004 = new_force%SSSV004 - old_force%SSSV005 = new_force%SSSV005 - old_force%SSWT001 = new_force%SSWT001 - old_force%SSWT002 = new_force%SSWT002 - old_force%SSWT003 = new_force%SSWT003 - old_force%SSWT004 = new_force%SSWT004 - old_force%SSWT005 = new_force%SSWT005 - old_force%SSSD001 = new_force%SSSD001 - old_force%SSSD002 = new_force%SSSD002 - old_force%SSSD003 = new_force%SSSD003 - old_force%SSSD004 = new_force%SSSD004 - old_force%SSSD005 = new_force%SSSD005 - - - new_force%DUDP001 = nodata_generic - new_force%DUDP002 = nodata_generic - new_force%DUDP003 = nodata_generic - new_force%DUDP004 = nodata_generic - new_force%DUDP005 = nodata_generic - new_force%DUSV001 = nodata_generic - new_force%DUSV002 = nodata_generic - new_force%DUSV003 = nodata_generic - new_force%DUSV004 = nodata_generic - new_force%DUSV005 = nodata_generic - new_force%DUWT001 = nodata_generic - new_force%DUWT002 = nodata_generic - new_force%DUWT003 = nodata_generic - new_force%DUWT004 = nodata_generic - new_force%DUWT005 = nodata_generic - new_force%DUSD001 = nodata_generic - new_force%DUSD002 = nodata_generic - new_force%DUSD003 = nodata_generic - new_force%DUSD004 = nodata_generic - new_force%DUSD005 = nodata_generic - new_force%BCDP001 = nodata_generic - new_force%BCDP002 = nodata_generic - new_force%BCSV001 = nodata_generic - new_force%BCSV002 = nodata_generic - new_force%BCWT001 = nodata_generic - new_force%BCWT002 = nodata_generic - new_force%BCSD001 = nodata_generic - new_force%BCSD002 = nodata_generic - new_force%OCDP001 = nodata_generic - new_force%OCDP002 = nodata_generic - new_force%OCSV001 = nodata_generic - new_force%OCSV002 = nodata_generic - new_force%OCWT001 = nodata_generic - new_force%OCWT002 = nodata_generic - new_force%OCSD001 = nodata_generic - new_force%OCSD002 = nodata_generic - new_force%SUDP003 = nodata_generic - new_force%SUSV003 = nodata_generic - new_force%SUWT003 = nodata_generic - new_force%SUSD003 = nodata_generic - new_force%SSDP001 = nodata_generic - new_force%SSDP002 = nodata_generic - new_force%SSDP003 = nodata_generic - new_force%SSDP004 = nodata_generic - new_force%SSDP005 = nodata_generic - new_force%SSSV001 = nodata_generic - new_force%SSSV002 = nodata_generic - new_force%SSSV003 = nodata_generic - new_force%SSSV004 = nodata_generic - new_force%SSSV005 = nodata_generic - new_force%SSWT001 = nodata_generic - new_force%SSWT002 = nodata_generic - new_force%SSWT003 = nodata_generic - new_force%SSWT004 = nodata_generic - new_force%SSWT005 = nodata_generic - new_force%SSSD001 = nodata_generic - new_force%SSSD002 = nodata_generic - new_force%SSSD003 = nodata_generic - new_force%SSSD004 = nodata_generic - new_force%SSSD005 = nodata_generic - - endif ! AEROSOL_DEPOSITION /=0 - - end subroutine LDAS_move_new_force_to_old - ! **************************************************************** - - subroutine get_Berg_netcdf(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read Berg_NetCDF files and extract forcings in tile space - ! (uses nearest neighbor interpolation) - - ! reichle, 25 May 2005 - ! reichle, 23 Feb 2009 -- revised treatment of Rainf_C - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! Berg grid and netcdf parameters - - integer, parameter :: berg_grid_N_lon = 720 - integer, parameter :: berg_grid_N_lat = 360 - real, parameter :: berg_grid_ll_lon = -180. - real, parameter :: berg_grid_ll_lat = -90. - real, parameter :: berg_grid_dlon = .5 - real, parameter :: berg_grid_dlat = .5 - - integer, parameter :: N_berg_compressed = 67420 - - ! Berg forcing time step in hours - - integer, parameter :: dt_berg_in_hours = 6 - - integer, parameter :: nciv_land_i = 3 - integer, parameter :: nciv_land_j = 4 - integer, parameter :: nciv_data = 7 - - integer, parameter :: N_berg_vars = 8 - - real, parameter :: nodata_berg = 1.e20 - - character(40), dimension(N_berg_vars), parameter :: berg_dir = (/ & - 'PREC-CONV/', & - 'PREC-TOTL/', & - 'PRES-SRF/ ', & - 'RAD-LW/ ', & - 'RAD-SW/ ', & - 'TEMP-AIR/ ', & - 'TEMP-DEW/ ', & - 'WIND/ ' /) - - character(40), dimension(N_berg_vars), parameter :: berg_name = (/ & - 'RainfSnowf_C_ecmwf', & - 'RainfSnowf_ecmwf ', & - 'PSurf_ecmwf ', & - 'LWdown_ecmwf ', & - 'SWdown_ecmwf ', & - 'Tair_ecmwf ', & - 'Tdew_ecmwf ', & - 'Wind_ecmwf ' /) - - ! local variables - - !!real, parameter :: Tzero = 273.16 - - real :: tol - - real, dimension(berg_grid_N_lon,berg_grid_N_lat) :: tmp_grid - - integer, dimension(N_berg_compressed) :: land_i_berg, land_j_berg - integer, dimension(N_catd) :: i_ind, j_ind - - real, dimension(N_berg_compressed) :: tmp_vec - - real, dimension(N_catd,N_berg_vars) :: force_array - - integer, dimension(2) :: start, icount - - integer :: k, n, hours_in_month, berg_var, ierr, ncid - - real :: this_lon, this_lat, dt_berg_in_seconds - - character(4) :: YYYY - character(2) :: MM - - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_Berg_netcdf' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - dt_berg_in_seconds = real(3600*dt_berg_in_hours) - - nodata_forcing = nodata_berg - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! assemble year and month strings - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - - ! find out which data are needed - - ! compressed space dimension (always read global vector) - - start(1) = 1 - icount(1) = N_berg_compressed - - ! time dimension (first entry in Berg_NetCDF file is at 0Z) - - if ( (date_time%min/=0) .or. (date_time%sec/=0) .or. & - (mod(date_time%hour,dt_berg_in_hours)/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing error') - - end if - - hours_in_month = (date_time%day-1)*24 + date_time%hour - - start(2) = hours_in_month / dt_berg_in_hours + 1 - icount(2) = 1 - - ! ---------------------------------------------- - ! - ! compute indices for nearest neighbor interpolation from Berg grid - ! to tile space - ! - ! (NOTE: this should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - ! ll_lon and ll_lat refer to lower left corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - i_ind(k) = ceiling( (this_lon - berg_grid_ll_lon)/berg_grid_dlon ) - j_ind(k) = ceiling( (this_lat - berg_grid_ll_lat)/berg_grid_dlat ) - - ! NOTE: For a "date line on center" grid and (180-dlon/2) < lon < 180 - ! we now have i_ind=(grid%N_lon+1) - ! This would need to be fixed. - - if (i_ind(k)>berg_grid_N_lon) i_ind(k)=1 - - end do - - ! ------------------------------------------------------ - ! - ! read compression parameters (same for all data variables and time steps) - - berg_var = 1 - - fname = trim(met_path) // trim(berg_dir(berg_var)) // '/' // YYYY & - // '/' // trim(berg_name(berg_var)) // '.' // YYYY // MM // '.nc' - - if(root_logit) write(logunit,*) 'get netcdf compression params from ' // trim(fname) - - ierr = NF_OPEN(fname,NF_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_INT(ncid, nciv_land_i, start, icount, land_i_berg) - ierr = NF_GET_VARA_INT(ncid, nciv_land_j, start, icount, land_j_berg) - - ierr = NF_CLOSE(ncid) - - ! ------------------------------------------------------ - ! - ! get forcing data - - do berg_var = 1,N_berg_vars - - ! open file, read compressed data, and put on global grid - - fname = trim(met_path) // trim(berg_dir(berg_var)) // '/' // YYYY & - // '/' // trim(berg_name(berg_var)) // '.' // YYYY // MM // '.nc' - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - ierr = NF_OPEN(fname,NF_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_REAL(ncid, nciv_data, start, icount, tmp_vec ) - - ierr = NF_CLOSE(ncid) - - tmp_grid = nodata_forcing - - do n=1,N_berg_compressed - - tmp_grid(land_i_berg(n), land_j_berg(n) ) = tmp_vec(n) - - end do - - ! interpolate to tile space - - ! (NOTE: This should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - force_array(k,berg_var) = tmp_grid(i_ind(k), j_ind(k)) - - end do - - end do - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from Berg files: - ! - ! force_array(:,1) = PREC-CONV = Rainf_C+Snowf_C kg/m2 (6h total) ??? - ! force_array(:,2) = PREC-TOTL = RainfSnowf kg/m2 (6h total) - ! force_array(:,3) = PRES-SRF = PSurf Pa - ! force_array(:,4) = RAD-LW = LWdown W/m2 - ! force_array(:,5) = RAD-SW = SWdown W/m2 - ! force_array(:,6) = TEMP-AIR = Tair K - ! force_array(:,7) = TEMP-DEW = Tdew K - ! force_array(:,8) = WIND = Wind m/s - - met_force_new%Psurf = force_array(:,3) - met_force_new%LWdown = force_array(:,4) - met_force_new%SWdown = force_array(:,5) - met_force_new%Tair = force_array(:,6) - met_force_new%Wind = force_array(:,8) - - ! get specific humidity from dew point temperature - - do k=1,N_catd - - if ( abs(force_array(k,3)-nodata_berg) DIFFERENT FROM GSWP2 FORMAT!!! <------ - ! - ! At 0Z for first day of month: - ! - for fluxes read first entry of that month - ! - for states read first entry of that month - ! At 6Z for first day of month: - ! - for fluxes read second entry of that month - ! - for states read second entry of that month - ! and so on... - - select case (this_var) - - case (1,2,3,4,5) ! "fluxes" - - date_time_tmp = date_time - - case (6,7,8,9) ! "states" - - date_time_tmp = date_time - - !!call augment_date_time(-int_dt_RedArk_GOLD_in_seconds,date_time_tmp) - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'error') - - end select - - ! assemble year and month strings - - write (YYYY,'(i4.4)') date_time_tmp%year - write (MM, '(i2.2)') date_time_tmp%month - write (DD, '(i2.2)') date_time_tmp%day - write (HHMM,'(i4.4)') date_time_tmp%hour*100 + date_time_tmp%min - - ! assemble file name, open file - - fname = trim(met_path) // '/' // trim(RedArk_GOLD_name(this_var)) & - // '/Y' // YYYY // '/M' // MM // '/' & - // trim(RedArk_GOLD_name(this_var)) // '_RedArk_' // & - YYYY // MM // DD // '_' // HHMM - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - open(10,file=fname,form='formatted',action='read') - - ! read compressed data, and put into tile space - - do i=1,RedArk_GOLD_N_cells - - read (10,*) tmp_vec(i) - - end do - - close(10,status='keep') - - do k=1,N_catd - - force_array(k,this_var) = tmp_vec( ind_gold2tile(k) ) - - end do - - end do - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from RedArk GOLD files: - ! - ! force_array(:, 1) = SWdown W/m2 - ! force_array(:, 2) = LWdown W/m2 - ! force_array(:, 3) = Rainf_C kg/m2/s - ! force_array(:, 4) = Rainf kg/m2/s - ! force_array(:, 5) = Snowf kg/m2/s - ! force_array(:, 6) = PSurf Pa - ! force_array(:, 7) = Qair kg/kg - ! force_array(:, 8) = Tair K - ! force_array(:, 9) = Wind m/s - - met_force_new%SWdown = force_array(:,1) - met_force_new%LWdown = force_array(:,2) - met_force_new%Rainf_C = force_array(:,3) - met_force_new%Rainf = force_array(:,4) - met_force_new%Snowf = force_array(:,5) - met_force_new%Psurf = force_array(:,6) - met_force_new%Qair = force_array(:,7) - met_force_new%Tair = force_array(:,8) - met_force_new%Wind = force_array(:,9) - - end subroutine get_RedArk_GOLD - - ! *************************************************************************** - - subroutine get_RedArk_Princeton(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read RedArk Princeton files and map to forcings in tile space - ! (uses pre-computed nearest neighbor interpolation) - - ! reichle, 6 Apr 2007 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! interpolation parameters - - integer, parameter :: RedArk_Princeton_N_cells = 70 - - character(80), parameter :: RedArk_Princeton_coord_file = & - 'Princeton_forcing_cells_2_RedArkOSSE_tiles.dat' - - ! Princeton_REDARK forcing time step in hours - - integer, parameter :: dt_RedArk_Princeton_in_hours = 3 - - integer, parameter :: N_RedArk_Princeton_vars = 7 - - real, parameter :: nodata_RedArk_Princeton = -9999. ! ????? - - character(40), dimension(N_RedArk_Princeton_vars), parameter :: & - RedArk_Princeton_name = (/ & - 'dswrf', & ! 1 - flux - 'dlwrf', & ! 2 - flux - 'prcp ', & ! 3 - flux - 'pres ', & ! 4 - state - 'shum ', & ! 5 - state - 'tas ', & ! 6 - state - 'wind ' /) ! 7 - state - - ! local variables - - real :: tol - - integer, dimension(N_catd) :: ind_princeton2tile - - real, dimension(RedArk_Princeton_N_cells) :: tmp_vec - - real, dimension(N_catd,N_RedArk_Princeton_vars) :: force_array - - type(date_time_type) :: date_time_tmp - - integer :: int_dt_RedArk_Princeton_in_secs, i, k, this_var, tmp_tile_id - - character(4) :: YYYY, HHMM - character(2) :: MM, DD - - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_RedArk_Princeton' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - int_dt_RedArk_Princeton_in_secs = 3600*dt_RedArk_Princeton_in_hours - - nodata_forcing = nodata_RedArk_Princeton - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! ---------------------------------------------- - ! - ! load indices for nearest neighbor interpolation from Princeton RedArk vec - ! to tile space - - fname = trim(met_path) // '/' // trim(RedArk_Princeton_coord_file) - - open (10, file=fname, form='formatted', action='read') - - do i=1,N_catd - - read (10,*) tmp_tile_id, ind_princeton2tile(i) - - if (tmp_tile_id /= tile_coord(i)%tile_id) then - err_msg = 'RedArk Princeton2tile error' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end do - - ! ------------------------------------------------------ - ! - ! get forcing data - - do this_var = 1,N_RedArk_Princeton_vars - - ! time dimension - ! - ! *** STATEMENTS BELOW STILL NEED TO BE VERIFIED!!!! - reichle, 6 Apr 2007 **** - ! - ! First entry in Princeton_RedArk file is at 0Z for states, - ! with fluxes for 0Z-3Z - ! ------> DIFFERENT FROM GSWP2 FORMAT!!! <------ - ! - ! At 0Z for first day of month: - ! - for fluxes read first entry of that month - ! - for states read first entry of that month - ! At 3Z for first day of month: - ! - for fluxes read second entry of that month - ! - for states read second entry of that month - ! and so on... - - select case (this_var) - - case (1,2,3) ! "fluxes" - - date_time_tmp = date_time - - case (4,5,6,7) ! "states" - - date_time_tmp = date_time - - !!call augment_date_time(-int_dt_RedArk_Princeton_in_secs,date_time_tmp) - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'error') - - end select - - ! assemble year and month strings - - write (YYYY,'(i4.4)') date_time_tmp%year - write (MM, '(i2.2)') date_time_tmp%month - write (DD, '(i2.2)') date_time_tmp%day - write (HHMM,'(i4.4)') date_time_tmp%hour*100 + date_time_tmp%min - - ! assemble file name, open file - - fname = trim(met_path) // '/' // trim(RedArk_Princeton_name(this_var)) & - // '/Y' // YYYY // '/M' // MM // '/' & - // trim(RedArk_Princeton_name(this_var)) // '_RedArk_' // & - YYYY // MM // DD // '_' // HHMM - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - open(10,file=fname,form='formatted',action='read') - - ! read compressed data, and put into tile space - - do i=1,RedArk_Princeton_N_cells - - read (10,*) tmp_vec(i) - - end do - - close(10,status='keep') - - do k=1,N_catd - - force_array(k,this_var) = tmp_vec( ind_princeton2tile(k) ) - - end do - - end do - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from RedArk Princeton files: - ! - ! force_array(:, 1) = SWdown W/m2 - ! force_array(:, 2) = LWdown W/m2 - ! force_array(:, 3) = RainfSnowf kg/m2/s - ! force_array(:, 4) = PSurf Pa - ! force_array(:, 5) = Qair kg/kg - ! force_array(:, 6) = Tair K - ! force_array(:, 7) = Wind m/s - - met_force_new%SWdown = force_array(:,1) - met_force_new%LWdown = force_array(:,2) - met_force_new%Psurf = force_array(:,4) - met_force_new%Qair = force_array(:,5) - met_force_new%Tair = force_array(:,6) - met_force_new%Wind = force_array(:,7) - - do k=1,N_catd - - ! rain and snow: - ! partition total precip into rain and snow according to Tair - ! set convective precip to zero - - met_force_new(k)%Rainf_C = 0. - - if ( met_force_new(k)%Tair < Tzero ) then - met_force_new(k)%Rainf = 0. - met_force_new(k)%Snowf = force_array(k,3) - else - met_force_new(k)%Rainf = force_array(k,3) - met_force_new(k)%Snowf = 0. - end if - - end do - - end subroutine get_RedArk_Princeton - - ! **************************************************************** - - subroutine get_Princeton_netcdf(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read Princeton_NetCDF files and extract forcing in tile space - ! (uses nearest neighbor interpolation) - - ! tyamada+reichle, 19 Jul 2007 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! Princeton_netcdf grid and netcdf parameters - - integer, parameter :: Princeton_grid_N_lon = 360 - integer, parameter :: Princeton_grid_N_lat = 180 - real, parameter :: Princeton_grid_ll_lon = 0. - real, parameter :: Princeton_grid_ll_lat = -90. - real, parameter :: Princeton_grid_dlon = 1. - real, parameter :: Princeton_grid_dlat = 1. - - ! Princeton_netcdf forcing time step in hours - - integer, parameter :: dt_Princeton_in_hours = 3 - integer, parameter :: nciv_data = 5 ! (1=lon, 2=lat, 3=z, 4=time, 5=data) - integer, parameter :: N_Princeton_vars = 7 - real, parameter :: nodata_Princeton = 2.e20 - - character(40), dimension(N_Princeton_vars), parameter :: Princeton_name = & - (/ & - 'dswrf', & ! 1 - flux - 'dlwrf', & ! 2 - flux - 'prcp ', & ! 3 - flux - 'pres ', & ! 4 - state - 'shum ', & ! 5 - state - 'tas ', & ! 6 - state - 'wind ' & ! 7 - state - /) - - ! local variables - - integer, dimension(N_catd) :: i_ind, j_ind - - real, dimension(Princeton_grid_N_lon, Princeton_grid_N_lat) :: tmp_grid - - real, dimension(N_catd, N_Princeton_vars) :: force_array - - integer, dimension(4) :: start, icount - - integer :: k, hours_in_year, Princeton_var, ierr, ncid - - real :: tol, this_lon, this_lat, dt_Princeton_in_seconds - - character( 4) :: YYYY, HHMM - character( 2) :: MM, DD - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_Princeton_netcdf' - character(len=400) :: err_msg - - ! ---------------------------------------------------------------- - - dt_Princeton_in_seconds = real(3600*dt_Princeton_in_hours) - - nodata_forcing = nodata_Princeton - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! assemble year and month strings - - write (YYYY, '(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HHMM, '(i4.4)') date_time%hour*100 + date_time%min - - ! set lon index - - start(1) = 1 - icount(1) = 360 - - ! set lat index - - start(2) = 1 - icount(2) = 180 - - ! set z index - - start(3) = 1 - icount(3) = 1 - - ! get time index - - if ( (date_time%min/=0) .or. (date_time%sec/=0) .or. & - (mod(date_time%hour, dt_Princeton_in_hours)/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing ERROR!!') - - endif - - hours_in_year = (date_time%dofyr-1)*24 + date_time%hour - - start(4) = hours_in_year / dt_Princeton_in_hours + 1 - icount(4) = 1 - - ! ---------------------------------------------------------------- - - do k=1,N_catd - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - ! change lon units for compatibility with Princeton netcdf - ! grid which starts at the Greenwich Meridian and goes - ! eastward (lon=0:360) - - if (this_lon<0.) this_lon = this_lon + 360. - - i_ind(k) = ceiling((this_lon - Princeton_grid_ll_lon)/Princeton_grid_dlon) - - j_ind(k) = ceiling((this_lat - Princeton_grid_ll_lat)/Princeton_grid_dlat) - - ! not sure this is quite right -- reichle, 24 Feb 2009 - - i_ind(k) = mod(i_ind(k), Princeton_grid_N_lon) - - ! fixed per suggestion from Greg Walker, - reichle, 26 Aug 2015 - - if(i_ind(k) < 1) i_ind(k) = i_ind(k) + Princeton_grid_N_lon - - enddo - - ! ---------------------------------------------------------------- - ! - ! open input file - - do Princeton_var = 1,N_Princeton_vars - - fname = trim(met_path) // '/' // trim(Princeton_name(Princeton_var)) & - // '_3hourly_' // YYYY // '-' // YYYY // '.nc' - - if(root_logit) write(logunit,*) 'opening' // trim(fname) - - ierr = NF_OPEN(fname, NF_NOWRITE, ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_REAL(ncid, nciv_data, start, icount, tmp_grid) - - ierr = NF_CLOSE(ncid) - - do k = 1, N_catd - - force_array(k, Princeton_var) = tmp_grid(i_ind(k), j_ind(k)) - - enddo - - enddo - - ! ---------------------------------------------------------------- - - met_force_new%SWdown = force_array(:, 1) - met_force_new%LWdown = force_array(:, 2) - met_force_new%Psurf = force_array(:, 4) - met_force_new%Qair = force_array(:, 5) - met_force_new%Tair = force_array(:, 6) - met_force_new%Wind = force_array(:, 7) - - do k=1, N_catd - - met_force_new(k)%Rainf_C = 0. - - if ( met_force_new(k)%Tair < Tzero ) then - met_force_new(k)%Rainf = 0. - met_force_new(k)%Snowf = force_array(k,3) - else - met_force_new(k)%Rainf = force_array(k,3) - met_force_new(k)%Snowf = 0. - endif - - enddo - - end subroutine get_Princeton_netcdf - - ! **************************************************************** - - subroutine get_conus_netcdf(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read conus_NetCDF files and extract forcing in tile space - ! (uses nearest neighbor interpolation) - - ! sarith+reichle, 19 Jul 2007 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! conus_netcdf grid and netcdf parameters - - integer, parameter :: conus_grid_N_lon = 115 - integer, parameter :: conus_grid_N_lat = 48 - real, parameter :: conus_grid_ll_lon = -125. - real, parameter :: conus_grid_ll_lat = 25. - real, parameter :: conus_grid_dlon = 0.5 - real, parameter :: conus_grid_dlat = 0.5 - - ! conus_netcdf forcing time step in hours - - integer, parameter :: dt_conus_in_hours = 1 - - integer, parameter :: N_conus_vars = 7 - real, parameter :: nodata_conus = 1.e20 - - character(40), dimension(N_conus_vars), parameter :: conus_name = & - (/ & - 'fsds ', & ! 1 - flux - 'flds ', & ! 2 - flux - 'precs', & ! 3 - flux - 'tbot ', & ! 4 - state - 'wind ', & ! 5 - state - 'psrf ', & ! 6 - state - 'qbot ' & ! 7 - state - /) - - integer :: nciv_data - - ! local variables - - integer, dimension(N_catd) :: i_ind, j_ind - - real, dimension(conus_grid_N_lon, conus_grid_N_lat) :: tmp_grid - - real, dimension(N_catd, N_conus_vars) :: force_array - - integer, dimension(3) :: start, icount - - integer :: k, hours_in_month, conus_var, ierr, ncid - - real :: tol, this_lon, this_lat, dt_conus_in_seconds - - character( 4) :: YYYY, HHMM - character( 2) :: MM, DD - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_conus_netcdf' - character(len=400) :: err_msg - - ! ---------------------------------------------------------------- - - dt_conus_in_seconds = real(3600*dt_conus_in_hours) - - nodata_forcing = nodata_conus - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! assemble year and month strings - - write (YYYY, '(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HHMM, '(i4.4)') date_time%hour*100 + date_time%min - - ! set lon index - - start(1) = 1 - icount(1) = conus_grid_N_lon - - ! set lat index - - start(2) = 1 - icount(2) = conus_grid_N_lat - - ! set z index - - !start(3) = 1 - !icount(3) = 1 - - ! get time index - - if ( (date_time%min/=0) .or. (date_time%sec/=0) .or. & - (mod(date_time%hour, dt_conus_in_hours)/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing ERROR!!') - - endif - - hours_in_month = (date_time%day-1)*24 + date_time%hour - - start(3) = hours_in_month / dt_conus_in_hours + 1 - icount(3) = 1 - - ! ---------------------------------------------------------------- - - do k=1,N_catd - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - i_ind(k) = ceiling((this_lon - conus_grid_ll_lon)/conus_grid_dlon) - - j_ind(k) = ceiling((this_lat - conus_grid_ll_lat)/conus_grid_dlat) - - enddo - - ! ---------------------------------------------------------------- - ! - ! open input file - - fname = trim(met_path) // '/' // YYYY//'-'//MM//'.nc' - - if(root_logit) write (logunit,*) 'opening' // trim(fname) - - ierr = NF_OPEN(fname, NF_NOWRITE, ncid) - - if (ierr/=0) then - err_msg = 'error opening conus_netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - do conus_var = 1,N_conus_vars - - ! nciv_data = order of fields in netcdf file: - ! - ! 5=lat, 6=lon, 7=fsds, 8=flds, 9=precs, 10=tbot, 11=wind, 12=psrf, 13=qbot - - nciv_data = 6 + conus_var - - ierr = NF_GET_VARA_REAL(ncid, nciv_data , start, icount, tmp_grid) - - do k = 1, N_catd - - force_array(k, conus_var) = tmp_grid(i_ind(k), j_ind(k)) - - end do - - enddo - - ierr = NF_CLOSE(ncid) - - ! ---------------------------------------------------------------- - - met_force_new%SWdown = force_array(:, 1) - met_force_new%LWdown = force_array(:, 2) - met_force_new%Psurf = force_array(:, 6) - met_force_new%Qair = force_array(:, 7) - met_force_new%Tair = force_array(:, 4) - met_force_new%Wind = force_array(:, 5) - - do k=1, N_catd - - met_force_new(k)%Rainf_C = 0. - - if ( met_force_new(k)%Tair < Tzero ) then - met_force_new(k)%Rainf = 0. - met_force_new(k)%Snowf = force_array(k,3) - else - met_force_new(k)%Rainf = force_array(k,3) - met_force_new(k)%Snowf = 0. - endif - - enddo - - end subroutine get_conus_netcdf - - - ! **************************************************************** - - subroutine get_ERA5_LIS(date_time, met_path, N_catd, tile_coord, MET_HINTERP, & - supported_option_MET_HINTERP, met_force_new, nodata_forcing ) - - ! Read ERA5 NetCDF files maintained and shared by the NASA LIS group - ! and based on forcing data put together originally for LDAS-Monde. - ! - ! Forcing data available over land only! - ! - ! Forcing data are interpolated into tile space using nearest-neighbor; - ! select MET_HINTERP accordingly during run configuration. - ! - ! Note that the LDAS-Monde data used here *differ* from the published - ! ERA5 data that are available through the Copernicus Climate Change - ! Service (C3S) Climate Data Store. - ! - ! Both the LDAS-Monde and the public data are on 1/4-deg lat/lon grids, - ! but the grids are offset by 1/2 grid cell in both the lat and long directions. - ! Also, the grid of the public data has 721 latitude points. - ! - ! Moreover, the LDAS-Monde data provide temperature and humidity for the - ! lowest atmospheric model level (~10 m), which are not available from the - ! C3S Climate Data Store. - ! - ! borescan+reichle, 14 Apr 2021 - ! - ! borescan+wjiang+reichle, 7 Oct 2021: added bilinear interpolation option - ! - ! ---------------------------------------------------------- - - use netcdf - implicit none - include 'mpif.h' - - type(date_time_type), intent(in) :: date_time - character(*), intent(in) :: met_path - integer, intent(in) :: N_catd, MET_HINTERP - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - logical, intent(inout) :: supported_option_MET_HINTERP - - type(met_force_type) , dimension(N_catd), intent(inout) :: met_force_new - real, intent(out) :: nodata_forcing - - ! ERA5 grid and netcdf parameters - - integer, parameter :: era5_grid_N_lon = 1440 - integer, parameter :: era5_grid_N_lat = 720 - real, parameter :: era5_grid_ll_lon = -180.0000 - real, parameter :: era5_grid_ll_lat = -90.0000 - real, parameter :: era5_grid_dlon = 0.25 - real, parameter :: era5_grid_dlat = 0.25 - integer, parameter :: N_era5_compressed = 340819 ! number of land grid cells - integer, parameter :: N_era5_vars = 9 - real, parameter :: nodata_era5 = 1.e20 - - character(40), dimension(N_era5_vars), parameter :: era5_name = (/ & - 'DIR_SWdown', & ! (1) - 'LWdown ', & ! (2) - 'Snowf ', & ! (3) - 'Rainf ', & ! (4) - 'Tair ', & ! (5) - 'Qair ', & ! (6) - 'Wind ', & ! (7) - 'PSurf ', & ! (8) - 'UREF '/) ! (9) at 10m - - ! local variables - - real, dimension(era5_grid_N_lon,era5_grid_N_lat) :: tmp_grid - integer, dimension(N_era5_compressed) :: land_i_era5, land_j_era5, p2g - real, dimension(N_era5_compressed) :: tmp_vec - real, dimension(N_catd,N_era5_vars) :: force_array - integer, dimension(2) :: start, icount - - integer :: k, n, hours_in_month, era5_var, ierr, ncid, era5_varid, kk - real :: tol, this_lon, this_lat - - character(4) :: YYYY - character(2) :: MM - character(300) :: fname - character(len=*), parameter :: Iam = 'get_ERA5_LIS' - character(len=400) :: err_msg - - ! bilinear interpolation variables - - integer, dimension(N_catd) :: i1, j1, i2, j2 - real, dimension(N_catd) :: x1, y1, x2, y2 - real :: fnbr(2,2) - - ! ---------------------------------------------------------------------------------------- - - nodata_forcing = nodata_era5 - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! assemble year and month strings - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - - ! compressed space dimension (always read global vector) - - start(1) = 1 - icount(1) = N_era5_compressed - - ! time dimension (first entry in ERA5_LIS file is at 00Z) - - if ( (date_time%min/=0) .or. (date_time%sec/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing ERROR!!') - - end if - - hours_in_month = (date_time%day-1)*24 + date_time%hour - - start(2) = hours_in_month + 1 - icount(2) = 1 - - ! compute indices for the nearest neighbor interpolation from ERA5 grid - ! to tile space - - call get_neighbor_index(MET_HINTERP, tile_coord, & - era5_grid_ll_lon, era5_grid_ll_lat, era5_grid_dlon, era5_grid_dlat, & - era5_grid_N_lon, era5_grid_N_lat, i1, j1, i2, j2, x1, y1, x2, y2) - - ! read parameters (same for all data variables and time steps) - - ! First read the point2grid (p2g) variable from the mapping.nc file - ! 'point2grid' is used to calculate i and j indices for the tmp_grid - - fname = trim(met_path) // '/mapping.nc' - - if(root_logit) write (logunit,*) 'get compression index vector from ' // trim(fname) - - ierr = NF90_OPEN(fname,NF90_NOWRITE,ncid) - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! read P2G from the nc file - ierr = NF90_INQ_VARID(ncid,'P2G',era5_varid) - ierr = NF90_GET_VAR(ncid, era5_varid, p2g) - - ! calculate i, j indices on era5_grid from 1-dim p2g index - - p2g = p2g-1 - - land_i_era5 = mod( p2g,era5_grid_N_lon ) + 1 - land_j_era5 = p2g/era5_grid_N_lon + 1 - - ! close NC file - ierr = NF90_CLOSE(ncid) - - ! read Forcing data (for the date corresponding to LIS file) - - ! open file - fname = trim(met_path) // '/FORCING_' // YYYY // MM // '.nc' - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - ierr = NF90_OPEN(fname,NF90_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! loop through forcing variables - - do era5_var = 1,N_era5_vars - - ierr = NF90_INQ_VARID(ncid,trim(era5_name(era5_var)),era5_varid) ! get var ID - ierr = NF90_GET_VAR(ncid,era5_varid,tmp_vec,start,icount) ! read variable - - ! put data on global grid - - tmp_grid = nodata_forcing ! initialize - - do n=1,N_era5_compressed - tmp_grid(land_i_era5(n),land_j_era5(n)) = tmp_vec(n) - end do - - select case (MET_HINTERP) ! interpolation method - - case (0) ! nearest neighbor interpolation - - ! interpolate to tile space - - do k=1,N_catd - force_array(k,era5_var) = tmp_grid(i1(k),j1(k)) - end do - - case (1) ! bilinear interpolation - - ! confirm that bilinear interpolation is supported in this reader - - supported_option_MET_HINTERP = .true. - - do k=1,N_catd - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - fnbr(1,1) = tmp_grid(i1(k),j1(k)) ! ptrShForce(i1(k),j1(k)) - fnbr(1,2) = tmp_grid(i1(k),j2(k)) ! ptrShForce(i1(k),j2(k)) - fnbr(2,1) = tmp_grid(i2(k),j1(k)) ! ptrShForce(i2(k),j1(k)) - fnbr(2,2) = tmp_grid(i2(k),j2(k)) ! ptrShForce(i2(k),j2(k)) - - force_array(k,era5_var) = BilinearInterpolation(this_lon, this_lat, x1(k), x2(k), & - y1(k), y2(k), fnbr, nodata_forcing, tol) - - end do - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unsupported MET_HINTERP option') - - end select ! interpolation method - - end do ! era5_var - - ierr = NF90_CLOSE(ncid) ! close NC file - - ! All variables in ERA5_LIS files have the units needed by met_force_type. - ! - ! force_array(:, 1) = DIR_SWdown W/m2 ; flux ;(ssrd) - ! force_array(:, 2) = LWdown W/m2 ; flux ;(strd) - ! force_array(:, 3) = Snowf kg/m2/s ; flux ;(sf) - ! force_array(:, 4) = Rainf kg/m2/s ; flux ;(cp+lsp-sf) - ! force_array(:, 5) = Tair K ; state ;(corresponds to T at the lowest model layer (~10m)) - ! force_array(:, 6) = Qair kg/kg ; state ;(corresponds to Q at the lowest model layer (~10m)) - ! force_array(:, 7) = Wind m/s ; state ;(sqrt(u2+v2)) - ! force_array(:, 8) = PSurf Pa ; state ;(derived from lnsp) - - met_force_new%SWdown = force_array(:,1) - met_force_new%LWdown = force_array(:,2) - met_force_new%Snowf = force_array(:,3) - met_force_new%Rainf = force_array(:,4) - met_force_new%Rainf_C = 0. ! always set convective precip to zero - met_force_new%Tair = force_array(:,5) - met_force_new%Qair = force_array(:,6) - met_force_new%Wind = force_array(:,7) - met_force_new%Psurf = force_array(:,8) - met_force_new%RefH = force_array(:,9) - - ! do not touch %PARdrct, and %PARdffs, which are not avaibable from ERA5_LIS - - end subroutine get_ERA5_LIS - - ! **************************************************************** - - subroutine get_GLDAS_2x2_5_netcdf(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read GLDAS_NetCDF files and extract forcings in tile space - ! (uses nearest neighbor interpolation) - - ! reichle, 30 Jun 2005 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! GLDAS grid and netcdf parameters - - integer, parameter :: gldas_grid_N_lon = 144 - integer, parameter :: gldas_grid_N_lat = 76 - real, parameter :: gldas_grid_ll_lon = -181.25 - real, parameter :: gldas_grid_ll_lat = -61. - real, parameter :: gldas_grid_dlon = 2.5 - real, parameter :: gldas_grid_dlat = 2. - - integer, parameter :: N_gldas_compressed = 3023 - - ! GLDAS forcing time step in hours - - integer, parameter :: dt_gldas_in_hours = 3 - - integer, parameter :: nciv_land_i = 3 - integer, parameter :: nciv_land_j = 4 - integer, parameter :: nciv_data = 7 - - integer, parameter :: N_gldas_vars = 10 - - real, parameter :: nodata_gldas = 1.e20 - - character(40), dimension(N_gldas_vars), parameter :: gldas_name = (/ & - 'SWdown_gldas ', & ! 1 - 'LWdown_gldas ', & ! 2 - 'Snowf_gldas ', & ! 3 - 'Rainf_gldas ', & ! 4 - 'Tair_gldas ', & ! 5 - 'Qair_gldas ', & ! 6 - 'Wind_E_gldas ', & ! 7 - 'Wind_N_gldas ', & ! 8 - 'PSurf_gldas ', & ! 9 - 'RainfSnowf_C_gldas' /) ! 10 ??? - - ! local variables - - real :: tol - - real, dimension(gldas_grid_N_lon,gldas_grid_N_lat) :: tmp_grid - - integer, dimension(N_gldas_compressed) :: land_i_gldas, land_j_gldas - integer, dimension(N_catd) :: i_ind, j_ind - - real, dimension(N_gldas_compressed) :: tmp_vec - - real, dimension(N_catd,N_gldas_vars) :: force_array - - integer, dimension(2) :: start, icount - - integer :: k, n, hours_in_month, gldas_var, ierr, ncid - - real :: this_lon, this_lat, dt_gldas_in_seconds - - character(4) :: YYYY - character(2) :: MM - - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_GLDAS_netcdf' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - dt_gldas_in_seconds = real(3600*dt_gldas_in_hours) - - nodata_forcing = nodata_gldas - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! assemble year and month strings - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - - ! find out which data are needed - - ! compressed space dimension (always read global vector) - - start(1) = 1 - icount(1) = N_gldas_compressed - - ! time dimension (first entry in GLDAS_NetCDF file is at 0Z) - - if ( (date_time%min/=0) .or. (date_time%sec/=0) .or. & - (mod(date_time%hour,dt_gldas_in_hours)/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing ERROR!!') - - end if - - hours_in_month = (date_time%day-1)*24 + date_time%hour - - start(2) = hours_in_month / dt_gldas_in_hours + 1 - icount(2) = 1 - - ! ---------------------------------------------- - ! - ! compute indices for nearest neighbor interpolation from GLDAS grid - ! to tile space - ! - ! (NOTE: this should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - ! ll_lon and ll_lat refer to lower left corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - i_ind(k) = ceiling( (this_lon - gldas_grid_ll_lon)/gldas_grid_dlon ) - j_ind(k) = ceiling( (this_lat - gldas_grid_ll_lat)/gldas_grid_dlat ) - - ! NOTE: For a "date line on center" grid and (180-dlon/2) < lon < 180 - ! we now have i_ind=(grid%N_lon+1) - ! This needs to be fixed. - - if (i_ind(k)>gldas_grid_N_lon) i_ind(k)=1 - - end do - - ! ------------------------------------------------------ - ! - ! read compression parameters (same for all data variables and time steps) - - gldas_var = 1 - - fname = trim(met_path) // trim(gldas_name(gldas_var)) // '/' // YYYY & - // '/' // trim(gldas_name(gldas_var)) // '.' // YYYY // MM // '.nc' - - if(root_logit) write (logunit,*) 'get netcdf compression params from ' // trim(fname) - - ierr = NF_OPEN(fname,NF_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_INT(ncid, nciv_land_i, start, icount, land_i_gldas) - ierr = NF_GET_VARA_INT(ncid, nciv_land_j, start, icount, land_j_gldas) - - ierr = NF_CLOSE(ncid) - - ! ------------------------------------------------------ - ! - ! get forcing data - - do gldas_var = 1,N_gldas_vars - - ! open file, read compressed data, and put on global grid - - fname = trim(met_path) // trim(gldas_name(gldas_var)) // '/' // YYYY & - // '/' // trim(gldas_name(gldas_var)) // '.' // YYYY // MM // & - '.nc' - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - ierr = NF_OPEN(fname,NF_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_REAL(ncid, nciv_data, start, icount, tmp_vec ) - - ierr = NF_CLOSE(ncid) - - tmp_grid = nodata_forcing - - do n=1,N_gldas_compressed - - tmp_grid(land_i_gldas(n), land_j_gldas(n) ) = tmp_vec(n) - - end do - - ! interpolate to tile space - - ! (NOTE: This should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - force_array(k,gldas_var) = tmp_grid(i_ind(k), j_ind(k)) - - end do - - end do - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from GLDAS files: - ! - ! force_array(:, 1) = SWdown W/m2 - ! force_array(:, 2) = LWdown W/m2 - ! force_array(:, 3) = Snowf kg/m2 (3h total) - ! force_array(:, 4) = Rainf kg/m2 (3h total) - ! force_array(:, 5) = Tair K - ! force_array(:, 6) = Qair kg/kg - ! force_array(:, 7) = Wind_E m/s - ! force_array(:, 8) = Wind_N m/s - ! force_array(:, 9) = PSurf Pa - ! force_array(:,10) = RainfSnowf_C kg/m2 (3h total) ??? - - met_force_new%SWdown = force_array(:,1) - met_force_new%LWdown = force_array(:,2) - met_force_new%Tair = force_array(:,5) - met_force_new%Qair = force_array(:,6) - met_force_new%Psurf = force_array(:,9) - - ! get wind speed from wind vector - - do k=1,N_catd - - if ( abs(force_array(k,7)-nodata_gldas)local_info%i1 - i2=>local_info%i2 - j1=>local_info%j1 - j2=>local_info%j2 - x1=>local_info%x1 - x2=>local_info%x2 - y1=>local_info%y1 - y2=>local_info%y2 - - ! allocate force_array - - allocate(force_array(N_catd,N_GEOSgcm_vars)) - force_array = nodata_forcing - - ! loop over variables - - do GEOSgcm_var = 1,N_GEOSgcm_vars - - ! init shared memory - N_lon_tmp = -1 - N_lat_tmp = -1 - if (associated(ptrShForce)) then - N_lon_tmp = size(ptrShForce,1) - N_lat_tmp = size(ptrShForce,2) - endif - if( (N_lon_tmp /= GEOSgcm_grid_N_lon) .or. & - (N_lat_tmp /= GEOSgcm_grid_N_lat) ) then - call MAPL_SyncSharedMemory(rc=status) - VERIFY_(status) - if (associated(ptrShForce)) then - call MAPL_DeallocNodeArray(ptrShForce,rc=status) - VERIFY_(status) - endif - call MAPL_AllocateShared(ptrShForce,(/GEOSgcm_grid_N_lon,GEOSgcm_grid_N_lat/),TransRoot= .true.,rc=status) - VERIFY_(status) - end if - - call MAPL_SyncSharedMemory(rc=status) - VERIFY_(status) - - ! read variable from netcdf file - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - rc= NF90_INQ_VARID( fid, trim(GEOSgcm_name(GEOSgcm_var)), nv_id) - _ASSERT( rc == nf90_noerr, "nf90 error") - rc= NF90_GET_VAR( fid, nv_id, ptrShForce, start=iistart,count=iicount) - end if - - call MAPL_SyncSharedMemory(rc=status) - - ! map variable array to force array using chosen met interpolation method - - select case (MET_HINTERP) - - case(0) ! nearest neighbor interpolation - - do k = 1, N_catd - force_array(k, GEOSgcm_var) = ptrShForce(i1(k), j1(k)) - end do - - case (1) ! bilinear interpolation - - do k=1,N_catd - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - fnbr(1,1) = ptrShForce(i1(k),j1(k)) - fnbr(1,2) = ptrShForce(i1(k),j2(k)) - fnbr(2,1) = ptrShForce(i2(k),j1(k)) - fnbr(2,2) = ptrShForce(i2(k),j2(k)) - - !DEC$ FORCEINLINE - force_array(k,GEOSgcm_var) = BilinearInterpolation(this_lon, this_lat, & - x1(k), x2(k), y1(k), y2(k), fnbr, nodata_forcing, tol) - end do - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unsupported MET_HINTERP option') - - end select - end do ! GEOSgcm_var - - ! ---------------------------------------------------------------- - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from GEOSgcm files: - ! - ! FCST/Hindcast - ! - ! force_array(:, 1) = PRECTOTCORR kg/m2/s ([gauge-corr]_total_precipitation, rainfall+snowfall) - ! force_array(:, 2) = LWGAB W/m2 (surface_absorbed_longwave_radiation) - ! force_array(:, 3) = SWGDN W/m2 (surface_incoming_shortwave_flux) - ! force_array(:, 4) = PARDR W/m2 (surface_downwelling_par_beam_flux) - ! force_array(:, 5) = PARDF W/m2 (surface_downwelling_par_diffuse_flux) - ! force_array(:, 6) = PS Pa (surface_pressure) - ! force_array(:, 7) = QLML kg/kg (surface_specific_humidity) - ! force_array(:, 8) = TLML K (surface_air_temperature) - ! force_array(:, 9) = SPEED m/s (surface_wind_speed) - ! force_array(:,10) = HLML m (surface_layer_height) - - ! AODAS - ! - ! force_array(:, 1) = TPREC kg/m2/s (total_precipitation, rainfall+snowfall) - ! force_array(:, 2) = LWS W/m2 (surface_absorbed_longwave_radiation) - ! force_array(:, 3) = SWGDWN W/m2 (surface_incoming_shortwave_flux) - ! force_array(:, 4) = PS Pa (surface_pressure) - ! force_array(:, 5) = QA kg/kg (surface_specific_humidity) - ! force_array(:, 6) = TA K (surface_air_temperature) - ! force_array(:, 7) = SPEED m/s (surface_wind_speed) - ! force_array(:, 8) = HLML m (surface_layer_height) - - if (FCST) then - met_force_new%LWdown = force_array(:, 2) - met_force_new%SWdown = force_array(:, 3) - met_force_new%PARdrct = force_array(:, 4) - met_force_new%PARdffs = force_array(:, 5) - met_force_new%Psurf = force_array(:, 6) - met_force_new%Qair = force_array(:, 7) - met_force_new%Tair = force_array(:, 8) - met_force_new%Wind = force_array(:, 9) - met_force_new%RefH = force_array(:,10) - elseif (AODAS) then - met_force_new%LWdown = force_array(:, 2) - met_force_new%SWdown = force_array(:, 3) - met_force_new%Psurf = force_array(:, 4) - met_force_new%Qair = force_array(:, 5) - met_force_new%Tair = force_array(:, 6) - met_force_new%Wind = force_array(:, 7) - met_force_new%RefH = force_array(:, 8) - end if - - ! rainfall - ! Rainf = convective rainfall + large-scale rainfall (total liquid precip) - ! Snowf = convective snowfall + large-scale snowfall (total solid precip) - - ! revised to compute precipitation components from total precipitation - ! and air temperature because pre-processing of precipitation components - ! was faulty - 14 Jun 2021 - - do k=1,N_catd - - ! "where" statements would probably be better than a do loop, but left for later - ! - reichle, 14 Jun 2021 - - Tair_tmp = met_force_new(k)%Tair - - Totprec_tmp = force_array(k,1) ! total precip is element 1 in FCST and AODAS - - if ( (abs(Tair_tmp -nodata_GEOSgcm) 0C - - met_force_new(k)%Snowf = 0. - met_force_new(k)%Rainf = Totprec_tmp - - end if - - ! Assign 0 to convective rainfall because only the total rainfall is used by the - ! Catchment model (for now). This may have to be revised for future model versions. - - met_force_new(k)%Rainf_C = 0. - - end if - - end do - - deallocate(force_array) - deallocate(GEOSgcm_name) - - end subroutine get_GEOSs2s - - ! ************************************************************************* - - subroutine get_GEOS( date_time, force_dtstep, met_path, met_tag, & - N_catd, tile_coord, MET_HINTERP, AEROSOL_DEPOSITION, & - supported_option_MET_HINTERP, & - supported_option_AEROSOL_DEPOSITION, & - met_force_new, nodata_forcing, PAR_available, MERRA_file_specs, & - init ) - - ! reichle, 5 March 2008 - adapted from get_GEOSgcm_gfio to work with DAS - ! and MERRA file specs - ! reichle, 21 March 2008 - overhauled for time-interpolation of Tair etc - ! when read from MERRA tavg files - ! qliu+reichle, 12 Aug 2008 - for MERRA, use TLML, QLML, ULML, VLML instead - ! of 2m variables - ! - different number of variables for DAS, MERRA - ! - ! reichle, 23 Feb 2009 - read ParDrct, ParDffs from MERRA files - ! - new output variable "MERRA_file_specs" - ! - ! reichle, 5 Mar 2009 - deleted ParDrct, ParDffs after testing found no impact - ! - ! reichle, 1 Dec 2009 - optionally read netcdf files with corrected precip - ! - parse "met_tag" for seamless integration across - ! MERRA streams; assemble MERRA "met_path" - ! - use only "lfo" files for MERRA - ! - ! reichle, 20 Dec 2011 - reinstated "PARdrct" and "PARdffs" for MERRA-Land file specs - ! - ! reichle, 27 Feb 2012 - renamed subroutine - ! - revised "DAS_defs", now called "G5DAS_defs" - ! - parse "met_tag" to decide whether to use "MERRA_defs" - ! (rather than check for presence of "diag_sfc" file) - ! pchakrab+reichle, - ! 13 Jan 2014 - added bilinear interpolation option - ! - ! reichle, 27 Jul 2015 - added MERRA-2 forcing - ! - ! jkolassa+reichle, 17 Dec 2019 - fixed "met_path", "prec_path", and "met_tag" at stream boundaries - ! (for MERRA-2, always point to publicly available files) - ! - updated comments - ! - ! qliu+reichle, 5 Dec 2023 - added GEOS-IT - ! - ! ----------------------------------- - ! - ! Read surface met forcing from MERRA, MERRA-2 or GEOS-5 DAS (i.e., FP) based on parsing of "met_tag". - ! - ! SEE "LDASsa_default_inputs_driver.nml" for more documentation of "met_tag" - ! and "met_path". - ! - ! Try reading met files in directory "met_path/" first. - ! If this fails, try again in "met_path/met_tag/*/Yyyyy/Mmm/" - ! - ! Read GEOSgcm (GEOS5) hdf or nc4 files (or nc files for corrected MERRA precip) - ! and extract forcings in tile space (uses nearest neighbor interpolation). - ! - ! Time convention for "met_force_new" as stated in get_forcing() does - ! NOT apply to get_GEOS(), which reads forcing states (such as - ! Tair) at date_time (=date_time_inst) and "previous" (or "backward-looking") forcing fluxes - ! (such as SWdown) at date_time_bkwd, rather than "subsequent" (or "forward-looking") - ! forcing fluxes (except for init=.true.). - ! - ! Example: if date_time=1z, met_force_new will contain TLML at 1z - ! and SWGDN for average from 0z to 1z (as stored in 0:30z file) - ! - ! When LDASsa is integrated within the coupled GEOS5 DAS, initial (time-avg) - ! "tavg1_2d_*_Nx" files are not available. Use optional "init" flag to - ! deal with this situation. [NOT SURE THIS STILL MAKES SENSE, reichle, 17 Dec 2019] - - use netcdf - implicit none - - ! intent in: - - type(date_time_type), intent(in) :: date_time ! date/time of 'inst' forcing - - integer, intent(in) :: force_dtstep - - ! e.g.: met_path = '/land/reichle/GEOS5_land_forcings/' - ! met_tag = 'js4rt_b7p1' (GEOSgcm exp label) - - character(*), intent(in) :: met_path - character(*), intent(in) :: met_tag - - integer, intent(in) :: N_catd, MET_HINTERP, AEROSOL_DEPOSITION - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - ! intent inout: - - logical, intent(inout) :: supported_option_MET_HINTERP - logical, intent(inout) :: supported_option_AEROSOL_DEPOSITION - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - ! intent out: - - real, intent(out) :: nodata_forcing - - logical, intent(out) :: PAR_available - logical, intent(out) :: MERRA_file_specs ! original MERRA specs, not MERRA-2 - - ! optional: - - logical, intent(in), optional :: init - - ! ----------------------------------------- - - ! local variables - - integer, parameter :: N_G5DAS_vars = 12 ! same as for MERRA-2 (excl Aerosol vars) - integer, parameter :: N_MERRA_vars = 13 - integer, parameter :: N_MERRA2_vars = 12 ! same as for G5DAS (excl Aerosol vars) - integer, parameter :: N_Aerosol_vars = 60 ! additional aerosol forcing vars for GOSWIM (w/ MERRA-2 only for now) - - integer, parameter :: N_MERRA2plusAerosol_vars = N_MERRA2_vars + N_Aerosol_vars - - integer, parameter :: N_defs_cols = 5 - - real, parameter :: nodata_GEOSgcm = 1.e15 - - character(40), dimension(N_G5DAS_vars, N_defs_cols) :: G5DAS_defs - character(40), dimension(N_G5DAS_vars, N_defs_cols) :: GEOSIT_defs - character(40), dimension(N_MERRA_vars, N_defs_cols) :: MERRA_defs - character(40), dimension(N_MERRA2plusAerosol_vars, N_defs_cols) :: M2INT_defs - character(40), dimension(N_MERRA2plusAerosol_vars, N_defs_cols) :: M2COR_defs - - character(40), dimension(:,:), allocatable :: GEOSgcm_defs - - ! NOTE: met_path, prec_path, and met_tag for current ('inst') time and fwd and bkwd 'tavg' - ! times differ at stream boundaries -- jkolassa+reichle, 17 Dec 2019 - - type(date_time_type) :: date_time_inst, date_time_fwd, date_time_bkwd, date_time_tmp - - character(200) :: met_path_inst, met_path_fwd, met_path_bkwd, met_path_tmp - character(200) :: prec_path_inst, prec_path_fwd, prec_path_bkwd, prec_path_tmp - character( 80) :: met_tag_inst, met_tag_fwd, met_tag_bkwd, met_tag_tmp - - character( 3) :: met_file_ext - character( 3) :: precip_corr_file_ext - - integer :: N_GEOSgcm_vars, N_lon_tmp, N_lat_tmp - - real :: this_lon, this_lat - - real :: tol - - real :: fnbr(2,2) - - integer, pointer :: i1(:), i2(:), j1(:), j2(:) - real, pointer :: x1(:), x2(:), y1(:), y2(:) - - real, dimension(:,:), allocatable :: force_array - - integer :: j, k, GEOSgcm_var, fid, km, lm, nvars, ngatts, rc, YYYYMMDD, HHMMSS - - logical :: minimize_shift, use_prec_corr, use_Predictor, tmp_init - - logical :: daily_met_files, daily_precipcorr_files - - integer :: nv_id, ierr, icount(3), istart(3), lonid, latid - - character(len=*), parameter :: Iam = 'get_GEOS' - integer :: status - character(len=400) :: err_msg - character(len=300) :: fname_full - logical :: file_exists, single_time_in_file - - ! ----------------------------------------------------------------------- - ! - ! define GEOS5 file specs - ! - ! columns of GEOSgcm_defs are as follows: - ! 1 - short variable name in gfio file - ! 2 - averaging mode in G5DAS/MERRA file ('tavg' or 'inst') - ! 3 - file tag (eg. 'bkg.sfc' or 'diag_sfc', or 'tavg1_2d_rad_Nx') - ! 4 - file dir ('ana' or 'diag') - ! 5 - treated as S="state" or F="flux" in subroutine interpolate_to_timestep() - - ! G5DAS (a.k.a. FP) file specs (default, unless otherwise specified via "met_tag") - ! - ! lfo_inst/tavg data available from 11 Jun 2013 (start of GEOS-5 ADAS version 5.11) - - G5DAS_defs( 1,:)=[character(len=40):: 'SWGDN ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 2,:)=[character(len=40):: 'LWGAB ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 3,:)=[character(len=40):: 'PARDR ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 4,:)=[character(len=40):: 'PARDF ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 5,:)=[character(len=40):: 'PRECCU ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 6,:)=[character(len=40):: 'PRECLS ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 7,:)=[character(len=40):: 'PRECSNO ','tavg','tavg1_2d_lfo_Nx','diag','F'] - G5DAS_defs( 8,:)=[character(len=40):: 'PS ','inst','inst1_2d_lfo_Nx','diag','S'] - G5DAS_defs( 9,:)=[character(len=40):: 'HLML ','inst','inst1_2d_lfo_Nx','diag','S'] - G5DAS_defs(10,:)=[character(len=40):: 'TLML ','inst','inst1_2d_lfo_Nx','diag','S'] - G5DAS_defs(11,:)=[character(len=40):: 'QLML ','inst','inst1_2d_lfo_Nx','diag','S'] - G5DAS_defs(12,:)=[character(len=40):: 'SPEEDLML','inst','inst1_2d_lfo_Nx','diag','S'] - - ! ----------------------------------------------------------------------- - ! - ! define GEOS-IT file specs - ! - ! same as G5DAS except for file tag (column 3) - - GEOSIT_defs = G5DAS_defs - - ! GEOSIT character(40): - ! - ! 1 2 3 4 - ! 1234567890123456789012345678901234567890 - - GEOSIT_defs( 1,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 2,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 3,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 4,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 5,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 6,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 7,3) = 'lfo_tavg_1hr_glo_L576x361_slv ' - GEOSIT_defs( 8,3) = 'lfo_inst_1hr_glo_L576x361_slv ' - GEOSIT_defs( 9,3) = 'lfo_inst_1hr_glo_L576x361_slv ' - GEOSIT_defs(10,3) = 'lfo_inst_1hr_glo_L576x361_slv ' - GEOSIT_defs(11,3) = 'lfo_inst_1hr_glo_L576x361_slv ' - GEOSIT_defs(12,3) = 'lfo_inst_1hr_glo_L576x361_slv ' - - - ! MERRA-2 file specs with uncorrected (AGCM) precip from the "int" Collection - ! (ie, the precip generated by the AGCM within the MERRA-2 system) - ! - ! NOTE: This is *NOT* the precipitation seen by the land surface in the MERRA-2 system. - ! - ! NOTE: Use SWGDN from the "rad" Collection because SWGDN in MERRA-2 "lfo" - ! is averaged over land tiles only, unlike all other variables, - ! which are global, as is SWGDN in the FP "lfo" files. - ! - reichle, 7 Dec 2015 - - M2INT_defs( 1,:)=[character(len=40):: 'SWGDN ','tavg','tavg1_2d_rad_Nx','diag','F'] ! use "rad" Collection - M2INT_defs( 2,:)=[character(len=40):: 'LWGAB ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2INT_defs( 3,:)=[character(len=40):: 'PARDR ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2INT_defs( 4,:)=[character(len=40):: 'PARDF ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2INT_defs( 5,:)=[character(len=40):: 'PRECCU ','tavg','tavg1_2d_int_Nx','diag','F'] ! uncorrected - M2INT_defs( 6,:)=[character(len=40):: 'PRECLS ','tavg','tavg1_2d_int_Nx','diag','F'] ! uncorrected - M2INT_defs( 7,:)=[character(len=40):: 'PRECSN ','tavg','tavg1_2d_int_Nx','diag','F'] ! uncorrected - M2INT_defs( 8,:)=[character(len=40):: 'PS ','inst','inst1_2d_lfo_Nx','diag','S'] - M2INT_defs( 9,:)=[character(len=40):: 'HLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2INT_defs(10,:)=[character(len=40):: 'TLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2INT_defs(11,:)=[character(len=40):: 'QLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2INT_defs(12,:)=[character(len=40):: 'SPEEDLML','inst','inst1_2d_lfo_Nx','diag','S'] - - M2INT_defs(13,:)=[character(len=40):: 'DUDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(14,:)=[character(len=40):: 'DUDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(15,:)=[character(len=40):: 'DUDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(16,:)=[character(len=40):: 'DUDP004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(17,:)=[character(len=40):: 'DUDP005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(18,:)=[character(len=40):: 'DUSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(19,:)=[character(len=40):: 'DUSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(20,:)=[character(len=40):: 'DUSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(21,:)=[character(len=40):: 'DUSV004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(22,:)=[character(len=40):: 'DUSV005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(23,:)=[character(len=40):: 'DUWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(24,:)=[character(len=40):: 'DUWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(25,:)=[character(len=40):: 'DUWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(26,:)=[character(len=40):: 'DUWT004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(27,:)=[character(len=40):: 'DUWT005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(28,:)=[character(len=40):: 'DUSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(29,:)=[character(len=40):: 'DUSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(30,:)=[character(len=40):: 'DUSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(31,:)=[character(len=40):: 'DUSD004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(32,:)=[character(len=40):: 'DUSD005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(33,:)=[character(len=40):: 'BCDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(34,:)=[character(len=40):: 'BCDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(35,:)=[character(len=40):: 'BCSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(36,:)=[character(len=40):: 'BCSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(37,:)=[character(len=40):: 'BCWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(38,:)=[character(len=40):: 'BCWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(39,:)=[character(len=40):: 'BCSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(40,:)=[character(len=40):: 'BCSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(41,:)=[character(len=40):: 'OCDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(42,:)=[character(len=40):: 'OCDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(43,:)=[character(len=40):: 'OCSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(44,:)=[character(len=40):: 'OCSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(45,:)=[character(len=40):: 'OCWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(46,:)=[character(len=40):: 'OCWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(47,:)=[character(len=40):: 'OCSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(48,:)=[character(len=40):: 'OCSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(49,:)=[character(len=40):: 'SUDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(50,:)=[character(len=40):: 'SUSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(51,:)=[character(len=40):: 'SUWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(52,:)=[character(len=40):: 'SUSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(53,:)=[character(len=40):: 'SSDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(54,:)=[character(len=40):: 'SSDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(55,:)=[character(len=40):: 'SSDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(56,:)=[character(len=40):: 'SSDP004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(57,:)=[character(len=40):: 'SSDP005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(58,:)=[character(len=40):: 'SSSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(59,:)=[character(len=40):: 'SSSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(60,:)=[character(len=40):: 'SSSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(61,:)=[character(len=40):: 'SSSV004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(62,:)=[character(len=40):: 'SSSV005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(63,:)=[character(len=40):: 'SSWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(64,:)=[character(len=40):: 'SSWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(65,:)=[character(len=40):: 'SSWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(66,:)=[character(len=40):: 'SSWT004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(67,:)=[character(len=40):: 'SSWT005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(68,:)=[character(len=40):: 'SSSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(69,:)=[character(len=40):: 'SSSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(70,:)=[character(len=40):: 'SSSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(71,:)=[character(len=40):: 'SSSD004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2INT_defs(72,:)=[character(len=40):: 'SSSD005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - - - ! MERRA-2 file specs with corrected precip, which could be either - ! - native (ie, the precip seen by the land surface in the MERRA-2 system), or - ! - corrected in post-processing using MERRA-2 (uncorrected) precip as the background - ! The default is to use MERRA-2 native precip corrections. If the "met_tag" includes - ! an optional "__prec[xyz]" string, the precip corrections specified by [xyz] are used. - ! - ! NOTE: This is *NOT* the same as the corrected precipitation of the off-line - ! spin-up run used to generate the MERRA-2 land surface initial conditions - ! for each stream. These precip files used for that have a MERRA background. - ! - ! NOTE: Use SWGDN from the "rad" Collection (see comment above). - - M2COR_defs( 1,:)=[character(len=40):: 'SWGDN ','tavg','tavg1_2d_rad_Nx','diag','F'] ! use "rad" Collection - M2COR_defs( 2,:)=[character(len=40):: 'LWGAB ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2COR_defs( 3,:)=[character(len=40):: 'PARDR ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2COR_defs( 4,:)=[character(len=40):: 'PARDF ','tavg','tavg1_2d_lfo_Nx','diag','F'] - M2COR_defs( 5,:)=[character(len=40):: 'PRECCUCORR ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! MERRA-2 built-in corrections - M2COR_defs( 6,:)=[character(len=40):: 'PRECLSCORR ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! MERRA-2 built-in corrections - M2COR_defs( 7,:)=[character(len=40):: 'PRECSNOCORR','tavg','tavg1_2d_lfo_Nx','diag','F'] ! MERRA-2 built-in corrections - M2COR_defs( 8,:)=[character(len=40):: 'PS ','inst','inst1_2d_lfo_Nx','diag','S'] - M2COR_defs( 9,:)=[character(len=40):: 'HLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2COR_defs(10,:)=[character(len=40):: 'TLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2COR_defs(11,:)=[character(len=40):: 'QLML ','inst','inst1_2d_lfo_Nx','diag','S'] - M2COR_defs(12,:)=[character(len=40):: 'SPEEDLML ','inst','inst1_2d_lfo_Nx','diag','S'] - - M2COR_defs(13,:)=[character(len=40):: 'DUDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(14,:)=[character(len=40):: 'DUDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(15,:)=[character(len=40):: 'DUDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(16,:)=[character(len=40):: 'DUDP004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(17,:)=[character(len=40):: 'DUDP005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(18,:)=[character(len=40):: 'DUSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(19,:)=[character(len=40):: 'DUSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(20,:)=[character(len=40):: 'DUSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(21,:)=[character(len=40):: 'DUSV004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(22,:)=[character(len=40):: 'DUSV005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(23,:)=[character(len=40):: 'DUWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(24,:)=[character(len=40):: 'DUWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(25,:)=[character(len=40):: 'DUWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(26,:)=[character(len=40):: 'DUWT004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(27,:)=[character(len=40):: 'DUWT005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(28,:)=[character(len=40):: 'DUSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(29,:)=[character(len=40):: 'DUSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(30,:)=[character(len=40):: 'DUSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(31,:)=[character(len=40):: 'DUSD004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(32,:)=[character(len=40):: 'DUSD005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(33,:)=[character(len=40):: 'BCDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(34,:)=[character(len=40):: 'BCDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(35,:)=[character(len=40):: 'BCSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(36,:)=[character(len=40):: 'BCSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(37,:)=[character(len=40):: 'BCWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(38,:)=[character(len=40):: 'BCWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(39,:)=[character(len=40):: 'BCSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(40,:)=[character(len=40):: 'BCSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(41,:)=[character(len=40):: 'OCDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(42,:)=[character(len=40):: 'OCDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(43,:)=[character(len=40):: 'OCSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(44,:)=[character(len=40):: 'OCSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(45,:)=[character(len=40):: 'OCWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(46,:)=[character(len=40):: 'OCWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(47,:)=[character(len=40):: 'OCSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(48,:)=[character(len=40):: 'OCSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(49,:)=[character(len=40):: 'SUDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(50,:)=[character(len=40):: 'SUSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(51,:)=[character(len=40):: 'SUWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(52,:)=[character(len=40):: 'SUSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(53,:)=[character(len=40):: 'SSDP001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(54,:)=[character(len=40):: 'SSDP002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(55,:)=[character(len=40):: 'SSDP003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(56,:)=[character(len=40):: 'SSDP004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(57,:)=[character(len=40):: 'SSDP005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(58,:)=[character(len=40):: 'SSSV001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(59,:)=[character(len=40):: 'SSSV002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(60,:)=[character(len=40):: 'SSSV003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(61,:)=[character(len=40):: 'SSSV004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(62,:)=[character(len=40):: 'SSSV005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(63,:)=[character(len=40):: 'SSWT001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(64,:)=[character(len=40):: 'SSWT002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(65,:)=[character(len=40):: 'SSWT003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(66,:)=[character(len=40):: 'SSWT004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(67,:)=[character(len=40):: 'SSWT005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(68,:)=[character(len=40):: 'SSSD001 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(69,:)=[character(len=40):: 'SSSD002 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(70,:)=[character(len=40):: 'SSSD003 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(71,:)=[character(len=40):: 'SSSD004 ','tavg','tavg1_2d_adg_Nx','diag','F'] - M2COR_defs(72,:)=[character(len=40):: 'SSSD005 ','tavg','tavg1_2d_adg_Nx','diag','F'] - - - ! MERRA file specs - ! - ! use *only* "tavg" files b/c "bkg.sfc" files are available only every 6h - ! - ! - replaced 'SWGNT' from MERRA 'rad' file with 'SWLAND' from 'lnd' file - ! - changed 'ULML', 'VLML' from 'S' to 'F' - ! - added 'PARDR', 'PARDF' - ! reichle, 24 Feb 2009 - ! - deleted 'PARDR', 'PARDF' after testing showed no impact (REINSTATED Dec 2011) - ! reichle, 5 Mar 2009 - ! - use "lfo" files - ! reichle, 1 Dec 2009 - - ! MERRA - ! collection - - MERRA_defs( 1,:)=[character(len=40):: 'SWGDN ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "rad" - MERRA_defs( 2,:)=[character(len=40):: 'LWGAB ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "rad" - MERRA_defs( 3,:)=[character(len=40):: 'PARDR ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "lnd" - MERRA_defs( 4,:)=[character(len=40):: 'PARDF ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "lnd" - MERRA_defs( 5,:)=[character(len=40):: 'PRECTOT','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "lnd" - MERRA_defs( 6,:)=[character(len=40):: 'PRECCON','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "flx" - MERRA_defs( 7,:)=[character(len=40):: 'PRECSNO','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "lnd" - MERRA_defs( 8,:)=[character(len=40):: 'PS ','tavg','tavg1_2d_lfo_Nx','diag','S'] ! "slv" - MERRA_defs( 9,:)=[character(len=40):: 'HLML ','tavg','tavg1_2d_lfo_Nx','diag','S'] ! "flx" - MERRA_defs(10,:)=[character(len=40):: 'TLML ','tavg','tavg1_2d_lfo_Nx','diag','S'] ! "flx" - MERRA_defs(11,:)=[character(len=40):: 'QLML ','tavg','tavg1_2d_lfo_Nx','diag','S'] ! "flx" - MERRA_defs(12,:)=[character(len=40):: 'ULML ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "flx" - MERRA_defs(13,:)=[character(len=40):: 'VLML ','tavg','tavg1_2d_lfo_Nx','diag','F'] ! "flx" - - ! -------------------------------------------------------------------- - ! - ! preparations - - tmp_init = .false. - - if (present(init)) tmp_init = init - - use_prec_corr = .false. ! use corrected precip dataset (other than native "M2COR_defs") - - ! use same nodata-value on input and output so that "nodata-check" can be - ! omitted when no arithmetic is needed - - nodata_forcing = nodata_GEOSgcm - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! all GEOS forcing datasets provide PAR (so far) - - PAR_available = .true. - - ! input variable "date_time" is for reading instantaneous ('inst') forcing variables - - date_time_inst = date_time - - ! assemble date/time structures for tavg files - ! (e.g. 0z-1z time average is in file with 0:30z timestamp) - - date_time_bkwd = date_time_inst - - call augment_date_time( -force_dtstep/2, date_time_bkwd ) - - date_time_fwd = date_time_inst - - call augment_date_time( +force_dtstep/2, date_time_fwd ) - - ! --------------------------------------------------------------------------- - - ! determine which file specs should be used (MERRA, MERRA-2, or G5DAS) - - ! initialize to most likely values, overwrite below as needed - - MERRA_file_specs = .false. - - met_file_ext = 'nc4' - - daily_met_files = .false. - - precip_corr_file_ext = 'nc4' - - if (met_tag(4:8)=='merra') then ! MERRA - - ! AEROSOL_DEPOSITION /= 0 is NOT supported - - N_GEOSgcm_vars = N_MERRA_vars - - allocate(GEOSgcm_defs(N_GEOSgcm_vars,N_defs_cols)) - - GEOSgcm_defs(1:N_GEOSgcm_vars,:) = MERRA_defs - - MERRA_file_specs = .true. - - met_file_ext = 'hdf' - - precip_corr_file_ext = 'nc ' - - call parse_MERRA_met_tag( met_path, met_tag, date_time_inst, & - met_path_inst, prec_path_inst, met_tag_inst, use_prec_corr ) - - call parse_MERRA_met_tag( met_path, met_tag, date_time_fwd, & - met_path_fwd, prec_path_fwd, met_tag_fwd, use_prec_corr ) - - call parse_MERRA_met_tag( met_path, met_tag, date_time_bkwd, & - met_path_bkwd, prec_path_bkwd, met_tag_bkwd, use_prec_corr ) - - elseif (met_tag(1:2)=='M2') then ! MERRA-2 - - select case (AEROSOL_DEPOSITION) - - case (0) ! no aerosols (default) - - N_GEOSgcm_vars = N_MERRA2_vars - - case (1) ! with aerosols - - supported_option_AEROSOL_DEPOSITION = .true. - - N_GEOSgcm_vars = N_MERRA2plusAerosol_vars - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unsupported AEROSOL_DEPOSITION option') - - end select - - allocate(GEOSgcm_defs(N_GEOSgcm_vars,N_defs_cols)) - - if (met_tag(1:5)=='M2INT') then - - GEOSgcm_defs(1:N_GEOSgcm_vars,:) = M2INT_defs(1:N_GEOSgcm_vars,:) - - elseif (met_tag(1:5)=='M2COR') then - - GEOSgcm_defs(1:N_GEOSgcm_vars,:) = M2COR_defs(1:N_GEOSgcm_vars,:) - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown "M2[xxx]" met_tag') - - end if - - daily_met_files = .true. - - call parse_MERRA2_met_tag( met_path, met_tag, date_time_inst, & - met_path_inst, prec_path_inst, met_tag_inst, use_prec_corr ) - - call parse_MERRA2_met_tag( met_path, met_tag, date_time_fwd, & - met_path_fwd, prec_path_fwd, met_tag_fwd, use_prec_corr ) - - call parse_MERRA2_met_tag( met_path, met_tag, date_time_bkwd, & - met_path_bkwd, prec_path_bkwd, met_tag_bkwd, use_prec_corr ) - - else ! GEOS ADAS (FP) - - ! AEROSOL_DEPOSITION /= 0 is NOT supported - - N_GEOSgcm_vars = N_G5DAS_vars - - allocate(GEOSgcm_defs(N_GEOSgcm_vars,N_defs_cols)) - - if ( (index(met_tag, 'GEOSIT') > 0) .or. (index(met_tag, 'geosit') > 0) ) then - GEOSgcm_defs(1:N_G5DAS_vars,:) = GEOSIT_defs - else - GEOSgcm_defs(1:N_G5DAS_vars,:) = G5DAS_defs - end if - - call parse_G5DAS_met_tag( met_path, met_tag, date_time_inst, & - met_path_inst, prec_path_inst, met_tag_inst, use_prec_corr, & - use_Predictor ) - - call parse_G5DAS_met_tag( met_path, met_tag, date_time_fwd, & - met_path_fwd, prec_path_fwd, met_tag_fwd, use_prec_corr, & - use_Predictor ) - - call parse_G5DAS_met_tag( met_path, met_tag, date_time_bkwd, & - met_path_bkwd, prec_path_bkwd, met_tag_bkwd, use_prec_corr, & - use_Predictor ) - - if (use_Predictor) then - - ! append "+-" to GCM file tag (ie, replace "Nx" with "Nx+-") - - do j=1,N_GEOSgcm_vars - - GEOSgcm_defs(j,3) = trim(GEOSgcm_defs(j,3)) // '+-' - - end do - - end if - - end if - - allocate(force_array(N_catd,N_GEOSgcm_vars)) - - ! --------------------------------------------------------------------------- - ! - ! get forcing data - - do GEOSgcm_var = 1,N_GEOSgcm_vars - - ! open GEOS file (G5DAS or MERRA or MERRA-2) - ! - ! Initial "tavg1_2d_*_Nx" files may not be available. In this case, - ! use first available file. For G5DAS file specs, only "PS" is affected - ! (because the fluxes from the missing initial "tavg1_2d_*_Nx" file are not needed). - ! For MERRA file specs, air temp, humidity, wind, and pressure are affected. - ! - ! if (init==.false.) the j loop ends for j=1 (either successfully open file - ! or stop). - ! - ! if (init==.true.) make second attempt (j=2) to allow for possibly - ! missing "diag_sfc" or "tavg" file at date_time_bkwd (and try reading - ! the file at date_time_fwd). - - do j=1,2 - - ! determine time stamp on file and corresponding met_path, prec_path, & met_tag - - if (trim(GEOSgcm_defs(GEOSgcm_var,2))=='tavg') then - - if (j==1) then - date_time_tmp = date_time_bkwd - met_path_tmp = met_path_bkwd - prec_path_tmp = prec_path_bkwd - met_tag_tmp = met_tag_bkwd - else - date_time_tmp = date_time_fwd - met_path_tmp = met_path_fwd - prec_path_tmp = prec_path_fwd - met_tag_tmp = met_tag_fwd - end if - - else if (trim(GEOSgcm_defs(GEOSgcm_var,2))=='inst' ) then - - date_time_tmp = date_time_inst - met_path_tmp = met_path_inst - prec_path_tmp = prec_path_inst - met_tag_tmp = met_tag_inst - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown GEOSgcm_defs(2)') - - end if - - YYYYMMDD = date_time_tmp%year*10000+date_time_tmp%month*100+date_time_tmp%day - HHMMSS = date_time_tmp%hour*10000+date_time_tmp%min*100 +date_time_tmp%sec - - ! determine forcing file name (with path) - - if ( (use_prec_corr) .and. (GEOSgcm_defs(GEOSgcm_var,1)(1:4)=='PREC') ) then - - call get_GEOS_corr_prec_filename(fname_full,file_exists,date_time_tmp, & - prec_path_tmp, met_tag_tmp, GEOSgcm_defs(GEOSgcm_var,:), precip_corr_file_ext, daily_precipcorr_files) - - single_time_in_file = .not. daily_precipcorr_files ! corr precip files are always hourly (incl. MERRA-2) - - else - - call get_GEOS_forcing_filename(fname_full,file_exists,date_time_tmp, & - daily_met_files, met_path_tmp, met_tag_tmp, & - GEOSgcm_defs(GEOSgcm_var,:), met_file_ext) - - single_time_in_file = .not. daily_met_files ! MERRA-2 files are daily files - - end if - - if ( file_exists) then - - exit ! exit j loop after successfully finding file - - elseif ( & - (j==1) .and. & - (tmp_init) .and. & - (trim(GEOSgcm_defs(GEOSgcm_var,2))=='tavg') .and. & - (root_logit) ) then - - if (.not. MERRA_file_specs) write (logunit,'(400A)') & - 'NOTE: Initialization. Data from tavg file are not used ' // & - 'with lfo inst/tavg forcing, but dummy values must be ' // & - 'read from some file for backward compatibility with ' // & - 'MERRA forcing.' - - write (logunit,*) 'try again with different file...' - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'error finding met forcing file') - - end if - - end do ! j=1,2 - - ! open file, extract coord info, prep horizontal interpolation info (if not done already) - - call GEOS_openfile(FileOpenedHash,fname_full,fid,tile_coord,MET_HINTERP) - - !fid = ptrNode%fid - - i1=>local_info%i1 - i2=>local_info%i2 - j1=>local_info%j1 - j2=>local_info%j2 - x1=>local_info%x1 - x2=>local_info%x2 - y1=>local_info%y1 - y2=>local_info%y2 - - ! ---------------------------------------------- - ! - ! process grid dimensions - ! NOTE: corrected precipitation forcing from separate netcdf can be on different grid - - ! init shared memory - N_lon_tmp = -1 - N_lat_tmp = -1 - if (associated(ptrShForce)) then - N_lon_tmp = size(ptrShForce,1) - N_lat_tmp = size(ptrShForce,2) - endif - if ( N_lon_tmp /= local_info%N_lon .or. & - N_lat_tmp /= local_info%N_lat ) then - call MAPL_SyncSharedMemory(rc=status) - VERIFY_(status) - if (associated(ptrShForce)) then - call MAPL_DeallocNodeArray(ptrShForce,rc=status) - VERIFY_(status) - endif - call MAPL_AllocateShared(ptrShForce,(/local_info%N_lon,local_info%N_lat/),TransRoot= .true.,rc=status) - VERIFY_(status) - call MAPL_SyncSharedMemory(rc=status) - VERIFY_(status) - end if - - ! ---------------------------------------------- - ! - ! read global gridded field of given variable - - call LDAS_GetVar( fid, trim(GEOSgcm_defs(GEOSgcm_var,1)), & - YYYYMMDD, HHMMSS, single_time_in_file, local_info, ptrShForce, rc) - if (rc<0) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'error reading gfio file') - endif - - ! interpolate to tile space - - select case (MET_HINTERP) - - case (0) ! nearest-neighbor interpolation - - do k=1,N_catd - - force_array(k,GEOSgcm_var) = ptrShForce(i1(k), j1(k)) - - end do - - case (1) ! bilinear interpolation - - supported_option_MET_HINTERP = .true. - - do k=1,N_catd - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - fnbr(1,1) = ptrShForce(i1(k),j1(k)) - fnbr(1,2) = ptrShForce(i1(k),j2(k)) - fnbr(2,1) = ptrShForce(i2(k),j1(k)) - fnbr(2,2) = ptrShForce(i2(k),j2(k)) - - !DEC$ FORCEINLINE - force_array(k,GEOSgcm_var) = BilinearInterpolation(this_lon, this_lat, & - x1(k), x2(k), y1(k), y2(k), fnbr, nodata_forcing, tol) - end do - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unsupported MET_HINTERP option') - - end select - - ! ---------------------------------------------- - ! - ! For non-flux "S" forcing variables that are read from MERRA "tavg" files - ! *optionally* read forward-looking 'tavg' file (if available) and interpolate - ! in time. - ! - ! Doing so minimizes the time shift between the "true" (but unavailable) MERRA - ! instantaneous forcing values and their off-line time interpolated equivalent - ! -- at the expense of a dampened diurnal cycle. - ! - ! reichle+qliu, 8 Oct 2008 - - minimize_shift = .true. - - ! minimize_shift should *only* affect "MERRA" forcing - reichle, 27 Feb 2012 - - if ((minimize_shift) .and. & - (trim(GEOSgcm_defs(GEOSgcm_var,2))=='tavg') .and. & - (trim(GEOSgcm_defs(GEOSgcm_var,5))=='S') ) then - - date_time_tmp = date_time_fwd - - ! open file - - call get_GEOS_forcing_filename( fname_full,file_exists,date_time_tmp, daily_met_files, & - met_path_tmp, met_tag_tmp, & - GEOSgcm_defs(GEOSgcm_var,:), met_file_ext) - - call GEOS_openfile(FileOpenedHash,fname_full,fid,tile_coord,MET_HINTERP) - - !fid = ptrNode%fid - - if (fid>0) then - - i1=>local_info%i1 - i2=>local_info%i2 - j1=>local_info%j1 - j2=>local_info%j2 - x1=>local_info%x1 - x2=>local_info%x2 - y1=>local_info%y1 - y2=>local_info%y2 - - YYYYMMDD = date_time_tmp%year*10000+date_time_tmp%month*100+date_time_tmp%day - HHMMSS = date_time_tmp%hour*10000+date_time_tmp%min*100 +date_time_tmp%sec - - ! read global gridded field of given variable - - call LDAS_GetVar( fid, trim(GEOSgcm_defs(GEOSgcm_var,1)), & - YYYYMMDD, HHMMSS, .false., local_info, ptrShForce, rc) - - if (rc<0) then - err_msg = 'error reading gfio file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! interpolate to tile space and in time - - select case (MET_HINTERP) - - case (0) ! nearest-neighbor interpolation - - do k=1,N_catd - - if ( abs(force_array(k,GEOSgcm_var) -nodata_GEOSgcm)0) - - end if ! if (minimize_shift) .and. [...] - - end do ! do GEOSgcm_var = 1,N_GEOSgcm_vars - - call FileOpenedHash%free( GEOS_closefile,.false. ) - - deallocate(GEOSgcm_defs) - - ! -------------------------------------------------------------------- - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from GEOSgcm files: - ! - ! G5DAS - ! M2INT MERRA - ! M2COR - ! - ! force_array(:, 1) = SWGDN SWGDN W/m2 (downward shortwave) - ! force_array(:, 2) = LWGAB LWGAB W/m2 ("absorbed" longwave) - ! force_array(:, 3) = PARDR PARDR W/m2 (direct PAR) - ! force_array(:, 4) = PARDF PARDF W/m2 (diffuse PAR) - ! force_array(:, 5) = PRECCU[*] PRECTOT kg/m2/s (*see below*) - ! force_array(:, 6) = PRECLS[*] PRECCON kg/m2/s (*see below*) - ! force_array(:, 7) = PRECSN[*] PRECSNO kg/m2/s (*see below*) - ! force_array(:, 8) = PS PS Pa (surface air pressure) - ! force_array(:, 9) = HLML HLML m (height of lowest model level "LML") - ! force_array(:,10) = TLML TLML K (air temperature at LML) - ! force_array(:,11) = QLML QLML kg/kg (air spec humidity at LML) - ! force_array(:,12) = SPEEDLML ULML m/s (wind speed/U-wind at LML) - ! force_array(:,13) = n/a VLML m/s ( V-wind at LML) - ! - ! PRECTOT kg/m2/s (total rain+snow) = PRECCU+PRECLS+PRECSNO - ! PRECCON kg/m2/s (convective rain+snow) - ! PRECCU kg/m2/s (convective rain) - ! PRECLS kg/m2/s (large-scale rain) - ! PRECSNO kg/m2/s (total snow) - - met_force_new%SWdown = force_array(:, 1) - met_force_new%LWdown = force_array(:, 2) - met_force_new%PARdrct = force_array(:, 3) - met_force_new%PARdffs = force_array(:, 4) - - met_force_new%Psurf = force_array(:, 8) - - met_force_new%RefH = force_array(:, 9) - met_force_new%Tair = force_array(:,10) - met_force_new%Qair = force_array(:,11) - - do k=1,N_catd - - ! get wind speed - - if (MERRA_file_specs) then - - if ( abs(force_array(k,12)-nodata_GEOSgcm)0) then - - met_force_new(k)%Snowf = force_array(k,7) - - ! total_rain = total_precip - total_snow - - met_force_new(k)%Rainf = force_array(k,5) - force_array(k,7) - - ! conv_rain = (conv_precip/total_precip) * total_rain - - met_force_new(k)%Rainf_C = & - force_array(k,6)/force_array(k,5)*met_force_new(k)%Rainf - - else - - met_force_new(k)%Rainf = 0. - met_force_new(k)%Rainf_C = 0. - met_force_new(k)%Snowf = 0. - - end if - - else - - ! G5DAS file specs - - met_force_new(k)%Rainf = force_array(k,5)+force_array(k,6) - met_force_new(k)%Rainf_C = force_array(k,5) - met_force_new(k)%Snowf = force_array(k,7) - - end if - - end if - - end do - - if(AEROSOL_DEPOSITION /=0) then - met_force_new%DUDP001 = force_array(:,13) - met_force_new%DUDP002 = force_array(:,14) - met_force_new%DUDP003 = force_array(:,15) - met_force_new%DUDP004 = force_array(:,16) - met_force_new%DUDP005 = force_array(:,17) - met_force_new%DUSV001 = force_array(:,18) - met_force_new%DUSV002 = force_array(:,19) - met_force_new%DUSV003 = force_array(:,20) - met_force_new%DUSV004 = force_array(:,21) - met_force_new%DUSV005 = force_array(:,22) - met_force_new%DUWT001 = force_array(:,23) - met_force_new%DUWT002 = force_array(:,24) - met_force_new%DUWT003 = force_array(:,25) - met_force_new%DUWT004 = force_array(:,26) - met_force_new%DUWT005 = force_array(:,27) - met_force_new%DUSD001 = force_array(:,28) - met_force_new%DUSD002 = force_array(:,29) - met_force_new%DUSD003 = force_array(:,30) - met_force_new%DUSD004 = force_array(:,31) - met_force_new%DUSD005 = force_array(:,32) - met_force_new%BCDP001 = force_array(:,33) - met_force_new%BCDP002 = force_array(:,34) - met_force_new%BCSV001 = force_array(:,35) - met_force_new%BCSV002 = force_array(:,36) - met_force_new%BCWT001 = force_array(:,37) - met_force_new%BCWT002 = force_array(:,38) - met_force_new%BCSD001 = force_array(:,39) - met_force_new%BCSD002 = force_array(:,40) - met_force_new%OCDP001 = force_array(:,41) - met_force_new%OCDP002 = force_array(:,42) - met_force_new%OCSV001 = force_array(:,43) - met_force_new%OCSV002 = force_array(:,44) - met_force_new%OCWT001 = force_array(:,45) - met_force_new%OCWT002 = force_array(:,46) - met_force_new%OCSD001 = force_array(:,47) - met_force_new%OCSD002 = force_array(:,48) - met_force_new%SUDP003 = force_array(:,49) - met_force_new%SUSV003 = force_array(:,50) - met_force_new%SUWT003 = force_array(:,51) - met_force_new%SUSD003 = force_array(:,52) - met_force_new%SSDP001 = force_array(:,53) - met_force_new%SSDP002 = force_array(:,54) - met_force_new%SSDP003 = force_array(:,55) - met_force_new%SSDP004 = force_array(:,56) - met_force_new%SSDP005 = force_array(:,57) - met_force_new%SSSV001 = force_array(:,58) - met_force_new%SSSV002 = force_array(:,59) - met_force_new%SSSV003 = force_array(:,60) - met_force_new%SSSV004 = force_array(:,61) - met_force_new%SSSV005 = force_array(:,62) - met_force_new%SSWT001 = force_array(:,63) - met_force_new%SSWT002 = force_array(:,64) - met_force_new%SSWT003 = force_array(:,65) - met_force_new%SSWT004 = force_array(:,66) - met_force_new%SSWT005 = force_array(:,67) - met_force_new%SSSD001 = force_array(:,68) - met_force_new%SSSD002 = force_array(:,69) - met_force_new%SSSD003 = force_array(:,70) - met_force_new%SSSD004 = force_array(:,71) - met_force_new%SSSD005 = force_array(:,72) - endif - - deallocate(force_array) - - end subroutine get_GEOS - - ! ****************************************************************** - - subroutine LDAS_GetVar(fid, vname, yyyymmdd, hhmmss, single_time_in_file, local_info, & - ptrShForce, rc) - - ! get LDAS forcing variable - - use netcdf - implicit none - include 'mpif.h' - - integer, intent(in) :: fid ! File handle - character(len=*), intent(in) :: vname ! Variable name - integer, intent(in) :: yyyymmdd ! Year-month-day, e.g., 19971003 - integer, intent(in) :: hhmmss ! Hour-minute-second, e.g., 120000 - logical, intent(in) :: single_time_in_file ! if true, no time index is necessary - type(local_grid), intent(in) :: local_info - !OUTPUT PARAMETERS: - real, pointer, intent(inout) :: ptrShForce(:,:) ! Gridded data read for this time - integer, intent(out) :: rc - - ! local - integer :: begDate, begTime, seconds, minutes, incSecs - integer :: iistart(3), iicount(3), timeIndex - integer :: istart(4), icount(4) ! cs grid - real, pointer :: tmpShared(:,:,:,:) ! cs grid - type(c_ptr) :: c_address - integer :: nv_id,imin, jmin, imax, jmax,ierr - integer :: DiffDate - integer :: status - character(*), parameter :: Iam="LDAS_getvar" - logical :: isCubed ! forcing on cs grid: true/false - - rc = 0 - isCubed = .false. - if(local_info%N_lat == 6*local_info%N_lon) then - isCubed = .true. - istart = 1 - icount(1) = local_info%N_lon - icount(2) = local_info%N_lon - icount(3) = 6 - icount(4) = 1 - else - iistart = 1 - iicount(1) = local_info%N_lon - iicount(2) = local_info%N_lat - iicount(3) = 1 - endif - - if (.not. single_time_in_file ) then ! determine start index - call GetBegDateTime ( fid, begDate, begTime, incSecs, rc ) - if (rc .NE. 0) then - print *, 'LDAS_GetVar: could not determine begin_date/begin_time' - return - endif - seconds = DiffDate (begDate, begTime, yyyymmdd, hhmmss) - ! Make sure input time are valid (assume time is not periodic) - if (seconds .LT. 0) then - print *, 'LDAS_GetVar: Error code from diffdate. Problem with date/time.' - rc = -7 - return - endif - - if ( MOD (seconds,60) .eq. 0 ) then - minutes = seconds / 60 - else - print *, 'LDAS_GetVar: Currently, times must fall on minute boundaries.' - rc = -6 - return - endif - - ! Determine the time index from the offset and time increment. - if ( MOD (seconds, incSecs) .ne. 0 ) then - print *, 'GFIO_getvar: Absolute time of ',seconds,' not ', & - 'possible with an interval of ',incSecs - rc = -2 - return - else - timeIndex = seconds/incSecs + 1 - endif - iistart(3)=timeIndex - istart(4) =timeIndex - endif - ! node root read and share - call MAPL_SyncSharedMemory(rc=status) - - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - rc= NF90_INQ_VARID( fid, vname, nv_id) - _ASSERT( rc == nf90_noerr, "nf90 error") - if (isCubed) then - c_address = c_loc(ptrShForce(1,1)) - call c_f_pointer(c_address,tmpShared,shape=icount) - rc= NF90_GET_VAR( fid, nv_id, tmpShared, start=istart,count=icount) - else - rc= NF90_GET_VAR( fid, nv_id, ptrShForce, start=iistart,count=iicount) - endif - _ASSERT( rc == nf90_noerr, "nf90 error") - endif - - call MAPL_SyncSharedMemory(rc=status) - - end subroutine LDAS_GetVar - - ! **************************************************************** - - function BilinearInterpolation(x,y,x1,x2,y1,y2,fnbr,UNDEF,tol) result(fxy) - - ! pchakrab: function to compute (bilinear) interpolated - ! value f(x,y). If we know the value at 4 points - ! f11=f(x1,y1), f12=f(x1,y2), f21=f(x2,y1) and f22=f(x2,y2), - ! the interpolated value, fxy, is computed as - ! - ! f11(x2-x)(y2-y) + f21(x-x1)(y2-y) + f12(x2-x)(y-y1) + f22(x-x1)(y-y1) - ! --------------------------------------------------------------------- - ! (x2-x1)(y2-y1) - ! - ! NOTE 1: UNDEF is the nodata value (1e15) - ! NOTE 2: If all the neighbouring f values are UNDEF, fxy = UNDEF - ! else, the UNDEF value at a corner is replaced by an - ! average of non-UNDEF values before fxy is computed - - real, intent(in) :: x, y, x1, x2, y1, y2, fnbr(2,2) - real, intent(in) :: UNDEF, tol - real :: fxy ! output - - ! local - real :: floc(2,2), fsum, dx1, dx2, dy1, dy2 - logical :: NoData(2,2) - integer :: i, j, numNoData - - floc = fnbr - - ! check for nodata values - ! and compute the sum of defined f values - NoData = .false. - numNodata = 0 - fsum = 0.0 - do j=1,2 - do i=1,2 - if (abs(floc(i,j)-UNDEF)0) then - where (NoData) floc = fsum/real(4-numNoData) - end if - dx1 = x-x1 - dx2 = x2-x - dy1 = y-y1 - dy2 = y2-y - fxy = ( & - floc(1,1)*dx2*dy2 + floc(2,1)*dx1*dy2 + & - floc(1,2)*dx2*dy1 + floc(2,2)*dx1*dy1 & - ) / ((x2-x1)*(y2-y1)) - end if - - end function BilinearInterpolation - - ! **************************************************************** - - subroutine parse_MERRA_met_tag( met_path_in, met_tag_in, date_time, & - met_path_default, met_path_prec, met_tag_out, use_prec_corr ) - - ! reichle, 1 Dec 2009 - - ! parse MERRA "met_tag", extract MERRA stream, assemble data paths - ! - ! Convention for driver_inputs*nml file or command line arguments: - ! - ! met_path = "/*/merra_land/" - ! - ! eg, on discover: /gpfsm/dnb51/projects/p15/iau/merra_land/ - ! on discover: /discover/nobackup/qliu/merra_land/ - ! on land01: /merra_land/ - ! - ! - ! met_tag = "d5_merra_[STREAM]__[GCM-TAG]{__prec[PREC]}" - ! - ! where {__prec[PREC]} is optional and where - ! - ! STREAM = 'jan79', 'jan89', 'jan98', or 'cross' - ! GCM-TAG = 'GEOSdas-2_1_4', ... - ! PREC = 'CMAPvS', 'GPCPv1.1', ... - ! - ! examples: - ! - ! STREAM = 'jan89' : use only Stream 2 MERRA data - ! STREAM = 'cross' : integrate across more than one stream - ! GCM-TAG = 'GEOSdas-2_1_4' : tag of standard MERRA (may differ for replays) - ! PREC : identifier for precip corrections to MERRA forcing - ! - ! --------------------------------------------------------------------------- - - implicit none - - character(*), intent(in) :: met_path_in - character(*), intent(in) :: met_tag_in - - type(date_time_type), intent(in) :: date_time - - character(200), intent(out) :: met_path_default, met_path_prec - character( 80), intent(out) :: met_tag_out - - logical, intent(out) :: use_prec_corr - - ! local variables - - integer :: is, ie - - type(date_time_type) :: dt1, dt2 - - character( 5) :: stream - character(80) :: gcm_tag, prec_tag - - character(len=*), parameter :: Iam = 'parse_MERRA_met_tag' - character(len=400) :: err_msg - - ! ---------------------------------------------------------- - - ! define intervals that determine which MERRA stream is used - ! in integrations that "cross" multiple streams - - ! Stream 1 ('jan79') --> 16 Dec 1978 - 31 Dec 1989 - ! Stream 2 ('jan89') --> 1 Jan 1990 - 31 Dec 1998 - ! Stream 3 ('jan98') --> 1 Jan 1999 - present - - ! dates before dt1 use Stream 1 - - dt1%year = 1993 - dt1%month = 1 - dt1%day = 1 - dt1%hour = 0 - dt1%min = 0 - dt1%sec = 0 - - ! otherwise, dates before dt2 use Stream 2 - - dt2%year = 2001 - dt2%month = 1 - dt2%day = 1 - dt2%hour = 0 - dt2%min = 0 - dt2%sec = 0 - - ! ---------------------------------------------------- - - ! initialize - - met_tag_out = repeat(' ', len(met_tag_out)) - - ! define which stream to use - - if (met_tag_in(10:14)=='cross') then - - if (datetime_lt_refdatetime( date_time, dt1 )) then - - stream = 'jan79' - - elseif (datetime_lt_refdatetime( date_time, dt2 )) then - - stream = 'jan89' - - else - - stream = 'jan98' - - end if - - met_tag_out = met_tag_in(1:9) // stream - - else - - met_tag_out = met_tag_in(1:14) - - end if - - ! ----------------------------------------------------- - ! - ! identify GCM tag and which precip corrections to use, - ! assemble met_path accordingly - ! - ! met_tag = "d5_merra_[STREAM]__[GCM-TAG]{__prec[PREC]}" - ! - ! where {__prec[PREC]} is optional - - is = index( met_tag_in, '__') - ie = index( met_tag_in, '__', .true.) - - if (is/=ie) then ! using precip corrections - - gcm_tag = met_tag_in(is+2:ie-1) - - met_path_default = trim(met_path_in) // '/MERRA_land_forcing/' // & - trim(gcm_tag) // '/' - - prec_tag = met_tag_in(ie+6:len(met_tag_in)) - - met_path_prec = trim(met_path_in) // '/precip_corr_' // trim(prec_tag) // & - '/' // trim(gcm_tag) // '/' - - use_prec_corr = .true. - - else ! not using precip corrections - - gcm_tag = met_tag_in(is+2:len(met_tag_in)) - - met_path_default = trim(met_path_in) // '/MERRA_land_forcing/' // & - trim(gcm_tag) // '/' - - prec_tag = repeat(' ', len(prec_tag)) - - met_path_prec = met_path_default - - use_prec_corr = .false. - - ! check if prec_tag was accidentally appended with a single underscore - - if (len_trim(met_tag_in)>29) then - - err_msg = 'questionable met_tag_in, not enough double underscores' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end if - - end subroutine parse_MERRA_met_tag - - ! **************************************************************** - - subroutine parse_MERRA2_met_tag( met_path_in, met_tag_in, date_time, & - met_path_default, met_path_prec, met_tag_out, use_prec_corr ) - - ! reichle, 27 Jul 2015 - - ! parse MERRA2 "met_tag", extract MERRA stream, assemble data paths - ! - ! met_tag = "M2[xxx]_[STREAM]{__prec[PREC]}" - ! - ! where {__prec[PREC]} is optional and where - ! - ! [xxx] = 'GCM' or 'COR' - ! STREAM = '100', '200', '300', '400', or 'cross' - ! PREC = 'CMAPvS', 'GPCPv1.1', ... - ! - ! examples: - ! - ! STREAM = '200' : use only Stream 2 MERRA data - ! STREAM = 'cross' : integrate across more than one stream - ! PREC : identifier for corrected precip data - ! - ! --------------------------------------------------------------------------- - - implicit none - - character(*), intent(in) :: met_path_in - character(*), intent(in) :: met_tag_in - - type(date_time_type), intent(in) :: date_time - - character(200), intent(out) :: met_path_default, met_path_prec - character( 80), intent(out) :: met_tag_out - - logical, intent(out) :: use_prec_corr - - ! local variables - - integer :: is - - type(date_time_type) :: dt1, dt2, dt3 - - character(10) :: stream - character(80) :: prec_tag - - character(len=*), parameter :: Iam = 'parse_MERRA2_met_tag' - character(len=400) :: err_msg - - ! ---------------------------------------------------------- - - ! define intervals that determine which MERRA-2 stream is used - ! in integrations that "cross" multiple streams - ! - ! 1/1/1980 - 12/31/1991: MERRA2_100 (Stream 1) - ! 1/1/1992 - 12/31/2000: MERRA2_200 (Stream 2) - ! 1/1/2001 - 12/31/2010: MERRA2_300 (Stream 3) - ! 1/1/2011 - present: MERRA2_400 (Stream 4) - - ! dates before dt1 use Stream 1 - - dt1%year = 1992 - dt1%month = 1 - dt1%day = 1 - dt1%hour = 0 - dt1%min = 0 - dt1%sec = 0 - - ! otherwise, dates before dt2 use Stream 2 - - dt2%year = 2001 - dt2%month = 1 - dt2%day = 1 - dt2%hour = 0 - dt2%min = 0 - dt2%sec = 0 - - ! otherwise, dates before dt3 use Stream 3 - - dt3%year = 2011 - dt3%month = 1 - dt3%day = 1 - dt3%hour = 0 - dt3%min = 0 - dt3%sec = 0 - - ! ---------------------------------------------------- - - ! initialize - - met_tag_out = repeat(' ', len(met_tag_out)) - - stream = repeat(' ', len(stream )) - - ! define which stream to use - - if (met_tag_in(7:11)=='cross') then - - if (datetime_lt_refdatetime( date_time, dt1 )) then - - stream = 'MERRA2_100' - - elseif (datetime_lt_refdatetime( date_time, dt2 )) then - - stream = 'MERRA2_200' - - elseif (datetime_lt_refdatetime( date_time, dt3 )) then - - stream = 'MERRA2_300' - - else - - stream = 'MERRA2_400' - - end if - - met_tag_out = trim(stream) - - else - - met_tag_out = 'MERRA2_' // met_tag_in(7:9) - - end if - - met_path_default = trim(met_path_in) // '/' - - ! ----------------------------------------------------- - ! - ! identify which precip corrections to use, - ! assemble met_path accordingly - ! - ! met_tag = "M2[xxx]_[STREAM]{__prec[PREC]}" - ! - ! where {__prec[PREC]} is optional - - is = index( met_tag_in, '__') - - if (is>0) then ! using precip corrections - - prec_tag = met_tag_in(is+6:len(met_tag_in)) - - met_path_prec = trim(met_path_in) // '/precip_corr_' // trim(prec_tag) // '/' - - use_prec_corr = .true. - - else ! not using precip corrections - - prec_tag = repeat(' ', len(prec_tag)) - - met_path_prec = met_path_default - - use_prec_corr = .false. - - ! check if prec_tag was accidentally appended with a single underscore - - if (len_trim(met_tag_in)>11) then - - err_msg = 'questionable met_tag_in, not enough double underscores' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end if - - end subroutine parse_MERRA2_met_tag - - ! **************************************************************** - - subroutine parse_G5DAS_met_tag( met_path_in, met_tag_in, date_time, & - met_path_default, met_path_prec, met_tag_out, use_prec_corr, & - use_Predictor ) - - ! parse G5DAS "met_tag" - ! - ! Convention for driver_inputs*nml file or command line arguments: - ! - ! met_tag = "[G5DAS-NAME]{__prec[PREC]}{__Nx+-}" - ! - ! where {__prec[PREC]} and {__Nx+-} are optional and where - ! - ! G5DAS-NAME : name of standard G5DAS forcing (must not contain "__"!) - ! e.g., "e5110_fp", "d591_rpit1", "d591_fpit", "d5294_geosit", ... - ! for cross-stream forcing, use "cross_d5294_GEOSIT", "cross_d5124_RPFPIT", "cross_FP" - ! PREC : identifier for precip corrections to G5DAS forcing (eg., 'GPCPv1.1') - ! - ! If {__Nx+-} is present, set flag for use forcing files from the DAS/GCM Predictor - ! segment. (Default is to use forcing from Corrector segment.) - ! - ! reichle, 3 Jun 2013 - ! reichle, 20 Sep 2013: restructured, added "use_Predictor" - ! reichle, 23 Sep 2013: added "cross-stream" capability - ! reichle, 5 Dec 2014: updated "cross-stream" dates - ! reichle, 14 Sep 2015: revised FP "cross-stream" dates - ! reichle, 28 Dec 2016: added 5.12.4 RPIT/FPIT streams - ! reichle, 19 Jan 2017: added FP transition from e5131 to f516 - ! reichle, 30 Oct 2017: added FP transition from f516 to f517 - ! reichle, 9 Jul 2018: added FP transition from f517 to f521 - ! reichle, 10 Oct 2019: added FP transition from f521 to f522 - ! reichle, 17 Jan 2020: added FP transition from f522 to f525 - ! reichle, 3 Apr 2020: added FP transition from f525 to f525_p5 - ! qliu+reichle, 5 Dec 2023: added GEOS-IT - ! - ! --------------------------------------------------------------------------- - - implicit none - - character(*), intent(in) :: met_path_in - character(*), intent(in) :: met_tag_in - - type(date_time_type), intent(in) :: date_time - - character(200), intent(out) :: met_path_default, met_path_prec - character( 80), intent(out) :: met_tag_out - - logical, intent(out) :: use_prec_corr - logical, intent(out) :: use_Predictor - - ! local variables - - integer :: is, ie, ii, N_opt_tag - - character(80) :: prec_tag, stream - character(80), dimension(2) :: tmp_tag - - type(date_time_type) :: dt_end_d591_rpit1 - type(date_time_type) :: dt_end_d591_rpit2 - type(date_time_type) :: dt_end_d591_rpit3 - type(date_time_type) :: dt_end_d591_fpit - - type(date_time_type) :: dt_end_d5124_rpit1 - type(date_time_type) :: dt_end_d5124_rpit2 - type(date_time_type) :: dt_end_d5124_rpit3 - - type(date_time_type) :: dt_end_d5294_geosit1 - type(date_time_type) :: dt_end_d5294_geosit2 - type(date_time_type) :: dt_end_d5294_geosit3 - - type(date_time_type) :: dt_end_e5110_fp - type(date_time_type) :: dt_end_e5130_fp - type(date_time_type) :: dt_end_e5131_fp - type(date_time_type) :: dt_end_f516_fp - type(date_time_type) :: dt_end_f517_fp - type(date_time_type) :: dt_end_f521_fp - type(date_time_type) :: dt_end_f522_fp - type(date_time_type) :: dt_end_f525_fp - type(date_time_type) :: dt_end_f525_p5_fp - - character(len=*), parameter :: Iam = 'parse_G5DAS_met_tag' - character(len=400) :: err_msg - - ! ---------------------------------------------------------- - ! - ! define transition times between RP-IT, FP-IT, GEOS-IT, or FP streams - ! if "cross-stream" forcing is requested - ! - ! | stream start | stream end (as of 5 Dec 2014) - ! ---------------------------------------- - ! d591_rpit1 | 1 Jan 2000 | 1 Jun 2007 - ! d591_rpit2 | 1 Jun 2006 | 30 Dec 2011 - ! d591_rpit3 | 1 Jan 2011 | 6 May 2013 - ! d591_fpit | 30 Dec 2012 | (present) - - dt_end_d591_rpit1%year = 2007 - dt_end_d591_rpit1%month = 6 - dt_end_d591_rpit1%day = 1 - dt_end_d591_rpit1%hour = 0 - dt_end_d591_rpit1%min = 0 - dt_end_d591_rpit1%sec = 0 - - dt_end_d591_rpit2%year = 2011 - dt_end_d591_rpit2%month = 12 - dt_end_d591_rpit2%day = 1 - dt_end_d591_rpit2%hour = 0 - dt_end_d591_rpit2%min = 0 - dt_end_d591_rpit2%sec = 0 - - dt_end_d591_rpit3%year = 2013 - dt_end_d591_rpit3%month = 5 - dt_end_d591_rpit3%day = 1 - dt_end_d591_rpit3%hour = 0 - dt_end_d591_rpit3%min = 0 - dt_end_d591_rpit3%sec = 0 - - dt_end_d591_fpit%year = 9999 - dt_end_d591_fpit%month = 1 - dt_end_d591_fpit%day = 1 - dt_end_d591_fpit%hour = 0 - dt_end_d591_fpit%min = 0 - dt_end_d591_fpit%sec = 0 - - ! | stream start | stream end (as of 28 Dec 2016) - ! ---------------------------------------- - ! d5124_rpit1 | 1 Jan 2000 | 1 Jan 2004 - ! d5124_rpit2 | 1 Jan 2004 | 1 Jan 2012 - ! d5124_rpit3 | 1 Jan 2012 | (present) - - dt_end_d5124_rpit1%year = 2004 - dt_end_d5124_rpit1%month = 1 - dt_end_d5124_rpit1%day = 1 - dt_end_d5124_rpit1%hour = 0 - dt_end_d5124_rpit1%min = 0 - dt_end_d5124_rpit1%sec = 0 - - dt_end_d5124_rpit2%year = 2012 - dt_end_d5124_rpit2%month = 1 - dt_end_d5124_rpit2%day = 1 - dt_end_d5124_rpit2%hour = 0 - dt_end_d5124_rpit2%min = 0 - dt_end_d5124_rpit2%sec = 0 - - dt_end_d5124_rpit3%year = 9999 - dt_end_d5124_rpit3%month = 1 - dt_end_d5124_rpit3%day = 1 - dt_end_d5124_rpit3%hour = 0 - dt_end_d5124_rpit3%min = 0 - dt_end_d5124_rpit3%sec = 0 - - ! | stream start | stream end - ! | (excl 1-yr | - ! | spinup) | - ! ---------------------------------------- - ! d5294_geosit1 | 1 Jan 1998 | 1 Jan 2008 - ! d5294_geosit2 | 1 Jan 2008 | 1 Jan 2018 - ! d5294_geosit3 | 1 Jan 2018 | (present) - - dt_end_d5294_geosit1%year = 2008 - dt_end_d5294_geosit1%month = 1 - dt_end_d5294_geosit1%day = 1 - dt_end_d5294_geosit1%hour = 0 - dt_end_d5294_geosit1%min = 0 - dt_end_d5294_geosit1%sec = 0 - - dt_end_d5294_geosit2%year = 2018 - dt_end_d5294_geosit2%month = 1 - dt_end_d5294_geosit2%day = 1 - dt_end_d5294_geosit2%hour = 0 - dt_end_d5294_geosit2%min = 0 - dt_end_d5294_geosit2%sec = 0 - - dt_end_d5294_geosit3%year = 9999 - dt_end_d5294_geosit3%month = 1 - dt_end_d5294_geosit3%day = 1 - dt_end_d5294_geosit3%hour = 0 - dt_end_d5294_geosit3%min = 0 - dt_end_d5294_geosit3%sec = 0 - - ! --------------------------------- - ! - ! FP streams - ! - ! Stream start/end in terms of availability - ! in the GEOS-5 archive (approximately): - ! - ! | stream start | stream end - ! ---------------------------------------- - ! e5110_fp | 11 Jun 2013 | 19 Aug 2014 - ! e5130_fp | 1 Aug 2014 | 4 May 2015 - ! e5131_fp | 1 May 2015 | 24 Jan 2017 - ! f516_fp | 24 Jan 2017 | 1 Nov 2017 - ! f517_fp | 1 Nov 2017 | 11 Jul 2018 - ! f521_fp | 11 Jul 2018 | 13 Mar 2019 - ! f522_fp | 13 Mar 2019 | 30 Jan 2020 - ! f525_fp | 30 Jan 2020 | 7 Apr 2020 - ! f525_p5_fp | 7 Apr 2020 | (present) - ! - ! Official stream transition times (as defined - ! by GMAO ops group) are: - ! - ! FP e5110 --> e5130 : 20 Aug 2014, 6z ADAS analysis - ! FP e5130 --> e5131 : 1 May 2015, 6z ADAS analysis - ! FP e5131 --> f516 : 24 Jan 2017, 6z ADAS analysis - ! FP f516 --> f517 : 1 Nov 2017, 6z ADAS analysis - ! FP f517 --> f521 : 11 Jul 2018, 6z ADAS analysis - ! FP f521 --> f522 : 13 Mar 2019, 6z ADAS analysis - ! FP f522 --> f525 : 30 Jan 2020, 6z ADAS analysis - ! FP f525 --> f525_p5 : 7 Apr 2020, 6z ADAS analysis - ! - ! Official stream transition times refer to the definition - ! of the official FP files with generic file names on the - ! NCCS data portal. - ! - ! Note that "lfo" files for the 6z analysis start from 4z, - ! that is, the exact transition time is slightly different - ! from the LDAS perspective. - ! - ! Define LDASsa "cross" streams dates for 0z of the - ! first day that contains only "new" data for - ! compatibility with the SMAP L4 Ops system and because of the - ! asymmetric availability of the data on the NCCS data portal. - ! - ! - reichle, 14 Sep 2015 - ! - ! Revised Aug 2014 cross-over date to Aug 20 at 0z because - ! e5110 data are not available for Aug 20 - ! - reichle+qliu, 29 Jan 2016 - - dt_end_e5110_fp%year = 2014 - dt_end_e5110_fp%month = 8 - dt_end_e5110_fp%day = 20 - dt_end_e5110_fp%hour = 0 - dt_end_e5110_fp%min = 0 - dt_end_e5110_fp%sec = 0 - - dt_end_e5130_fp%year = 2015 - dt_end_e5130_fp%month = 5 - dt_end_e5130_fp%day = 2 - dt_end_e5130_fp%hour = 0 - dt_end_e5130_fp%min = 0 - dt_end_e5130_fp%sec = 0 - - dt_end_e5131_fp%year = 2017 - dt_end_e5131_fp%month = 1 - dt_end_e5131_fp%day = 24 - dt_end_e5131_fp%hour = 3 - dt_end_e5131_fp%min = 0 - dt_end_e5131_fp%sec = 0 - - dt_end_f516_fp%year = 2017 - dt_end_f516_fp%month = 11 - dt_end_f516_fp%day = 1 - dt_end_f516_fp%hour = 3 - dt_end_f516_fp%min = 0 - dt_end_f516_fp%sec = 0 - - dt_end_f517_fp%year = 2018 - dt_end_f517_fp%month = 7 - dt_end_f517_fp%day = 11 - dt_end_f517_fp%hour = 3 - dt_end_f517_fp%min = 0 - dt_end_f517_fp%sec = 0 - - dt_end_f521_fp%year = 2019 - dt_end_f521_fp%month = 3 - dt_end_f521_fp%day = 13 - dt_end_f521_fp%hour = 3 - dt_end_f521_fp%min = 0 - dt_end_f521_fp%sec = 0 - - dt_end_f522_fp%year = 2020 - dt_end_f522_fp%month = 1 - dt_end_f522_fp%day = 30 - dt_end_f522_fp%hour = 3 - dt_end_f522_fp%min = 0 - dt_end_f522_fp%sec = 0 - - dt_end_f525_fp%year = 2020 - dt_end_f525_fp%month = 4 - dt_end_f525_fp%day = 7 - dt_end_f525_fp%hour = 3 - dt_end_f525_fp%min = 0 - dt_end_f525_fp%sec = 0 - - dt_end_f525_p5_fp%year = 9999 - dt_end_f525_p5_fp%month= 1 - dt_end_f525_p5_fp%day = 1 - dt_end_f525_p5_fp%hour = 0 - dt_end_f525_p5_fp%min = 0 - dt_end_f525_p5_fp%sec = 0 - - ! ---------------------------------------------------- - - ! initialize - - met_tag_out = repeat(' ', len(met_tag_out)) - - stream = repeat(' ', len(stream )) - - use_prec_corr = .false. - - use_Predictor = .false. - - ! ----------------------------------------------------- - ! - ! identify "GCM" tag and whether to use precip corrections and/or - ! forcing from the DAS/GCM Predictor segment (default: Corrector segment) - ! - ! met_tag = "[G5DAS-NAME]{__prec[PREC]}{__Nx+-}" - ! - ! where {__prec[PREC]} and {__Nx+-} are optional - - is = index( met_tag_in, '__') - ie = index( met_tag_in, '__', .true.) - - ! determine how many optional tag segments are present - - if (is==0) then - - N_opt_tag = 0 - - met_tag_out = met_tag_in - - elseif (is==ie) then - - N_opt_tag = 1 - - met_tag_out = met_tag_in(1:(is-1)) - - tmp_tag(1) = met_tag_in((is+2):len(met_tag_in)) - - else - - ! make sure there are at most two optional tag segments - - ! "ii" should be the index for the next "__" after "is" - - ii = index( met_tag_in(is+2:len(met_tag_in)), '__') - - if (is+1+ii==ie) then - - N_opt_tag = 2 - - met_tag_out = met_tag_in(1:(is-1)) - - tmp_tag(1) = met_tag_in((is+2):ie-1) - - tmp_tag(2) = met_tag_in((ie+2):len(met_tag_in)) - - else - - err_msg = 'invalid met_tag_in, too many double underscores' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end if - - - ! resolve cross-stream if requested - - if (met_tag_out(1:17)=='cross_d591_RPFPIT') then - - if (datetime_lt_refdatetime( date_time, dt_end_d591_rpit1 )) then - - stream = 'd591_rpit1_jan00' ! use d591 RP-IT stream 1 - - elseif (datetime_lt_refdatetime( date_time, dt_end_d591_rpit2 )) then - - stream = 'd591_rpit2_jun06' ! use d591 RP-IT stream 2 - - elseif (datetime_lt_refdatetime( date_time, dt_end_d591_rpit3 )) then - - stream = 'd591_rpit3_jan11' ! use d591 RP-IT stream 3 - - else - - stream = 'd591_fpit' ! use d591 FP-IT - - end if - - elseif (met_tag_out(1:18)=='cross_d5124_RPFPIT') then - - if (datetime_lt_refdatetime( date_time, dt_end_d5124_rpit1 )) then - - stream = 'd5124_rpit_jan00' ! use d5124 RP-IT stream 1 - - elseif (datetime_lt_refdatetime( date_time, dt_end_d5124_rpit2 )) then - - stream = 'd5124_rpit_jan04' ! use d5124 RP-IT stream 2 - - else - - stream = 'd5124_rpit_jan12' ! use d5124 RP-IT stream 3 - - end if - - elseif (met_tag_out(1:18)=='cross_d5294_GEOSIT') then - - if (datetime_lt_refdatetime( date_time, dt_end_d5294_geosit1 )) then - - stream = 'd5294_geosit_jan98' ! use d5294 GEOS-IT stream 1 - - elseif (datetime_lt_refdatetime( date_time, dt_end_d5294_geosit2 )) then - - stream = 'd5294_geosit_jan08' ! use d5294 GEOS-IT stream 2 - - else - - stream = 'd5294_geosit_jan18' ! use d5294 GEOS-IT stream 3 - - end if - - - elseif (met_tag_out(1:8)=='cross_FP') then - - if (datetime_lt_refdatetime( date_time, dt_end_e5110_fp )) then - - stream = 'e5110_fp' ! use GEOS-5.11.0 output - - elseif (datetime_lt_refdatetime( date_time, dt_end_e5130_fp )) then - - stream = 'e5130_fp' ! use GEOS-5.13.0 output - - elseif (datetime_le_refdatetime( date_time, dt_end_e5131_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'e5131_fp' ! use GEOS-5.13.1 output - - elseif (datetime_le_refdatetime( date_time, dt_end_f516_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'f516_fp' ! use GEOS-5.16.x output - - elseif (datetime_le_refdatetime( date_time, dt_end_f517_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'f517_fp' ! use GEOS-5.17.x output - - elseif (datetime_le_refdatetime( date_time, dt_end_f521_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'f521_fp' ! use GEOS-5.21.x output - - elseif (datetime_le_refdatetime( date_time, dt_end_f522_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'f522_fp' ! use GEOS-5.22.x output - - elseif (datetime_le_refdatetime( date_time, dt_end_f525_fp )) then - - ! Note "less-than-or-equal" (_le_) above - - stream = 'f525_fp' ! use GEOS-5.25.x output - - else - - stream = 'f525_p5_fp' ! use GEOS-5.25_p5.x output - - end if - - else - - stream = met_tag_out - - end if - - met_tag_out = stream - - - ! interpret optional tag segments - - do ii=1,N_opt_tag - - if (tmp_tag(ii)(1:4)=='prec') then - - use_prec_corr = .true. - - prec_tag = tmp_tag(ii)(5:len(tmp_tag(ii))) - - elseif (tmp_tag(ii)(1:4)=='Nx+-') then - - use_Predictor = .true. - - else - - err_msg = 'invalid met_tag_in, unknown optional tag segment' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end do - - ! get path to met forcing (except precip) - - met_path_default = trim(met_path_in) // '/' - - ! get path to precip - - if (use_prec_corr) then ! using precip corrections - - met_path_prec = trim(met_path_in) // '/precip_corr_' // trim(prec_tag) // '/' - - else ! *not* using precip corrections - - met_path_prec = met_path_default - - end if - - ! Double-check if optional tag segments were somehow missed, e.g., - ! because they were accidentally appended with single underscores. - ! Assumes that "prec" and "Nx+-" never appear in GEOS-5 product names. - ! Does NOT protect against spelling errors, e.g., "__perc" or "__Nx-+". - ! - reichle, 24 Nov 2015 - - if ((.not. use_prec_corr) .and. (index( met_tag_in, 'prec')>0)) then - - err_msg = 'questionable met_tag_in: includes "prec" but use_prec_corr=.false.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - if ((.not. use_Predictor) .and. (index( met_tag_in, 'Nx+-')>0)) then - - err_msg = 'questionable met_tag_in: includes "Nx+-" but use_Predictor=.false.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - end subroutine parse_G5DAS_met_tag - - ! **************************************************************** - - subroutine get_GEOS_forcing_filename(fname_full,file_exists, date_time, daily_file, met_path, met_tag, & - GEOSgcm_defs, file_ext) - - ! reichle, 27 Jul 2015 - added "daily_file" option - ! (because MERRA-2 provides aggregated daily files that contain 24 hourly fields) - - ! reichle, 7 May 2020 - added "seamless" GEOS FP file names (so far, only "asm" assimilation files) - - implicit none - - character(*), intent(inout) :: fname_full - logical, intent(out) :: file_exists - type(date_time_type), intent(in) :: date_time - logical, intent(in) :: daily_file - character(*), intent(in) :: met_path - character(*), intent(in) :: met_tag - character( 40), dimension(5), intent(in) :: GEOSgcm_defs - character(*), intent(in) :: file_ext - - ! local variables - - character(300) :: fname, fname_full_tmp1, fname_full_tmp2 - character( 16) :: time_stamp - character( 4) :: YYYY, HHMM, day_dir - character( 2) :: MM, DD - - integer :: tmpind, tmpindend - - character(len=*), parameter :: Iam = 'get_GEOS_forcing_filename' - - ! assemble date/time strings - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HHMM,'(i4.4)') date_time%hour*100+date_time%min - - ! deal with absence of "minutes" in "bkg.sfc" file name - ! (replace minutes with blanks, then trim, see below) - - if (trim(GEOSgcm_defs(3))=='bkg.sfc') HHMM = HHMM(1:2) // ' ' - - ! assemble file name - - time_stamp = repeat(' ', len(time_stamp)) - - if (daily_file) then - - time_stamp(1:8) = YYYY // MM // DD - - elseif (index(met_tag,'GEOSIT') > 0 .or. index(met_tag,'geosit') > 0) then - - time_stamp(1:16) = YYYY //'-'// MM //'-'// DD // 'T' // trim(HHMM) // 'Z' - - else - - time_stamp(1:14) = YYYY // MM // DD // '_' // trim(HHMM) // 'z' - - end if - - if (trim(met_tag(1:11))=='GEOS.fp.asm') then - - ! GEOS FP with generic file names, e.g., - ! - ! GEOS.fp.asm.inst1_2d_lfo_Nx.20200507_0000.V01.nc4 - ! - ! for now, always use product counter V01 - ! (as of 7 May 2020, no V02 or higher was issued for GEOS FP "lfo" products - ! going back to Jun 2013) - - fname = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '.' // & - trim(time_stamp(1:13)) // '.V01.' // trim(file_ext) - - ! archived files are stored in daily directories - - day_dir = 'D' // DD // '/' - - else - - ! GEOS FP with experiment-specific file names and MERRA-2, e.g., - ! - ! f525_p5_fp.inst1_2d_lfo_Nx.20200507_0000z.nc4 - ! MERRA2_400.inst1_2d_lfo_Nx.20200507.nc4 - - fname = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '.' // & - trim(time_stamp) // '.' // trim(file_ext) - - ! archived files are stored in monthly directories - ! (per LDAS legacy convention for GEOS FP with experiment-specific file names) - - day_dir = repeat(' ', len(day_dir)) - - end if - - ! ---------------------------------------------- - ! - ! find suitable file in a couple of places - - file_exists = .false. ! initialize - - - ! first try: year/month[/day] directory - - fname_full = trim(met_path) // '/' // trim(met_tag) // '/' // & - trim(GEOSgcm_defs(4)) // '/Y' // YYYY // '/M' // MM // '/' // & - trim(day_dir) // trim(fname) - - inquire(file=fname_full, exist=file_exists) - - if (file_exists) return ! done - - fname_full_tmp1 = trim(fname_full) ! remember for error log below - - - ! second try: ./met_path (coupled land-atm DAS) - - fname_full = trim(met_path) // '/' // trim(fname) - - inquire(file=fname_full, exist=file_exists) - - if (file_exists) return ! done - - fname_full_tmp2 = trim(fname_full) ! remember for error log below - - - ! last try: for GEOS FP with generic file names, try product counter '.V02.' in year/month/day dir - - if (trim(met_tag(1:11))=='GEOS.fp.asm') then - - fname_full = fname_full_tmp1 ! from first try - - ! GEOS.fp.asm.inst1_2d_lfo_Nx.20200507_0000.V01.nc4 - ! 1234567 - - tmpindend = len_trim(fname_full) - tmpind = len_trim(file_ext) - - tmpind = tmpindend - tmpind - 3 - - fname_full( tmpind:tmpind+2 ) = 'V02' ! --> *.V02.nc4 - - inquire(file=fname_full, exist=file_exists) - - end if - - - ! if no file was found, report file names that were tried - - if (.not. file_exists) then - if(root_logit) then - print '(400A)', trim(Iam) // ': Could not find any of the following files:' - print '(400A)', trim(fname_full_tmp1) - print '(400A)', trim(fname_full_tmp2) - print '(400A)', trim(fname_full) - endif - endif - - end subroutine get_GEOS_forcing_filename - - !********************************************************** - - subroutine GEOS_openfile(FileOpenedHash, fname_full, fid, tile_coord, m_hinterp, rc, lat_str, lon_str) - - ! open GEOS forcing file, extract coord info, prep horizontal interpolation info (if not done already) - ! - ! ASSUMPTIONS (as of 23 Jun 2021): - ! - forcing grid is global - ! - if lat/lon forcing grid, pole is on center of grid cell and dateline is on center of grid cell - ! - if cube-sphere forcing grid, tile space (tile_coord) is associated with same cube-sphere grid - - use netcdf - implicit none - include 'mpif.h' - type(Hash_Table), intent(inout) :: FileOpenedHash - character(*), intent(in) :: fname_full - integer, intent(out) :: fid - type(tile_coord_type), dimension(:), intent(in) :: tile_coord - integer, intent(in) :: m_hinterp - integer, optional, intent(out) :: rc - character(*), optional, intent(in) :: lat_str, lon_str - - integer :: N_lat, N_lon, N_cat, N_f - integer, allocatable :: i1(:), i2(:), j1(:), j2(:) - real, allocatable :: x1(:), x2(:), y1(:), y2(:) - integer :: ierr, k - integer :: latid, lonid, nfid, xdimid - real :: dlon, dlat, ll_lon, ll_lat - character(len=100) :: err_msg - character(*), parameter :: Iam="GEOS_openfile" - logical :: isCubed ! forcing on cs grid: true/false - ! add mpi - type(ESMF_VM) :: vm - integer :: comm, total_prcs, myrank - integer :: status - - ! initialize hash table, if not already initialized - - call FileOpenedHash%init() - - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - call ESMF_VmGet(vm, mpicommunicator=comm, rc=status) - VERIFY_(status) - - ! get file ID from hash table - - call FileOpenedHash%get(fname_full,fid) - - if( fid == -9999 ) then ! not open yet - ierr=nf90_open(fname_full,NF90_NOWRITE, fid) ! open file - if(root_logit) then - write(logunit,'(400A)') "opening file: "//trim(fname_full) - endif - _ASSERT( ierr == nf90_noerr, "nf90 error") - call FileOpenedHash%put(fname_full,fid) ! record file ID in hash table - endif - - ! -------------------------------------------------- - ! - ! determine grid dimension, spacing, and offset/extent - ! - ! ONLY the grid dimensions are read from the file; - ! the grid spacing and offset/extent are determined based on hard-wired assumptions! - - ! check if forcing in file is on cs grid - ierr = nf90_inq_dimid(fid,"nf",nfid) ! check if number-of-faces (nf) dimension exists - - if (ierr == nf90_noerr) then ! forcing is on cubed-sphere grid if face dimension is found - - ! cube-sphere grid: need N_f (number-of-faces), N_lon, N_lat - - ierr = nf90_inq_dimid(fid,"Xdim",xdimid) - _ASSERT( ierr == nf90_noerr, "nf90 error") - ierr = nf90_Inquire_Dimension(fid,nfid, len=N_f) - _ASSERT( ierr == nf90_noerr, "nf90 error") - _ASSERT( N_f == 6, "number of (cubed-sphere) faces not equal to 6") - ierr = nf90_Inquire_Dimension(fid,xdimid,len=N_lon) - _ASSERT( ierr == nf90_noerr, "nf90 error") - _ASSERT( N_lon == im_world_cs, "forcing on cube-sphere grid: forcing grid dimension must match native grid dimension (grid associated with tile space)") - N_lat = N_f*N_lon - _ASSERT( m_hinterp == 0, "forcing on cubed-sphere grid requires nearest-neighbor interpolation (m_hinterp = 0)") - - isCubed = .true. ! forcing is on cube sphere grid - - else - - ! lat/lon grid: need N_lon, N_lat, dlon, dlat, ll_lon, ll_lat - - if (present(lat_str) .and. present(lon_str)) then - ierr = nf90_inq_dimid(fid,trim(lat_str),latid) - ierr = nf90_inq_dimid(fid,trim(lon_str),lonid) - else - ierr = nf90_inq_dimid(fid,"lat",latid) - ierr = nf90_inq_dimid(fid,"lon",lonid) - endif - ierr = nf90_Inquire_Dimension(fid,latid,len=N_lat) - ierr = nf90_Inquire_Dimension(fid,lonid,len=N_lon) - - isCubed = .false. ! forcing is on regular lat/lon grid - - ! assume global grid w/ dateline on center and pole on center - - dlon = 360./real(N_lon) - dlat = 180./real(N_lat-1) - ll_lon = -180. - dlon/2. - ll_lat = -90. - dlat/2. - - endif - - ! ----------------------------------------------------------------- - - ! prep interpolation from forcing grid to model tiles - - N_cat = size(tile_coord,1) - - ! if dimensions are the same, no need to recalculate the local_info - if( local_info%N_lat == N_lat .and. local_info%N_lon == N_lon ) then - RETURN_(ESMF_SUCCESS) - endif - - allocate(i1(N_cat),j1(N_cat)) - allocate(i2(N_cat),j2(N_cat),x1(N_cat),x2(N_cat),y1(N_cat),y2(N_cat)) - - if (isCubed) then ! forcing is on cs grid - ! cube-sphere grid of forcing data must match cube-sphere grid associated with tile space - i1(:) = tile_coord(:)%i_indg - j1(:) = tile_coord(:)%j_indg - else - ! get index and coord info of neighbor(s) - call get_neighbor_index(m_hinterp, tile_coord, ll_lon, ll_lat, dlon, dlat, N_lon, N_lat, & - i1, j1, i2, j2, x1, y1, x2, y2) - endif - - local_info%N_lat = N_lat - local_info%N_lon = N_lon - local_info%N_cat = N_cat - call move_alloc(i1,local_info%i1) - call move_alloc(i2,local_info%i2) - call move_alloc(j1,local_info%j1) - call move_alloc(j2,local_info%j2) - call move_alloc(x1,local_info%x1) - call move_alloc(x2,local_info%x2) - call move_alloc(y1,local_info%y1) - call move_alloc(y2,local_info%y2) - - RETURN_(ESMF_SUCCESS) - - end subroutine GEOS_openfile - - subroutine set_neighbor_offset(offset) - real, intent(in) :: offset - neighbor_offset = offset - end subroutine - ! **************************************************************** - - subroutine get_neighbor_index(m_hinterp, tile_coord, ll_lon, ll_lat, dlon, dlat, N_lon, N_lat, & - i1, j1, i2, j2, x1, y1, x2, y2, rc) - - ! Prep info for horizontal interpolation of lat/lon gridded forcing data to tile space: - ! Compute indices of nearest neighbors needed for nearest-neighbor or bilinear interpolation - ! from regular lat/lon grid to tile space. - ! - ! This functionality was previously contained in GEOS_openfile. Some of the hard-coded assumptions - ! about the grid extent and grid origin location from GEOS_openfile were relaxed. Nearest-neighbor - ! interpolation of cube-sphere gridded forcing remains in GEOS_openfile. - ! - ! - wjiang+reichle, 5 Oct 2021 - - integer, intent(in) :: m_hinterp ! 0=nearest-neighbor, 1=bilinear - type(tile_coord_type), dimension(:), intent(in) :: tile_coord - real, intent(in) :: ll_lat, ll_lon, dlat, dlon - integer, intent(in) :: N_lat, N_lon - integer, dimension(:), intent(inout) :: i1, i2, j1, j2 - real, dimension(:), intent(out) :: x1, x2, y1, y2 - integer, optional, intent(out) :: rc - - ! N_lon, N_lat, dlon, dlat, ll_lon, and ll_lat provide a complete description of the - ! regular lat/lon grid. - ! NOTE: ll_lon and ll_lat refer to lower left corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - - ! pchakrab: For bilinear interpolation, for each tile, we need: - ! x1, x2, y1, y2 (defining the co-ords of four neighbors) and - ! i1, i2, j1, j2 (defining the indices of four neighbors) - - ! local variables - - - integer :: N_cat - - real, dimension(:), allocatable :: tmp_lat, tmp_lon - - character(len=*), parameter :: Iam="get_neighbor_index" - - ! ------------------------------------------------------------------- - ! - ! find nearest neighbor - - i1 = ceiling((tile_coord%com_lon + neighbor_offset - ll_lon)/dlon) - j1 = ceiling((tile_coord%com_lat + neighbor_offset - ll_lat)/dlat) - - ! NOTE: For a "date line on center" grid and (180-dlon/2) < lon < 180 - ! we now have i1=(grid%N_lon+1). - ! This needs to be fixed as follows: - - where( i1 > N_lon) i1=1 - if (any(j1 > N_lat)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, "encountered tile near the poles") - end if - - ! done if nearest-neighbor interpolation is requested - - if (m_hinterp == 0) then - RETURN_(ESMF_SUCCESS) - endif - - ! continue for bilinear interpolation - - x1 = real(i1-1)*dlon + ll_lon + 0.5*dlon ! longitude of nearest neighbor - y1 = real(j1-1)*dlat + ll_lat + 0.5*dlat ! latitude of nearest neighbor - - ! find forcing grid cell ("2") diagonally across the tile from nearest neighbor (i1,j1) - ! - ! to this end, determine quadrant of forcing grid cell that contains center-of-mass coord of tile - ! - ! quadrant is found by determining nearest-neighbor indices (i2, j2) when tile is shifted - ! by 1/2 of the grid-spacing to the northeast (upper right) and testing if the nearest - ! neighbor changes - - ! location of tiles when shifted by 1/2 grid spacing in positive lon and lat directions (northeast) - - N_cat = size(tile_coord,1) - - allocate(tmp_lon(N_cat)) - allocate(tmp_lat(N_cat)) - - tmp_lon = tile_coord%com_lon + 0.5*dlon - tmp_lat = tile_coord%com_lat + 0.5*dlat - - ! find nearest neighbor grid cell (i2,j2) of shifted tile (use same "offset" as above) - - i2 = ceiling((tmp_lon + neighbor_offset - ll_lon)/dlon) - j2 = ceiling((tmp_lat + neighbor_offset - ll_lat)/dlat) - - ! now determine desired quadrant and correct (i2,j2) accordingly - - where (i2==i1) i2 = i2 - 1 ! if 0.5*dlon shift results in same lon index, go west (left) - where (j2==j1) j2 = j2 - 1 ! if 0.5*dlat shift results in same lat index, go south (down) - - ! determine center lon and lat of forcing grid cell "2"; - ! must do this BEFORE wrap-around (such that x2 will be outside of [-180:180] near dateline), - ! otherwise distance calculation would not work near dateline - - x2 = real(i2-1)*dlon + ll_lon + 0.5*dlon - y2 = real(j2-1)*dlat + ll_lat + 0.5*dlat - - ! wrap-around and check for proximity to poles - - where (i2==0) i2 = N_lon - where (i2 > N_lon) i2 = 1 - if (any(j2==0) .or. any(j2>N_lat)) then - call ldas_abort(LDAS_GENERIC_ERROR, Iam, "encountered tile near the poles") - end if - - ! return cleanly after bilinear interpolation - - if (allocated(tmp_lon)) deallocate(tmp_lon) - if (allocated(tmp_lat)) deallocate(tmp_lat) - - if (m_hinterp == 1) then - RETURN_(ESMF_SUCCESS) - endif - - ! error in m_hinterp input if we get to here: - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown m_hinterp!!') - - end subroutine - - ! **************************************************************** - - subroutine GEOS_closefile(fid) - use netcdf - implicit none - integer,intent (in) :: fid - integer :: ierr - - ierr = nf90_close(fid) - if(ierr /= nf90_noerr) then - print *, " error GEOS_closefile" - stop 2 - endif - - endsubroutine - - ! **************************************************************** - - subroutine get_GEOS_corr_prec_filename(fname_full,file_exists, date_time, met_path, met_tag, & - GEOSgcm_defs, file_ext, daily_files) - - implicit none - character(*), intent(inout) :: fname_full - logical,intent(out) :: file_exists - logical,intent(out) :: daily_files - type(date_time_type), intent(in) :: date_time - character(*), intent(in) :: met_path - character(*), intent(in) :: met_tag - character( 40), dimension(5), intent(in) :: GEOSgcm_defs - character(*), intent(in) :: file_ext - - ! local variables - - character(100) :: fname, fname_tmp - character(200) :: fdir - character(300) :: fname_full_tmp1, fname_full_tmp2, fname_full_tmp3 - character( 4) :: YYYY, HHMM - character( 2) :: MM, DD - - integer :: tmpind, tmpindend - - character(len=*), parameter :: Iam = 'get_GEOS_corr_prec_filename' - - ! assemble date/time strings - - write (YYYY,'(i4.4)') date_time%year - write (MM, '(i2.2)') date_time%month - write (DD, '(i2.2)') date_time%day - write (HHMM,'(i4.4)') date_time%hour*100+date_time%min - - ! assemble file name - - if (trim(met_tag(1:11))=='GEOS.fp.asm') then - - ! for now, always use product counter V01 - ! (as of 7 May 2020, no V02 or higher was issued for GEOS FP "lfo" products - ! going back to Jun 2013) - - fname = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '_corr.' // & - YYYY // MM // DD // '_' // trim(HHMM) // '.V01.' // trim(file_ext) - - fname_tmp = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '_corr.' // & - YYYY // MM // DD // '.V01.' // trim(file_ext) - - else - - fname = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '_corr.' // & - YYYY // MM // DD // '_' // trim(HHMM) // 'z.' // trim(file_ext) - - fname_tmp = trim(met_tag) // '.' // trim(GEOSgcm_defs(3)) // '_corr.' // & - YYYY // MM // DD // '.' // trim(file_ext) - - end if - - ! assemble dir name with "/Yyy" (year) dir but without "/Mmm" (month) dir - - fdir = trim(met_path) // '/' // trim(met_tag) // '/' // & - trim(GEOSgcm_defs(4)) // '/' // 'Y' // YYYY // '/' - - ! ----------------------------------------------------------------------- - - file_exists = .false. ! initialize - daily_files = .false. - - ! first try: look for file in year/month dir - ! (LDAS standard for corrected G5DAS precip) - - fname_full = trim(fdir) // 'M' // MM // '/' // trim(fname) - - inquire(file=fname_full, exist=file_exists) - - if (file_exists) return ! done - - fname_full_tmp1 = trim(fname_full) ! remember for error log below - - ! second try: look for daily file in year/month dir - fname_full = trim(fdir) // 'M' // MM // '/' // trim(fname_tmp) - - inquire(file=fname_full, exist=file_exists) - - if (file_exists) then - daily_files = .true. - return ! done - endif - - fname_full_tmp2 = trim(fname_full) ! remember for error log below - - ! third try: *without* "/Mmm" (month) dir - - ! THIS TRY IS PROBABLY OBSOLETE BUT COULD EASILY BE TWEAKED TO LOOK - ! IN year/month/day DIRECTORY (WHICH POSSIBLY APPLIES TO CORRECTED - ! PRECIP FROM GMAO OPS THAT IS INPUT INTO MERRA-2) - ! - reichle 10 May 2020 - - fname_full = trim(fdir) // trim(fname) - - inquire(file=fname_full, exist=file_exists) - - if (file_exists) return ! done - - fname_full_tmp3 = trim(fname_full) ! remember for error log below - - - ! last try: for GEOS FP with generic file names, try product counter '.V02.' in year/month dir - - if (trim(met_tag(1:11))=='GEOS.fp.asm') then - - fname_full = fname_full_tmp1 ! from first try - - ! GEOS.fp.asm.inst1_2d_lfo_Nx.20200507_0000.V01.nc4 - ! 1234567 - - tmpindend = len_trim(fname_full) - tmpind = len_trim(file_ext) - - tmpind = tmpindend - tmpind - 3 - - fname_full( tmpind:tmpind+2 ) = 'V02' ! --> *.V02.nc4 - - inquire(file=fname_full, exist=file_exists) - - end if - - - ! if no file was found, report file names that were tried - - if( .not. file_exists ) then - if(root_logit) then - print '(400A)', trim(Iam) // ': Could not find any of the following files:' - print '(400A)', trim(fname_full_tmp1) - print '(400A)', trim(fname_full_tmp2) - print '(400A)', trim(fname_full_tmp3) - print '(400A)', trim(fname_full) - endif - endif - - end subroutine get_GEOS_corr_prec_filename - - ! **************************************************************** - - subroutine get_GSWP2_1x1_netcdf(date_time, met_path, N_catd, tile_coord, & - met_force_new, nodata_forcing ) - - ! read GSWP2_NetCDF files and extract forcings in tile space - ! (uses nearest neighbor interpolation) - - ! reichle, 28 Jul 2005 - - implicit none - - type(date_time_type), intent(in) :: date_time - - character(*), intent(in) :: met_path - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force_new - - real, intent(out) :: nodata_forcing - - ! GEOS5-DAS grid and netcdf parameters - - integer, parameter :: gswp2_grid_N_lon = 360 - integer, parameter :: gswp2_grid_N_lat = 150 - real, parameter :: gswp2_grid_ll_lon = -180. - real, parameter :: gswp2_grid_ll_lat = -60. - real, parameter :: gswp2_grid_dlon = 1. - real, parameter :: gswp2_grid_dlat = 1. - - integer, parameter :: N_gswp2_compressed = 15238 - - ! GSWP2 forcing time step in hours - - integer, parameter :: dt_gswp2_in_hours = 3 - - integer, parameter :: nciv_land = 3 - integer, parameter :: nciv_data = 6 - - integer, parameter :: N_gswp2_vars = 9 - - real, parameter :: nodata_gswp2 = 1.e20 - - character(40), dimension(N_gswp2_vars), parameter :: gswp2_name = (/ & - 'SWdown_srb ', & ! 1 - flux - 'LWdown_srb ', & ! 2 - flux - 'Rainf_C_gswp ', & ! 3 - flux - 'Rainf_gswp ', & ! 4 - flux - 'Snowf_gswp ', & ! 5 - flux - 'PSurf_ecor ', & ! 6 - state - 'Qair_cru ', & ! 7 - state - 'Tair_cru ', & ! 8 - state - 'Wind_ncep ' /) ! 9 - state - - ! local variables - - real :: tol - - real, dimension(gswp2_grid_N_lon,gswp2_grid_N_lat) :: tmp_grid - - integer, dimension(N_gswp2_compressed) :: land_gswp2 - integer, dimension(N_gswp2_compressed) :: land_i_gswp2, land_j_gswp2 - integer, dimension(N_catd) :: i_ind, j_ind - - real, dimension(N_gswp2_compressed) :: tmp_vec - - real, dimension(N_catd,N_gswp2_vars) :: force_array - - integer, dimension(2) :: start, icount - - integer :: k, n, hours_in_month, gswp2_var, ierr, ncid - - integer :: int_dt_gswp2_in_seconds - - real :: this_lon, this_lat - - type(date_time_type) :: date_time_tmp - - character(4) :: YYYY - character(2) :: MM - - character(300) :: fname - - character(len=*), parameter :: Iam = 'get_GSWP2_1x1_netcdf' - character(len=400) :: err_msg - - ! -------------------------------------------------------------------- - - int_dt_gswp2_in_seconds = 3600*dt_gswp2_in_hours - - nodata_forcing = nodata_gswp2 - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - ! ---------------------------------------------- - ! - ! compute indices for nearest neighbor interpolation from GSWP2 grid - ! to tile space - ! - ! (NOTE: this should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - ! ll_lon and ll_lat refer to lower left corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - - this_lon = tile_coord(k)%com_lon - this_lat = tile_coord(k)%com_lat - - ! i_ind, j_ind count eastward and northward - ! (note that lat/lon coordinates in GSWP2 netcdf files - ! are eastward and southward) - - i_ind(k) = ceiling( (this_lon - gswp2_grid_ll_lon)/gswp2_grid_dlon ) - j_ind(k) = ceiling( (this_lat - gswp2_grid_ll_lat)/gswp2_grid_dlat ) - - end do - - ! ------------------------------------------------------ - ! - ! space dimension is same for all variables - - start(1) = 1 - icount(1) = N_gswp2_compressed - - ! check for possible error with time - - if ( (date_time%min/=0) .or. (date_time%sec/=0) .or. & - (mod(date_time%hour,dt_gswp2_in_hours)/=0) ) then - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'timing ERROR!!') - - end if - - ! ------------------------------------------------------ - ! - ! get forcing data - - do gswp2_var = 1,N_gswp2_vars - - ! time dimension - ! - ! First entry in GSWP2_NetCDF file is at 3Z, with fluxes for 0Z-3Z - ! - ! At 0Z for first day of month: - ! - for fluxes read first entry of that month - ! - for states read last entry of preceding month - ! At 3Z for first day of month: - ! - for fluxes read second entry of that month - ! - for states read first entry of that month - ! and so on... - - select case (gswp2_var) - - case (1,2,3,4,5) ! "fluxes" - - date_time_tmp = date_time - - case (6,7,8,9) ! "states" - - date_time_tmp = date_time - - call augment_date_time( -int_dt_gswp2_in_seconds, date_time_tmp ) - - case default - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'error') - - end select - - hours_in_month = (date_time_tmp%day-1)*24 + date_time_tmp%hour - - start(2) = hours_in_month / dt_gswp2_in_hours + 1 - icount(2) = 1 - - ! assemble year and month strings - - write (YYYY,'(i4.4)') date_time_tmp%year - write (MM, '(i2.2)') date_time_tmp%month - - ! assemble file name, open file - - fname = trim(met_path) // trim(gswp2_name(gswp2_var)) // '/' & - // '/' // trim(gswp2_name(gswp2_var)) // YYYY // MM // '.nc' - - if(root_logit) write (logunit,*) 'opening ' // trim(fname) - - ierr = NF_OPEN(fname,NF_NOWRITE,ncid) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! ------------------------------------------------------ - ! - ! read compression parameters (same for all data variables and time steps) - - if (gswp2_var == 1) then - - if(root_logit) write (logunit,*) 'get netcdf compression params from ' // trim(fname) - - if (ierr/=0) then - err_msg = 'error opening netcdf file' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ierr = NF_GET_VARA_INT(ncid, nciv_land, start, icount, land_gswp2) - - ! land_i_gswp2, land_j_gswp2 count eastward and southward - ! (note that lat/lon coordinates in GSWP2 netcdf files - ! are eastward and southward) - - do k=1,N_gswp2_compressed - - land_j_gswp2(k) = (land_gswp2(k)-1)/gswp2_grid_N_lon + 1 - land_i_gswp2(k) = & - land_gswp2(k) - (land_j_gswp2(k)-1)*gswp2_grid_N_lon - - end do - - end if - - ! ------------------------------------------------------ - ! - ! read compressed data, and put on global grid - - ierr = NF_GET_VARA_REAL(ncid, nciv_data, start, icount, tmp_vec ) - - ierr = NF_CLOSE(ncid) - - tmp_grid = nodata_forcing - - do n=1,N_gswp2_compressed - - tmp_grid(land_i_gswp2(n), land_j_gswp2(n) ) = tmp_vec(n) - - end do - - ! flip tmp_grid - ! (land_j_gswp2 counts southward, whereas j_ind counts northward) - - tmp_grid = tmp_grid(:,gswp2_grid_N_lat:1:-1) - - !!do k=1,gswp2_grid_N_lon - !! do n=1,gswp2_grid_N_lat - !! - !! write (999,*) k, n, tmp_grid(k,n) - !! - !! end do - !!end do - !!write (logunit,*) 'debug stop here' - !!stop - - ! interpolate to tile space - - ! (NOTE: This should at some point be replaced with a regridding - ! subroutine that interpolates from the - ! native forcing grid to the GCM atmospheric grid that is used - ! to cut catchments into tiles - then "standard" grid2tile - ! using tile_coord%atm_i and tile_coord%atm_j applies. - ! reichle, 26 May 2005) - - do k=1,N_catd - - force_array(k,gswp2_var) = tmp_grid(i_ind(k), j_ind(k)) - - end do - - end do - - ! convert variables and units of force_array to match met_force_type, - ! put into structure - - ! from GSWP2 files: - ! - ! force_array(:, 1) = SWdown_srb W/m2 - ! force_array(:, 2) = LWdown_srb W/m2 - ! force_array(:, 3) = Rainf_C_gswp kg/m2/s - ! force_array(:, 4) = Rainf_gswp kg/m2/s - ! force_array(:, 5) = Snowf_gswp kg/m2/s - ! force_array(:, 6) = PSurf_ecor Pa - ! force_array(:, 7) = Qair_cru kg/kg - ! force_array(:, 8) = Tair_cru K - ! force_array(:, 9) = Wind_ncep m/s - - met_force_new%SWdown = force_array(:,1) - met_force_new%LWdown = force_array(:,2) - met_force_new%Rainf_C = force_array(:,3) - met_force_new%Rainf = force_array(:,4) - met_force_new%Snowf = force_array(:,5) - met_force_new%Psurf = force_array(:,6) - met_force_new%Qair = force_array(:,7) - met_force_new%Tair = force_array(:,8) - met_force_new%Wind = force_array(:,9) - - end subroutine get_GSWP2_1x1_netcdf - - ! **************************************************************** - - subroutine check_forcing_nodata( N_catd, tile_coord, nodata_forcing, met_force ) - - ! Check for nodata values in met_force and fill with "neighboring" data if sensible; - ! otherwise, check_forcing_nodata() will abort. - ! Upon successful exit, there will *not* be nodata-values in met_force except - ! possibly RefH, which is not checked. - ! - ! (Note: subroutine repair_forcing() checks for unphysical values.) - ! - ! Owing to differences in land masks, some land-only forcing datasets may have - ! only nodata-values for some GEOS land tiles. There may also be intermittent - ! nodata-values in the forcing dataset. - ! If a nodata-value is encountered, use the value from the "next" tile, where - ! "next" is next in tile order, provided the "next" tile is within "max_distance". - ! Abort if this does not work. - ! The "next" tile approach is used to avoid the costly determination of the nearest - ! tile, which would require communications across processors and long loops. - ! For details, see helper subroutine check_forcing_nodata_2(), which also offers - ! a compile-time switch to create a list of all tiles that lack forcing data. - ! - ! reichle, 13 May 2003 - ! reichle, 13 Jun 2005 - ! reichle, 12 Feb 2021 - added "max_distance" limit, revised comments - ! reichle, 22 Apr 2021 - PAR must now also have "good" data at this stage, added to checks - - implicit none - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - real, intent(in) :: nodata_forcing - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force - - ! ------------------------------------------------------------ - - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Tair ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Qair ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Psurf ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Rainf_C) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Rainf ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Snowf ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%LWdown ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%SWdown ) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%PARdrct) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%PARdffs) - call check_forcing_nodata_2(N_catd,tile_coord,nodata_forcing,met_force%Wind ) - - ! do NOT call check_forcing_nodata_2() for "RefH" (should not have any problems) - - end subroutine check_forcing_nodata - - ! ***************************************************************** - - subroutine check_forcing_nodata_2( N_catd, tile_coord, nodata_forcing, force_vec ) - - ! helper subroutine for check_forcing_nodata() - ! - ! reichle, 13 Jun 2005 - ! reichle, 12 Feb 2021 - added "max_distance" limit, revised comments - - implicit none - - integer, intent(in) :: N_catd - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - real, intent(in) :: nodata_forcing - - real, dimension(:), intent(inout) :: force_vec - - ! local variables - - real, parameter :: max_distance = 0.5 ! [degrees] - - real :: tol, distsq_next - - integer :: i, i_next, N_exclude - - ! Set the following logical to .true. to generate an "ExcludeList" - ! for a given forcing data set. The list contains all tiles for - ! which the specified forcing dataset has only nodata-values - ! within "max_distance". The list will end up in the file - ! "fort.9999". Next, run "ldas_setup" again and exclude the - ! tiles in this list from the simulation domain (see "ExcludeList" - ! in "exeinp" setup file.) - - logical, parameter :: create_ExcludeList = .false. - - - character(len=*), parameter :: Iam = 'check_forcing_nodata_2' - character(len=400) :: err_msg - - ! ------------------------------------------------------------ - - N_exclude = 0 - - tol = abs(nodata_forcing*nodata_tolfrac_generic) - - do i=1,N_catd - - ! nodata-value checks - - i_next = min(i+1,N_catd) - - if (abs(force_vec(i)-nodata_forcing)tol) .and. & - (distsq_next .le. max_distance**2) ) then - - ! "next" tile has good forcing data and is within "max_distance" - ! --> use forcing from "next" tile for tile i, add note in log file. - - if (root_logit) write (logunit,*) 'forcing has nodata-value in tile ID = ', & - tile_coord(i)%tile_id, '. Using forcing from nearby tile.' - force_vec(i)=force_vec(i_next) - - else - - ! cannot find forcing data for tile i, abort with message - - write (tmpstring100,*) tile_coord(i)%tile_id - err_msg = 'forcing has nodata-value in tile ID = ' // trim(tmpstring100) // & - '. No good forcing nearby. ' // & - 'Use compile-time switch "create_ExcludeList" to create ' // & - 'a complete list for use in "ldas_setup".' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end if - - end if - - end do - - if (create_ExcludeList) then - if(root_logit) write (logunit,*) '---------------------------------------------------------------' - if(root_logit) write (logunit,*) ' found N_exclude = ',N_exclude, ' tiles that should be in ExcludeList' - err_msg = 'ExcludeList now in file fort.9999. Use this info in ldas_setup.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - end subroutine check_forcing_nodata_2 - - ! ****************************************************************** - - type(date_time_type) function shift_forcing_date( met_tag, date_time ) - - ! shift date_time by years or days, useful for twin experiments - ! - ! examples: - ! - ! met_tag = "RedArk_ASCII_shift-1year" uses 1980 forcing for 1981 and so on - ! met_tag = "RedArk_ASCII_shift+3day" uses Jan 4 forcing for Jan 1 and so on - ! - ! reichle, 6 Apr 2007 - - implicit none - - character(80) :: met_tag - - type(date_time_type) :: date_time, date_time_tmp - - integer :: is, ie, shift - - character(300) :: tmpstring300 - - ! initialize - - date_time_tmp = date_time - - ! check whether met_tag asks for shift - - is = index( met_tag, 'shift' ) - - if (is>0) then - - ! make sure this is only used for pre-specified forcing data sets - ! for now permit use with all "RedArk" data sets (reichle, 6 Apr 2007) - - if (index(met_tag,'RedArk')==0) then - - tmpstring300 = 'shift_forcing_date(): Are you sure? ' // & - 'If so, edit source code and recompile.' - - if(root_logit) write (logunit,*) tmpstring300 - write(0,*) tmpstring300 - stop - - end if - - ie = index( met_tag, 'year') - - if (ie>0) then - - read (met_tag(is+5:ie-1),'(i1)') shift - - date_time_tmp%year = date_time%year + shift - - ! deal with leap year issues - - if ( is_leap_year(date_time_tmp%year) .or. & - is_leap_year(date_time%year) ) then - - if (date_time%month==2 .and. date_time%day==29) & - date_time_tmp%day = 28 - - - call get_dofyr_pentad( date_time_tmp ) - - end if - - end if - - ie = index( met_tag, 'day') - - if (ie>0) then - - read (met_tag(is+5:ie-1),'(i1)') shift - - call augment_date_time( 86400*shift, date_time_tmp ) - - end if - - end if - - shift_forcing_date = date_time_tmp - - end function shift_forcing_date - - ! ****************************************************************** - -end module LDAS_ForceMod - -! ------------------------------------------------------------------- - -#if 0 - -program ut_parse_G5DAS_met_tag - - implicit none - - integer, parameter :: N_met_tag_in=6 - - ! "in" - character(200) :: met_path_in - character( 80) :: met_tag_in - - ! "out" - character(200) :: met_path_default, met_path_prec - character( 80) :: met_tag_out - - logical :: use_prec_corr - logical :: use_Predictor - - - ! other - integer :: ii - character( 80), dimension(N_met_tag_in) :: met_tag_in_vec - - - met_path_in = 'mymetpathin' - - met_tag_in_vec = (/ & - 'gcmexpname' , & - 'gcmexpname__Nx+-' , & - 'gcmexpname__precCORRPREC', & - 'gcmexpname__precCORRPREC__Nx+-' , & - 'gcmexpname__Nx+-__precCORRPREC' , & - 'gcmexpname__qrecCORRPREC__Nx+-' /) - - - do ii=1,N_met_tag_in - - met_tag_in = met_tag_in_vec(ii) - - write (*,*) '----------------------------------------------' - write (*,*) 'ii = ', ii - write (*,*) 'met_tag_in = ', trim(met_tag_in) - - call parse_G5DAS_met_tag( met_path_in, met_tag_in, & - met_path_default, met_path_prec, met_tag_out, use_prec_corr, use_Predictor ) - - write (*,*) 'met_path_default = ', trim(met_path_default) - write (*,*) 'met_path_prec = ', trim(met_path_prec) - write (*,*) 'met_tag_out = ', trim(met_tag_out) - write (*,*) 'use_prec_corr = ', use_prec_corr - write (*,*) 'use_Predictor = ', use_Predictor - - end do - -end program ut_parse_G5DAS_met_tag - -#endif - -#if 0 - -program test_shift_forcing_date - - use clsm_ensdrv_functions - use date_time_util - - type(date_time_type) :: date_time, date_time_tmp - - integer :: dtstep, iter, i - - character(80) :: met_tag - - ! ------- - - met_tag = 'RedArk_OSSE_shift+3day' - met_tag = 'Princeton_shift+3day' - - dtstep = 21600 - - iter = 120 - - date_time%year = 1992 ! 4-digit year - date_time%month = 2 ! month in year - date_time%day = 1 ! day in month - date_time%hour = 3 ! hour of day - date_time%min = 0 ! minute of hour - date_time%sec = 0 ! seconds of minute - date_time%pentad = -9999 ! pentad of year - date_time%dofyr = -9999 ! day of year - - do i=1,iter - - call augment_date_time(dtstep, date_time) - - date_time_tmp = shift_forcing_date(met_tag, date_time) - - write (*,'(16i5)') date_time, date_time_tmp - - - end do - -end program test_shift_forcing_date - -#endif - -! *********** EOF ************************************************** diff --git a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_HashTable.F90 b/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_HashTable.F90 deleted file mode 100644 index 67cf8604..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_HashTable.F90 +++ /dev/null @@ -1,181 +0,0 @@ -MODULE LDAS_HashTable - - IMPLICIT NONE ! Use strong typing - private - INTEGER, PARAMETER :: tbl_size = 50 - integer, parameter :: keylen = 512 - - TYPE nodelist - TYPE(nodelist), POINTER :: child => NULL() - CHARACTER(len=:), ALLOCATABLE :: key - integer :: fid - CONTAINS - PROCEDURE :: put => put_nodeinfo - PROCEDURE :: get => get_nodeinfo - PROCEDURE :: free => free_nodeinfo - END TYPE nodelist - - TYPE hash_table - TYPE(nodelist), DIMENSION(:), ALLOCATABLE :: vec - INTEGER :: vec_len = 0 - LOGICAL :: is_init = .FALSE. - integer :: max_file_N = 20 - integer :: counter = 0 - CONTAINS - PROCEDURE :: init => init_hash_table - PROCEDURE :: put => put_hash_table - PROCEDURE :: get => get_hash_table - PROCEDURE :: free => free_hash_table - END TYPE hash_table - PUBLIC :: nodelist - PUBLIC :: hash_table -CONTAINS - - RECURSIVE SUBROUTINE put_nodeinfo(list,key,fid) - CLASS(nodelist),target, INTENT(inout) :: list - CHARACTER(len=*), INTENT(in) :: key - integer, INTENT(in) :: fid - ! local - INTEGER :: klen - - klen = LEN(key) - if ( klen > keylen) then - print*, key - stop (' key loo long') - endif - - IF (ALLOCATED(list%key)) THEN - IF (trim(list%key) /= trim(key)) THEN - IF ( .NOT. ASSOCIATED(list%child) ) then - ALLOCATE(list%child) - ENDIF - CALL put_nodeinfo(list%child,key,fid) - END IF - ELSE - IF (.NOT. ALLOCATED(list%key)) & - ALLOCATE(CHARACTER(len=keylen) :: list%key) - - list%key = key - list%fid = fid - - END IF - END SUBROUTINE put_nodeinfo - - RECURSIVE SUBROUTINE get_nodeinfo(list,key,fid) - CLASS(nodelist), target, INTENT(in) :: list - CHARACTER(len=*), INTENT(in) :: key - integer, INTENT(out) :: fid - - if (ALLOCATED(list%key)) then - if (trim(list%key) == trim(key)) THEN - fid = list%fid - return - endif - endif - - IF(ASSOCIATED(list%child)) THEN ! keep going - CALL get_nodeinfo(list%child,key,fid) - ELSE ! At the end of the list, no key found - fid = -9999 - END IF - - END SUBROUTINE get_nodeinfo - - RECURSIVE SUBROUTINE free_nodeinfo(list,closefile) - CLASS(nodelist), INTENT(inout) :: list - external :: closefile - integer :: rc - - IF (ASSOCIATED(list%child)) THEN - CALL free_nodeinfo(list%child, closefile ) - DEALLOCATE(list%child) - END IF - - IF (ALLOCATED(list%key)) then - call closefile(list%fid) - DEALLOCATE(list%key) - ENDIF - - END SUBROUTINE free_nodeinfo - - SUBROUTINE init_hash_table(tbl,tbl_len) - CLASS(hash_table), INTENT(inout) :: tbl - INTEGER, OPTIONAL, INTENT(in) :: tbl_len - - if(tbl%is_init) return - - IF (allocated(tbl%vec)) DEALLOCATE(tbl%vec) - IF (PRESENT(tbl_len)) THEN - ALLOCATE(tbl%vec(0:tbl_len-1)) - tbl%vec_len = tbl_len - ELSE - ALLOCATE(tbl%vec(0:tbl_size-1)) - tbl%vec_len = tbl_size - END IF - tbl%is_init = .TRUE. - END SUBROUTINE init_hash_table - - ! The first part of the hashing procedure using the string - ! collating sequence - ELEMENTAL FUNCTION sum_string(str) RESULT(sig) - CHARACTER(len=*), INTENT(in) :: str - INTEGER :: sig - CHARACTER, DIMENSION(LEN(str)) :: tmp - INTEGER :: i - - FORALL (i=1:LEN(str)) - tmp(i) = str(i:i) - END FORALL - sig = SUM(ICHAR(tmp)) - END FUNCTION sum_string - - SUBROUTINE put_hash_table(tbl,key,fid) - CLASS(hash_table), INTENT(inout) :: tbl - CHARACTER(len=*), INTENT(in) :: key - integer, INTENT(in) :: fid - !local - INTEGER :: hash - - hash = MOD(sum_string(key),tbl%vec_len) - CALL tbl%vec(hash)%put(key,fid) - tbl%counter = tbl%counter + 1 - END SUBROUTINE put_hash_table - - - SUBROUTINE get_hash_table(tbl,key,fid) - CLASS(hash_table),INTENT(in) :: tbl - CHARACTER(len=*), INTENT(in) :: key - integer, INTENT(out) :: fid - - ! local - INTEGER :: hash - - hash = MOD(sum_string(key),tbl%vec_len) - CALL tbl%vec(hash)%get(key,fid) - END SUBROUTINE get_hash_table - - - SUBROUTINE free_hash_table(tbl,closefile,forced) - CLASS(hash_table), INTENT(inout) :: tbl - INTEGER :: i, low, high - external :: closefile - logical,intent(in) :: forced ! force to clean up - - if((.not. forced) .and. (tbl%counter < tbl%max_file_N)) return - - IF (allocated(tbl%vec)) THEN - low = LBOUND(tbl%vec,dim=1) - high = UBOUND(tbl%vec,dim=1) - DO i=low,high - CALL tbl%vec(i)%free(closefile) - END DO - DEALLOCATE(tbl%vec) - END IF - - tbl%vec_len = 0 - tbl%counter = 0 - tbl%is_init = .FALSE. - - END SUBROUTINE free_hash_table - -END MODULE LDAS_HashTable diff --git a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Interp.F90 b/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Interp.F90 deleted file mode 100644 index 918bfcd3..00000000 --- a/src/Components/GEOSldas_GridComp/GEOSmetforce_GridComp/LDAS_Interp.F90 +++ /dev/null @@ -1,283 +0,0 @@ -#include "MAPL_ErrLog.h" - -module LDAS_InterpMod - - use ESMF - use MAPL_mod - use LDAS_DateTimeMod, only: date_time_type, datetime2_minus_datetime1 - use LDAS_DriverTypes, only: met_force_type, assignment (=) - use LDAS_ensdrv_Globals, only: nodata_generic, nodata_tol_generic - - implicit none - - private - - public :: metforcing_tinterp - - real, parameter :: min_zth = 0.0001 - -contains - - subroutine metforcing_tinterp( & - lons, & - lats, & - zth, & - zenav, & - force_time_prv, & - model_time_nxt, & - force_dtstep, & - mf_prv, & - mf_nxt, & - mf_ntp, & - AEROSOL_DEPOSITION, & - rc & - ) - - ! Interpolates the forcing data to current timestep. - ! - ! model_time_nxt = date_time at the *end* of model integration time step - ! - ! "mf" = "met_force" - ! - ! "mf_prv" = at prv forcing time - ! "mf_nxt" = at nxt forcing time - ! "mf_ntp" = at current ("interpolated") time - ! - ! NOTE: time avg radiative fluxes for the interval between "prv" - ! and "nxt" time must be stored in mf_prv - ! - ! reichle, 14 May 2003 - ! reichle, 11 Sep 2007 - albedo changes - ! reichle, 23 Feb 2009 - add ParDrct, ParDffs from MERRA forcing - ! reichle, 6 Mar 2009 - added fractional day-of-year (fdofyr) for monthly interp - ! - deleted ParDrct, ParDffs after testing found no impact - ! reichle, 20 Dec 2011 - reinstated "PARdrct", "PARdffs" for MERRA-Land file specs - ! - cleanup - ! reichle, 26 Jul 2013 - revised GRN, LAI and albedo scaling parameter inputs - - implicit none - - real, intent(in) :: lats(:) ! tile lats - real, intent(in) :: lons(:) ! tile lons - ! fix potential inconsistency between zth and zenav owing to 300s time - ! step used in MAPL_SunGetInsolation() - ! in ==>inout - real, intent(inout) :: zth(:) ! zenith angle (>=0) - real, intent(inout) :: zenav(:) ! avg zenith angle (>=0) over forcing period - type(date_time_type), intent(in) :: model_time_nxt - type(date_time_type), intent(in) :: force_time_prv - integer, intent(in) :: force_dtstep - type(met_force_type), intent(in) :: mf_prv(:) - type(met_force_type), intent(in) :: mf_nxt(:) - type(met_force_type), intent(out) :: mf_ntp(:) - integer,intent(in) :: AEROSOL_DEPOSITION - integer, optional, intent(out) :: rc - - real :: w - integer :: secs_since_prv, secs_in_day - integer :: n, nTiles - real :: sunang_ntp, tmpreal - character(len=*), parameter :: Iam = 'metforcing_tinterp' - - ! get secs_in_day from hh:mm:ss - secs_in_day = model_time_nxt%hour*3600 + model_time_nxt%min*60 & - + model_time_nxt%sec - - ! weight for forcing "states" interpolation - ! (temperature, humidity, pressure, wind) - secs_since_prv = datetime2_minus_datetime1( force_time_prv, model_time_nxt ) - - ! use INTEGER DIVISION such that w changes from 0. to 1. - ! halfway through the current forcing interval, that is, - ! - ! w = 0. if secs_since_prv < force_dtstep/2 - ! w = 0.5 if secs_since_prv == force_dtstep/2 - ! w = 1. if force_dtstep/2 < secs_since_prv <= force_dtstep - ! - ! For example, using 15 min model time steps and hourly forcing, - ! the time interpolation weights are as follows: - ! - ! secs_since_prv: 900 1800 2700 3600 - ! w: 0. 0.5 1. 1. - ! - ! Note that w=0.5 for secs_since_prv==force_dtstep/2 (at the mid-point). - if (secs_since_prv==force_dtstep/2) then - w = 0.5 - else - w = real( (secs_since_prv-1)/(force_dtstep/2) ) - end if - - nTiles = size(mf_prv) - - do n=1,nTiles - - ! initialize - mf_ntp(n) = nodata_generic - - ! STATES - ! - ! temperature, humidity, pressure and wind - - mf_ntp(n)%Tair = (1.-w)*mf_prv(n)%Tair + w*mf_nxt(n)%Tair - mf_ntp(n)%Qair = (1.-w)*mf_prv(n)%Qair + w*mf_nxt(n)%Qair - mf_ntp(n)%Psurf = (1.-w)*mf_prv(n)%Psurf + w*mf_nxt(n)%Psurf - mf_ntp(n)%RefH = (1.-w)*mf_prv(n)%RefH + w*mf_nxt(n)%RefH - - ! Wind - - ! LDASsa CVS tags between reichle-LDASsa_m2-10 and reichle-LDASsa_m2-13_p2 - ! worked with *inst*lfo* and *tavg*lfo* G5DAS forcing (as opposed to just - ! *tavg*lfo* from MERRA) and G5DAS Wind was read from *inst*lfo* files. - ! But for G5DAS forcing (as for MERRA), Wind was treated as a time-average - ! field, which implied that, e.g., the instantaneous G5DAS Wind at 0z was - ! used to force the land at 0:20z, 0:40z, and 1z. - ! In these tags, Wind was treated as a time-average field whenever - ! force_dtstep<=3601, which included MERRA, G5DAS, RedArk, and CONUS - ! forcing. - ! To make things more consistent for G5DAS winds, the "if" statement now - ! checks whether Wind at date_time_nxt is available (which is true G5DAS - ! and false for MERRA). The revised "if" statement does not change how - ! Wind is interpolated in MERRA (because Wind is unavailable at date_time_nxt) - ! and in GLDAS, Princeton, and GWSP (because force_dtstep>3601). - ! The revised "if" statement does change how CONUS and RedArk Wind data - ! are interpolated (now treated as instantaneous, previously treated as - ! time-average). - ! In summary, as of this change, Wind is treated as instantaneous for all - ! forcing data *except* MERRA. - ! - ! - reichle, 31 Jan 2014 - - ! if (force_dtstep_real > 3601.) then - if (abs(mf_nxt(n)%Wind-nodata_generic)>nodata_tol_generic) then - ! treat Wind as instantaneous fields (all forcing data sets *except* MERRA) - mf_ntp(n)%Wind = (1.-w)*mf_prv(n)%Wind + w*mf_nxt(n)%Wind - else - ! treat Wind as time-average fields (MERRA) - mf_ntp(n)%Wind = mf_prv(n)%Wind - end if - - ! FLUXES - - ! precipitation - mf_ntp(n)%Rainf_C = mf_prv(n)%Rainf_C - mf_ntp(n)%Rainf = mf_prv(n)%Rainf - mf_ntp(n)%Snowf = mf_prv(n)%Snowf - - ! incoming radiation - mf_ntp(n)%LWdown = mf_prv(n)%LWdown - - ! changed min sun-angle from 0.01 to 0.0001 for consistency with CatchGridComp - ! reichle, 23 Feb 2009 - ! changed min sun-angle back to 0.01 after testing - ! reichle, 27 Feb 2009 - sunang_ntp = max(zth(n), min_zth) - - ! changed minimum SWdown to 0. from 0.00001 - reichle, 28 Aug 2008 - ! fix potential inconsistency between zth and zenav owing to 300s time - ! step used in MAPL_SunGetInsolation() - if (abs(zenav(n)) <= 0.000001) then - zth(n) = 0. - zenav(n) = 0. - endif - - if (zth(n) > 0.) then - - if (zenav(n) <= 0.) then - RETURN_(ESMF_FAILURE) - end if - - tmpreal = zth(n)/zenav(n) - mf_ntp(n)%SWdown = mf_prv(n)%SWdown*tmpreal - ! wjiang+reichle, 22 Apr 2021 - "PARdrct" and "PARdffs" now - ! backfilled in get_forcing(), arrive here with only "good" values - mf_ntp(n)%PARdrct = mf_prv(n)%PARdrct*tmpreal - mf_ntp(n)%PARdffs = mf_prv(n)%PARdffs*tmpreal - - elseif ((zth(n) <= 0.) .and. (zenav(n) <= 0.)) then ! not sure this makes sense, leave for now, - reichle, 23 Apr 2021 - - mf_ntp(n)%SWdown = max(0., mf_prv(n)%SWdown) - mf_ntp(n)%PARdrct = max(0., mf_prv(n)%PARdrct) - mf_ntp(n)%PARdffs = max(0., mf_prv(n)%PARdffs) - - else - - mf_ntp(n)%SWdown = 0. - mf_ntp(n)%PARdrct = 0. - mf_ntp(n)%PARdffs = 0. - - end if - - ! cap shortwave radiation at (cosine of) sun angle times solar constant - ! reichle, 14 Aug 2002 - mf_ntp(n)%SWdown = min( mf_ntp(n)%SWdown, 1360.*sunang_ntp ) ! this should probably applied proportionally to PAR, - reichle, 23 Apr 2021 - - end do - - if (AEROSOL_DEPOSITION /=0 .and. nTiles >=1 ) then - mf_ntp%DUDP001 = mf_prv%DUDP001 - mf_ntp%DUDP002 = mf_prv%DUDP002 - mf_ntp%DUDP003 = mf_prv%DUDP003 - mf_ntp%DUDP004 = mf_prv%DUDP004 - mf_ntp%DUDP005 = mf_prv%DUDP005 - mf_ntp%DUSV001 = mf_prv%DUSV001 - mf_ntp%DUSV002 = mf_prv%DUSV002 - mf_ntp%DUSV003 = mf_prv%DUSV003 - mf_ntp%DUSV004 = mf_prv%DUSV004 - mf_ntp%DUSV005 = mf_prv%DUSV005 - mf_ntp%DUWT001 = mf_prv%DUWT001 - mf_ntp%DUWT002 = mf_prv%DUWT002 - mf_ntp%DUWT003 = mf_prv%DUWT003 - mf_ntp%DUWT004 = mf_prv%DUWT004 - mf_ntp%DUWT005 = mf_prv%DUWT005 - mf_ntp%DUSD001 = mf_prv%DUSD001 - mf_ntp%DUSD002 = mf_prv%DUSD002 - mf_ntp%DUSD003 = mf_prv%DUSD003 - mf_ntp%DUSD004 = mf_prv%DUSD004 - mf_ntp%DUSD005 = mf_prv%DUSD005 - mf_ntp%BCDP001 = mf_prv%BCDP001 - mf_ntp%BCDP002 = mf_prv%BCDP002 - mf_ntp%BCSV001 = mf_prv%BCSV001 - mf_ntp%BCSV002 = mf_prv%BCSV002 - mf_ntp%BCWT001 = mf_prv%BCWT001 - mf_ntp%BCWT002 = mf_prv%BCWT002 - mf_ntp%BCSD001 = mf_prv%BCSD001 - mf_ntp%BCSD002 = mf_prv%BCSD002 - mf_ntp%OCDP001 = mf_prv%OCDP001 - mf_ntp%OCDP002 = mf_prv%OCDP002 - mf_ntp%OCSV001 = mf_prv%OCSV001 - mf_ntp%OCSV002 = mf_prv%OCSV002 - mf_ntp%OCWT001 = mf_prv%OCWT001 - mf_ntp%OCWT002 = mf_prv%OCWT002 - mf_ntp%OCSD001 = mf_prv%OCSD001 - mf_ntp%OCSD002 = mf_prv%OCSD002 - mf_ntp%SUDP003 = mf_prv%SUDP003 - mf_ntp%SUSV003 = mf_prv%SUSV003 - mf_ntp%SUWT003 = mf_prv%SUWT003 - mf_ntp%SUSD003 = mf_prv%SUSD003 - mf_ntp%SSDP001 = mf_prv%SSDP001 - mf_ntp%SSDP002 = mf_prv%SSDP002 - mf_ntp%SSDP003 = mf_prv%SSDP003 - mf_ntp%SSDP004 = mf_prv%SSDP004 - mf_ntp%SSDP005 = mf_prv%SSDP005 - mf_ntp%SSSV001 = mf_prv%SSSV001 - mf_ntp%SSSV002 = mf_prv%SSSV002 - mf_ntp%SSSV003 = mf_prv%SSSV003 - mf_ntp%SSSV004 = mf_prv%SSSV004 - mf_ntp%SSSV005 = mf_prv%SSSV005 - mf_ntp%SSWT001 = mf_prv%SSWT001 - mf_ntp%SSWT002 = mf_prv%SSWT002 - mf_ntp%SSWT003 = mf_prv%SSWT003 - mf_ntp%SSWT004 = mf_prv%SSWT004 - mf_ntp%SSWT005 = mf_prv%SSWT005 - mf_ntp%SSSD001 = mf_prv%SSSD001 - mf_ntp%SSSD002 = mf_prv%SSSD002 - mf_ntp%SSSD003 = mf_prv%SSSD003 - mf_ntp%SSSD004 = mf_prv%SSSD004 - mf_ntp%SSSD005 = mf_prv%SSSD005 - endif - - RETURN_(ESMF_SUCCESS) - - end subroutine metforcing_tinterp - -end module LDAS_InterpMod diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/CMakeLists.txt b/src/Components/GEOSldas_GridComp/LDAS_Shared/CMakeLists.txt deleted file mode 100644 index f1cc3dd8..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -set (this GEOS_LdasShared) - -set (SRCS - enkf_types.F90 catch_types.F90 LDAS_ensdrv_Globals.F90 LDAS_DriverTypes.F90 - LDAS_Convert.F90 LDAS_Exceptions.F90 LDAS_TileCoordType.F90 LDAS_PertTypes.F90 - LDAS_ensdrv_functions.F90 my_matrix_functions.F90 - LDAS_TileCoordRoutines.F90 - LDAS_RepairForcing.F90 - LDAS_ensdrv_mpi.F90 - ) - -list (APPEND SRCS - nr_indexx.f my_lu_decomp.f - ) - -esma_add_library(${this} - SRCS ${SRCS} - DEPENDENCIES MAPL GEOS_Shared GEOS_LandShared makebcs - INCLUDES ${INC_ESMF} ${INC_NETCDF}) diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Convert.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Convert.F90 deleted file mode 100644 index 71b4acb9..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Convert.F90 +++ /dev/null @@ -1,49 +0,0 @@ -#include "MAPL_Generic.h" - -module LDAS_ConvertMod - - use ESMF - use MAPL_mod - use LDAS_DateTimeMod, only: date_time_type - use LDAS_DateTimeMod, only: get_dofyr_pentad - - implicit none - - private - - public :: esmf2ldas - - interface esmf2ldas - module procedure esmf2ldas_time - end interface esmf2ldas - -contains - - subroutine esmf2ldas_time(esmf_dt, ldas_dt, rc) - - type(ESMF_Time), intent(in) :: esmf_dt - type(date_time_type), intent(out) :: ldas_dt - integer, optional, intent(out) :: rc - - character(len=*), parameter :: Iam = 'emsf2ldas_time' - integer :: status - - call ESMF_TimeGet( & - esmf_dt, & - YY=ldas_dt%year, & - MM=ldas_dt%month, & - DD=ldas_dt%day, & - H=ldas_dt%hour, & - M=ldas_dt%min, & - S=ldas_dt%sec, & - rc=status & - ) - VERIFY_(status) - - call get_dofyr_pentad( ldas_dt ) - - RETURN_(ESMF_SUCCESS) - - end subroutine esmf2ldas_time - -end module LDAS_ConvertMod diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_DriverTypes.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_DriverTypes.F90 deleted file mode 100644 index 153a5252..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_DriverTypes.F90 +++ /dev/null @@ -1,691 +0,0 @@ - -module LDAS_DriverTypes - - ! definition of types and associated operators for Catchment Model driver - ! - ! IMPORTANT: - ! When adding a field to any of the derived types, must also update - ! the associated assignment and operator definitions. - ! THERE IS NO WARNING/ERROR IF OPERATOR IS NOT DEFINED FOR ALL FIELDS! - ! - ! reichle, 10 May 2005 - ! reichle, 10 Jun 2005 - converted met_force_type to ALMA - ! reichle, 10 Sep 2007 - added modis_alb_param_type - ! reichle+qliu, 8 Oct 2008 (and earlier) - added fields "RefH" and "SWnet" - ! for DAS/LDASsa integration - ! reichle, 23 Feb 2009 - added fields ParDrct, ParDffs for MERRA - ! reichle, 5 Mar 2009 - deleted ParDrct, ParDffs after testing found no impact - ! reichle, 30 Sep 2009 - changed "out_avg_type" to "out_select_type" - ! reichle, 8 Dec 2011 - added "veg_param_type" and "bal_diagn_type" - ! reichle, 20 Dec 2011 - reinstated met_force fields "PARdrct" and "PARdffs" - ! for MERRA-Land output specs - ! reichle, 5 Apr 2013 - removed modis_alb_param_type fields "sc_albvr", "sc_albnr" - ! reichle, 23 Jul 2013 - renamed "modis_alb_param" --> "alb_param" - ! reichle, 23 Apr 2021 - removed "SWnet" - ! - ! -------------------------------------------------------------------------- - - implicit none - - ! everything is private by default unless made public - - private - - public :: met_force_type, veg_param_type, bal_diagn_type - public :: alb_param_type - public :: assignment (=), operator (/), operator (+), operator (*) - - ! --------------------------------------------------------------------- - ! - ! meteorological forcing variables - ! - ! The Catchment model driver requires forcing fields of the types - ! and units in the structure met_force_type. - ! Make sure to convert the native types and units of each forcing - ! data set into the types and units of met_force_type right after - ! the native data have been read. See for example get_Berg_netcdf(). - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: met_force_type - real :: Tair ! air temperature at RefH [K] - real :: Qair ! specific humidity at RefH [kg/kg] - real :: Psurf ! surface pressure [Pa] - real :: Rainf_C ! convective rainfall [kg/m2/s] - real :: Rainf ! total rainfall [kg/m2/s] - real :: Snowf ! total snowfall [kg/m2/s] - real :: LWdown ! downward longwave radiation [W/m2] - real :: SWdown ! downward shortwave radiation [W/m2] - real :: PARdrct ! Photosynth. Active Radiation (direct) [W/m2] - real :: PARdffs ! Photosynth. Active Radiation (diffuse) [W/m2] - real :: Wind ! wind speed at RefH [m/s] - real :: RefH ! reference height for Tair, Qair, Wind [m] - - ! GOSWIM aerosol forcing - ! - real :: DUDP001 ! below all units are [kg/m2/s] - real :: DUDP002 - real :: DUDP003 - real :: DUDP004 - real :: DUDP005 - real :: DUSV001 - real :: DUSV002 - real :: DUSV003 - real :: DUSV004 - real :: DUSV005 - real :: DUWT001 - real :: DUWT002 - real :: DUWT003 - real :: DUWT004 - real :: DUWT005 - real :: DUSD001 - real :: DUSD002 - real :: DUSD003 - real :: DUSD004 - real :: DUSD005 - real :: BCDP001 - real :: BCDP002 - real :: BCSV001 - real :: BCSV002 - real :: BCWT001 - real :: BCWT002 - real :: BCSD001 - real :: BCSD002 - real :: OCDP001 - real :: OCDP002 - real :: OCSV001 - real :: OCSV002 - real :: OCWT001 - real :: OCWT002 - real :: OCSD001 - real :: OCSD002 - real :: SUDP003 - real :: SUSV003 - real :: SUWT003 - real :: SUSD003 - real :: SSDP001 - real :: SSDP002 - real :: SSDP003 - real :: SSDP004 - real :: SSDP005 - real :: SSSV001 - real :: SSSV002 - real :: SSSV003 - real :: SSSV004 - real :: SSSV005 - real :: SSWT001 - real :: SSWT002 - real :: SSWT003 - real :: SSWT004 - real :: SSWT005 - real :: SSSD001 - real :: SSSD002 - real :: SSSD003 - real :: SSSD004 - real :: SSSD005 - - end type met_force_type - - ! --------------------------------------------------------------------- - ! - ! vegetation variables - ! - ! The Catchment model requires seasonally varying greenness and leaf-area-index - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: veg_param_type - real :: grn ! vegetation greenness fraction [-] - real :: lai ! leaf-area-index [m2/m2] - end type veg_param_type - - ! --------------------------------------------------------------------- - ! - ! water and energy balance diagnostic variables - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: bal_diagn_type - real :: etotl ! total energy store (in all model progn) [J/m2] - real :: echng ! energy change per unit time (model only) [W/m2] - real :: eincr ! energy analysis increment per unit time [W/m2] - real :: wtotl ! total water store (in all model progn) [kg/m2] - real :: wchng ! water change per unit time (model only) [kg/m2/s] - real :: wincr ! water analysis increment per unit time [kg/m2/s] - end type bal_diagn_type - - - ! --------------------------------------------------------------- - ! - ! albedo scaling factors - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: alb_param_type - real :: sc_albvf ! Scaling factor for diffuse visible or whitesky 0.3-0.7 - real :: sc_albnf ! Scaling factor for diffuse infrared or whitesky 0.7-5.0 - end type alb_param_type - - ! -------------------------------------------------------------- - - interface assignment (=) - module procedure scalar2met_force - module procedure scalar2veg_param - module procedure scalar2bal_diagn - module procedure scalar2alb_param - end interface - - interface operator (/) - module procedure met_force_div_scalar - module procedure veg_param_div_scalar - module procedure bal_diagn_div_scalar - end interface - - interface operator (*) - module procedure alb_param_times_scalar ! Need both definitions to - module procedure scalar_times_alb_param ! define a*b and b*a - end interface - - interface operator (+) - module procedure add_met_force - module procedure add_veg_param - module procedure add_bal_diagn - module procedure add_alb_param - end interface - -contains - - ! -------------------------------------------------- - - subroutine scalar2met_force( met_force, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(met_force_type), intent(out) :: met_force - - met_force%Tair = scalar - met_force%Qair = scalar - met_force%Psurf = scalar - met_force%Rainf_C = scalar - met_force%Rainf = scalar - met_force%Snowf = scalar - met_force%LWdown = scalar - met_force%SWdown = scalar - met_force%PARdrct = scalar - met_force%PARdffs = scalar - met_force%Wind = scalar - met_force%RefH = scalar - - met_force%DUDP001 = scalar - met_force%DUDP002 = scalar - met_force%DUDP003 = scalar - met_force%DUDP004 = scalar - met_force%DUDP005 = scalar - met_force%DUSV001 = scalar - met_force%DUSV002 = scalar - met_force%DUSV003 = scalar - met_force%DUSV004 = scalar - met_force%DUSV005 = scalar - met_force%DUWT001 = scalar - met_force%DUWT002 = scalar - met_force%DUWT003 = scalar - met_force%DUWT004 = scalar - met_force%DUWT005 = scalar - met_force%DUSD001 = scalar - met_force%DUSD002 = scalar - met_force%DUSD003 = scalar - met_force%DUSD004 = scalar - met_force%DUSD005 = scalar - met_force%BCDP001 = scalar - met_force%BCDP002 = scalar - met_force%BCSV001 = scalar - met_force%BCSV002 = scalar - met_force%BCWT001 = scalar - met_force%BCWT002 = scalar - met_force%BCSD001 = scalar - met_force%BCSD002 = scalar - met_force%OCDP001 = scalar - met_force%OCDP002 = scalar - met_force%OCSV001 = scalar - met_force%OCSV002 = scalar - met_force%OCWT001 = scalar - met_force%OCWT002 = scalar - met_force%OCSD001 = scalar - met_force%OCSD002 = scalar - met_force%SUDP003 = scalar - met_force%SUSV003 = scalar - met_force%SUWT003 = scalar - met_force%SUSD003 = scalar - met_force%SSDP001 = scalar - met_force%SSDP002 = scalar - met_force%SSDP003 = scalar - met_force%SSDP004 = scalar - met_force%SSDP005 = scalar - met_force%SSSV001 = scalar - met_force%SSSV002 = scalar - met_force%SSSV003 = scalar - met_force%SSSV004 = scalar - met_force%SSSV005 = scalar - met_force%SSWT001 = scalar - met_force%SSWT002 = scalar - met_force%SSWT003 = scalar - met_force%SSWT004 = scalar - met_force%SSWT005 = scalar - met_force%SSSD001 = scalar - met_force%SSSD002 = scalar - met_force%SSSD003 = scalar - met_force%SSSD004 = scalar - met_force%SSSD005 = scalar - - end subroutine scalar2met_force - - ! --------------------------------------------------- - - function met_force_div_scalar( met_force, scalar ) - - implicit none - - type(met_force_type) :: met_force_div_scalar - type(met_force_type), intent(in) :: met_force - - real, intent(in) :: scalar - - met_force_div_scalar%Tair = met_force%Tair / scalar - met_force_div_scalar%Qair = met_force%Qair / scalar - met_force_div_scalar%Psurf = met_force%Psurf / scalar - met_force_div_scalar%Rainf_C = met_force%Rainf_C / scalar - met_force_div_scalar%Rainf = met_force%Rainf / scalar - met_force_div_scalar%Snowf = met_force%Snowf / scalar - met_force_div_scalar%LWdown = met_force%LWdown / scalar - met_force_div_scalar%SWdown = met_force%SWdown / scalar - met_force_div_scalar%PARdrct = met_force%PARdrct / scalar - met_force_div_scalar%PARdffs = met_force%PARdffs / scalar - met_force_div_scalar%Wind = met_force%Wind / scalar - met_force_div_scalar%RefH = met_force%RefH / scalar - - met_force_div_scalar%DUDP001 = met_force%DUDP001 / scalar - met_force_div_scalar%DUDP002 = met_force%DUDP002 / scalar - met_force_div_scalar%DUDP003 = met_force%DUDP003 / scalar - met_force_div_scalar%DUDP004 = met_force%DUDP004 / scalar - met_force_div_scalar%DUDP005 = met_force%DUDP005 / scalar - met_force_div_scalar%DUSV001 = met_force%DUSV001 / scalar - met_force_div_scalar%DUSV002 = met_force%DUSV002 / scalar - met_force_div_scalar%DUSV003 = met_force%DUSV003 / scalar - met_force_div_scalar%DUSV004 = met_force%DUSV004 / scalar - met_force_div_scalar%DUSV005 = met_force%DUSV005 / scalar - met_force_div_scalar%DUWT001 = met_force%DUWT001 / scalar - met_force_div_scalar%DUWT002 = met_force%DUWT002 / scalar - met_force_div_scalar%DUWT003 = met_force%DUWT003 / scalar - met_force_div_scalar%DUWT004 = met_force%DUWT004 / scalar - met_force_div_scalar%DUWT005 = met_force%DUWT005 / scalar - met_force_div_scalar%DUSD001 = met_force%DUSD001 / scalar - met_force_div_scalar%DUSD002 = met_force%DUSD002 / scalar - met_force_div_scalar%DUSD003 = met_force%DUSD003 / scalar - met_force_div_scalar%DUSD004 = met_force%DUSD004 / scalar - met_force_div_scalar%DUSD005 = met_force%DUSD005 / scalar - met_force_div_scalar%BCDP001 = met_force%BCDP001 / scalar - met_force_div_scalar%BCDP002 = met_force%BCDP002 / scalar - met_force_div_scalar%BCSV001 = met_force%BCSV001 / scalar - met_force_div_scalar%BCSV002 = met_force%BCSV002 / scalar - met_force_div_scalar%BCWT001 = met_force%BCWT001 / scalar - met_force_div_scalar%BCWT002 = met_force%BCWT002 / scalar - met_force_div_scalar%BCSD001 = met_force%BCSD001 / scalar - met_force_div_scalar%BCSD002 = met_force%BCSD002 / scalar - met_force_div_scalar%OCDP001 = met_force%OCDP001 / scalar - met_force_div_scalar%OCDP002 = met_force%OCDP002 / scalar - met_force_div_scalar%OCSV001 = met_force%OCSV001 / scalar - met_force_div_scalar%OCSV002 = met_force%OCSV002 / scalar - met_force_div_scalar%OCWT001 = met_force%OCWT001 / scalar - met_force_div_scalar%OCWT002 = met_force%OCWT002 / scalar - met_force_div_scalar%OCSD001 = met_force%OCSD001 / scalar - met_force_div_scalar%OCSD002 = met_force%OCSD002 / scalar - met_force_div_scalar%SUDP003 = met_force%SUDP003 / scalar - met_force_div_scalar%SUSV003 = met_force%SUSV003 / scalar - met_force_div_scalar%SUWT003 = met_force%SUWT003 / scalar - met_force_div_scalar%SUSD003 = met_force%SUSD003 / scalar - met_force_div_scalar%SSDP001 = met_force%SSDP001 / scalar - met_force_div_scalar%SSDP002 = met_force%SSDP002 / scalar - met_force_div_scalar%SSDP003 = met_force%SSDP003 / scalar - met_force_div_scalar%SSDP004 = met_force%SSDP004 / scalar - met_force_div_scalar%SSDP005 = met_force%SSDP005 / scalar - met_force_div_scalar%SSSV001 = met_force%SSSV001 / scalar - met_force_div_scalar%SSSV002 = met_force%SSSV002 / scalar - met_force_div_scalar%SSSV003 = met_force%SSSV003 / scalar - met_force_div_scalar%SSSV004 = met_force%SSSV004 / scalar - met_force_div_scalar%SSSV005 = met_force%SSSV005 / scalar - met_force_div_scalar%SSWT001 = met_force%SSWT001 / scalar - met_force_div_scalar%SSWT002 = met_force%SSWT002 / scalar - met_force_div_scalar%SSWT003 = met_force%SSWT003 / scalar - met_force_div_scalar%SSWT004 = met_force%SSWT004 / scalar - met_force_div_scalar%SSWT005 = met_force%SSWT005 / scalar - met_force_div_scalar%SSSD001 = met_force%SSSD001 / scalar - met_force_div_scalar%SSSD002 = met_force%SSSD002 / scalar - met_force_div_scalar%SSSD003 = met_force%SSSD003 / scalar - met_force_div_scalar%SSSD004 = met_force%SSSD004 / scalar - met_force_div_scalar%SSSD005 = met_force%SSSD005 / scalar - - end function met_force_div_scalar - - ! ----------------------------------------------------------- - - function add_met_force( met_force_1, met_force_2 ) - - implicit none - - type(met_force_type) :: add_met_force - type(met_force_type), intent(in) :: met_force_1, met_force_2 - - add_met_force%Tair = met_force_1%Tair + met_force_2%Tair - add_met_force%Qair = met_force_1%Qair + met_force_2%Qair - add_met_force%Psurf = met_force_1%Psurf + met_force_2%Psurf - add_met_force%Rainf_C = met_force_1%Rainf_C + met_force_2%Rainf_C - add_met_force%Rainf = met_force_1%Rainf + met_force_2%Rainf - add_met_force%Snowf = met_force_1%Snowf + met_force_2%Snowf - add_met_force%LWdown = met_force_1%LWdown + met_force_2%LWdown - add_met_force%SWdown = met_force_1%SWdown + met_force_2%SWdown - add_met_force%PARdrct = met_force_1%PARdrct + met_force_2%PARdrct - add_met_force%PARdffs = met_force_1%PARdffs + met_force_2%PARdffs - add_met_force%Wind = met_force_1%Wind + met_force_2%Wind - add_met_force%RefH = met_force_1%RefH + met_force_2%RefH - - add_met_force%DUDP001 = met_force_1%DUDP001 + met_force_2%DUDP001 - add_met_force%DUDP002 = met_force_1%DUDP002 + met_force_2%DUDP002 - add_met_force%DUDP003 = met_force_1%DUDP003 + met_force_2%DUDP003 - add_met_force%DUDP004 = met_force_1%DUDP004 + met_force_2%DUDP004 - add_met_force%DUDP005 = met_force_1%DUDP005 + met_force_2%DUDP005 - add_met_force%DUSV001 = met_force_1%DUSV001 + met_force_2%DUSV001 - add_met_force%DUSV002 = met_force_1%DUSV002 + met_force_2%DUSV002 - add_met_force%DUSV003 = met_force_1%DUSV003 + met_force_2%DUSV003 - add_met_force%DUSV004 = met_force_1%DUSV004 + met_force_2%DUSV004 - add_met_force%DUSV005 = met_force_1%DUSV005 + met_force_2%DUSV005 - add_met_force%DUWT001 = met_force_1%DUWT001 + met_force_2%DUWT001 - add_met_force%DUWT002 = met_force_1%DUWT002 + met_force_2%DUWT002 - add_met_force%DUWT003 = met_force_1%DUWT003 + met_force_2%DUWT003 - add_met_force%DUWT004 = met_force_1%DUWT004 + met_force_2%DUWT004 - add_met_force%DUWT005 = met_force_1%DUWT005 + met_force_2%DUWT005 - add_met_force%DUSD001 = met_force_1%DUSD001 + met_force_2%DUSD001 - add_met_force%DUSD002 = met_force_1%DUSD002 + met_force_2%DUSD002 - add_met_force%DUSD003 = met_force_1%DUSD003 + met_force_2%DUSD003 - add_met_force%DUSD004 = met_force_1%DUSD004 + met_force_2%DUSD004 - add_met_force%DUSD005 = met_force_1%DUSD005 + met_force_2%DUSD005 - add_met_force%BCDP001 = met_force_1%BCDP001 + met_force_2%BCDP001 - add_met_force%BCDP002 = met_force_1%BCDP002 + met_force_2%BCDP002 - add_met_force%BCSV001 = met_force_1%BCSV001 + met_force_2%BCSV001 - add_met_force%BCSV002 = met_force_1%BCSV002 + met_force_2%BCSV002 - add_met_force%BCWT001 = met_force_1%BCWT001 + met_force_2%BCWT001 - add_met_force%BCWT002 = met_force_1%BCWT002 + met_force_2%BCWT002 - add_met_force%BCSD001 = met_force_1%BCSD001 + met_force_2%BCSD001 - add_met_force%BCSD002 = met_force_1%BCSD002 + met_force_2%BCSD002 - add_met_force%OCDP001 = met_force_1%OCDP001 + met_force_2%OCDP001 - add_met_force%OCDP002 = met_force_1%OCDP002 + met_force_2%OCDP002 - add_met_force%OCSV001 = met_force_1%OCSV001 + met_force_2%OCSV001 - add_met_force%OCSV002 = met_force_1%OCSV002 + met_force_2%OCSV002 - add_met_force%OCWT001 = met_force_1%OCWT001 + met_force_2%OCWT001 - add_met_force%OCWT002 = met_force_1%OCWT002 + met_force_2%OCWT002 - add_met_force%OCSD001 = met_force_1%OCSD001 + met_force_2%OCSD001 - add_met_force%OCSD002 = met_force_1%OCSD002 + met_force_2%OCSD002 - add_met_force%SUDP003 = met_force_1%SUDP003 + met_force_2%SUDP003 - add_met_force%SUSV003 = met_force_1%SUSV003 + met_force_2%SUSV003 - add_met_force%SUWT003 = met_force_1%SUWT003 + met_force_2%SUWT003 - add_met_force%SUSD003 = met_force_1%SUSD003 + met_force_2%SUSD003 - add_met_force%SSDP001 = met_force_1%SSDP001 + met_force_2%SSDP001 - add_met_force%SSDP002 = met_force_1%SSDP002 + met_force_2%SSDP002 - add_met_force%SSDP003 = met_force_1%SSDP003 + met_force_2%SSDP003 - add_met_force%SSDP004 = met_force_1%SSDP004 + met_force_2%SSDP004 - add_met_force%SSDP005 = met_force_1%SSDP005 + met_force_2%SSDP005 - add_met_force%SSSV001 = met_force_1%SSSV001 + met_force_2%SSSV001 - add_met_force%SSSV002 = met_force_1%SSSV002 + met_force_2%SSSV002 - add_met_force%SSSV003 = met_force_1%SSSV003 + met_force_2%SSSV003 - add_met_force%SSSV004 = met_force_1%SSSV004 + met_force_2%SSSV004 - add_met_force%SSSV005 = met_force_1%SSSV005 + met_force_2%SSSV005 - add_met_force%SSWT001 = met_force_1%SSWT001 + met_force_2%SSWT001 - add_met_force%SSWT002 = met_force_1%SSWT002 + met_force_2%SSWT002 - add_met_force%SSWT003 = met_force_1%SSWT003 + met_force_2%SSWT003 - add_met_force%SSWT004 = met_force_1%SSWT004 + met_force_2%SSWT004 - add_met_force%SSWT005 = met_force_1%SSWT005 + met_force_2%SSWT005 - add_met_force%SSSD001 = met_force_1%SSSD001 + met_force_2%SSSD001 - add_met_force%SSSD002 = met_force_1%SSSD002 + met_force_2%SSSD002 - add_met_force%SSSD003 = met_force_1%SSSD003 + met_force_2%SSSD003 - add_met_force%SSSD004 = met_force_1%SSSD004 + met_force_2%SSSD004 - add_met_force%SSSD005 = met_force_1%SSSD005 + met_force_2%SSSD005 - - end function add_met_force - - ! --------------------------------------------------- - - subroutine scalar2veg_param( veg_param, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(veg_param_type), intent(out) :: veg_param - - veg_param%grn = scalar - veg_param%lai = scalar - - end subroutine scalar2veg_param - - ! ----------------------------------------------------------- - - function veg_param_div_scalar( veg_param, scalar ) - - implicit none - - type(veg_param_type) :: veg_param_div_scalar - type(veg_param_type), intent(in) :: veg_param - - real, intent(in) :: scalar - - veg_param_div_scalar%grn = veg_param%grn / scalar - veg_param_div_scalar%lai = veg_param%lai / scalar - - end function veg_param_div_scalar - - ! ----------------------------------------------------------- - - function add_veg_param( veg_param_1, veg_param_2 ) - - implicit none - - type(veg_param_type) :: add_veg_param - type(veg_param_type), intent(in) :: veg_param_1, veg_param_2 - - add_veg_param%grn = veg_param_1%grn + veg_param_2%grn - add_veg_param%lai = veg_param_1%lai + veg_param_2%lai - - end function add_veg_param - - ! --------------------------------------------------- - - subroutine scalar2bal_diagn( bal_diagn, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(bal_diagn_type), intent(out) :: bal_diagn - - bal_diagn%etotl = scalar - bal_diagn%echng = scalar - bal_diagn%eincr = scalar - bal_diagn%wtotl = scalar - bal_diagn%wchng = scalar - bal_diagn%wincr = scalar - - end subroutine scalar2bal_diagn - - ! ----------------------------------------------------------- - - function bal_diagn_div_scalar( bal_diagn, scalar ) - - implicit none - - type(bal_diagn_type) :: bal_diagn_div_scalar - type(bal_diagn_type), intent(in) :: bal_diagn - - real, intent(in) :: scalar - - bal_diagn_div_scalar%etotl = bal_diagn%etotl / scalar - bal_diagn_div_scalar%echng = bal_diagn%echng / scalar - bal_diagn_div_scalar%eincr = bal_diagn%eincr / scalar - bal_diagn_div_scalar%wtotl = bal_diagn%wtotl / scalar - bal_diagn_div_scalar%wchng = bal_diagn%wchng / scalar - bal_diagn_div_scalar%wincr = bal_diagn%wincr / scalar - - end function bal_diagn_div_scalar - - ! ----------------------------------------------------------- - - function add_bal_diagn( bal_diagn_1, bal_diagn_2 ) - - implicit none - - type(bal_diagn_type) :: add_bal_diagn - type(bal_diagn_type), intent(in) :: bal_diagn_1, bal_diagn_2 - - add_bal_diagn%etotl = bal_diagn_1%etotl + bal_diagn_2%etotl - add_bal_diagn%echng = bal_diagn_1%echng + bal_diagn_2%echng - add_bal_diagn%eincr = bal_diagn_1%eincr + bal_diagn_2%eincr - add_bal_diagn%wtotl = bal_diagn_1%wtotl + bal_diagn_2%wtotl - add_bal_diagn%wchng = bal_diagn_1%wchng + bal_diagn_2%wchng - add_bal_diagn%wincr = bal_diagn_1%wincr + bal_diagn_2%wincr - - end function add_bal_diagn - - ! ----------------------------------------------------------- - - subroutine scalar2alb_param( alb_param, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(alb_param_type), intent(out) :: alb_param - - alb_param%sc_albvf = scalar - alb_param%sc_albnf = scalar - - end subroutine scalar2alb_param - - ! --------------------------------------------------- - - function alb_param_times_scalar( alb_param, scalar ) - - implicit none - - type(alb_param_type) :: alb_param_times_scalar - type(alb_param_type), intent(in) :: alb_param - - real, intent(in) :: scalar - - alb_param_times_scalar%sc_albvf = alb_param%sc_albvf * scalar - alb_param_times_scalar%sc_albnf = alb_param%sc_albnf * scalar - - end function alb_param_times_scalar - - ! --------------------------------------------------- - - function scalar_times_alb_param( scalar, alb_param ) - - implicit none - - type(alb_param_type) :: scalar_times_alb_param - type(alb_param_type), intent(in) :: alb_param - - real, intent(in) :: scalar - - scalar_times_alb_param%sc_albvf = alb_param%sc_albvf * scalar - scalar_times_alb_param%sc_albnf = alb_param%sc_albnf * scalar - - end function scalar_times_alb_param - - ! ----------------------------------------------------------- - - function add_alb_param( alb_param_1, alb_param_2 ) - - implicit none - - type(alb_param_type) :: add_alb_param - type(alb_param_type), intent(in) :: alb_param_1, alb_param_2 - - add_alb_param%sc_albvf = alb_param_1%sc_albvf + alb_param_2%sc_albvf - add_alb_param%sc_albnf = alb_param_1%sc_albnf + alb_param_2%sc_albnf - - end function add_alb_param - - ! ----------------------------------------------------------- - -end module LDAS_DriverTypes - - -! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -#if 0 - -program test - - use driver_types - - type(alb_param_type), dimension(2,3) :: map1, map2 - type(alb_param_type), dimension(2) :: map3 - - integer :: n, m - - n=1 - m=3 - - map1(n,m) = 1.111 - map2(n,m) = 2.222 - map3(n) = 0. - - write (*,*) map1(n,m) - write (*,*) map2(n,m) - write (*,*) map3(n) - write (*,*) - - map3(n) = map1(n,m) + map2(n,m) - - write (*,*) map1(n,m) - write (*,*) map2(n,m) - write (*,*) map - write (*,*) - - map3(n)%sc_albnf = map2(n,m)%sc_albnf * 40. - - write (*,*) map1(n,m) - write (*,*) map2(n,m) - write (*,*) map3(n) - write (*,*) - - map3(n) = map2(n,m) * 40. + map1(n,m) * 3. - - write (*,*) map1(n,m) - write (*,*) map2(n,m) - write (*,*) map3(n) - write (*,*) - -end program test - -#endif - -! =========== EOF ======================================================= - diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Exceptions.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Exceptions.F90 deleted file mode 100644 index 83414a23..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_Exceptions.F90 +++ /dev/null @@ -1,104 +0,0 @@ -! clsm_exceptions.F90 - -! pchakrab, xx July 2014 - -module LDAS_ExceptionsMod - - use ESMF - use MAPL_Mod - - use, intrinsic :: iso_fortran_env, only: logunit => output_unit - - implicit none - - private - - integer, parameter, public :: LDAS_GENERIC_ERROR = 3000 - integer, parameter, public :: LDAS_FILE_NOT_FOUND = 3001 - !integer, parameter, public :: LDAS_INVALID_VALUE = 3002 - integer, parameter, public :: LDAS_GENERIC_WARNING = 6000 - - ! more error/warning codes here - - public :: ldas_abort - public :: ldas_warn - -contains - - subroutine ldas_abort(err_code, calling_fn, message) - ! input/output - integer, intent(in) :: err_code - character(len=*), intent(in) :: calling_fn - character(len=*), intent(in) :: message - - ! local - character(len=10) :: err_code_str ! largest 4B integer has 10 digits - type(ESMF_VM) :: vm - integer :: mpierr - integer :: comm - integer :: status - - ! write status (failed) file - call write_status(.false.) - - write(err_code_str, '(i10)') err_code ! err_code from int to str - write(logunit, *) 'LDAS ERROR (' // & - trim(adjustl(err_code_str)) // ') from ' // & - trim(calling_fn) // ': ' // trim(message) - -#ifdef LDAS_MPI - ! abort - call ESMF_VmGetCurrent(vm, rc=status) - VERIFY_(status) - call ESMF_VmGet(vm, mpicommunicator=comm, rc=status) - VERIFY_(status) - call MPI_Abort(comm, err_code, mpierr) -#else - stop -#endif - - end subroutine ldas_abort - - - subroutine ldas_warn(warn_code, calling_fn, message) - ! input/output - integer, intent(in) :: warn_code - character(len=*), intent(in) :: calling_fn - character(len=*), intent(in) :: message - - ! local - character(len=10) :: warn_code_str ! largest 4B integer has 10 digits - - write(warn_code_str, '(i10)') warn_code - write(logunit, *) 'LDAS WARNING (' // & - trim(adjustl(warn_code_str)) // ') from ' // & - trim(calling_fn) // ': ' // trim(message) - - end subroutine ldas_warn - - - subroutine write_status(lenkf_status) - - ! write status message (success/failure) to designated file - ! hardwired filename, used by ADAS scripts - - ! Draper, reichle, 27 Feb 2012 - - implicit none - - logical, intent(in) :: lenkf_status - - open( unit=10, file='lenkf_job_completed.txt' ) - - if (lenkf_status) then - write (10,*) 'SUCCEEDED' - else - write (10,*) 'FAILED' - endif - - close(unit=10) - - end subroutine write_status - - -end module LDAS_ExceptionsMod diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_PertTypes.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_PertTypes.F90 deleted file mode 100644 index c0da62c1..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_PertTypes.F90 +++ /dev/null @@ -1,186 +0,0 @@ -! -! type definitions for module to generate land surface perturbations -! -! reichle, 14 Apr 2006 - split land_pert.F90 into 2 files to avoid -! having more than one module per file -! -! ------------------------------------------------------------ - -module LDAS_PertTypes - - ! reichle, 26 May 2005 - - use ESMF - use LDAS_TileCoordType, only: grid_def_type - - implicit none - - ! everything is private by default unless made public - - private - - public :: pert_param_type - public :: allocate_pert_param - public :: deallocate_pert_param - - public :: T_LANDPERT_STATE - public :: LANDPERT_WRAP - - ! -------------------------------------------------------------------- - ! - ! parameters for each kind of perturbation (precip, radiation, - ! soil moisture, etc) - - type :: pert_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! calls to MPI_BCAST in clsm_ensdrv_main.F90 are also updated. - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - character(40) :: descr ! 'pcp' (precip), 'sw' (shortwave), etc - - ! add or multiply perturbation? - ! - ! additive: typ = 0 - ! multiplicative and lognormal: typ = 1 - - integer :: typ - - ! max allowed normalized perturbation (relative to N(0,1)) - - real :: std_normal_max - - ! if .true. enforce zeromean across ensemble - ! (implies mean=1 for multiplicative perturbations) - ! (not applicable if only one ensemble member is done at a time) - - logical :: zeromean ! enforce zero mean across ensemble - - ! Allow perturbations to be computed on coarsened grid? - ! Coarse grid spacing automatically determined as a function of model - ! grid spacing and spatial correlation scales (see random_fields.F90) - - logical :: coarsen - - ! Mean and std are allowed to vary in space (dimension(N_x,N_y)). - - real, dimension(:,:), pointer :: mean ! mean - real, dimension(:,:), pointer :: std ! standard deviation - - ! Cross-correlations between different kinds of perturbations - ! (eg. between precip and shortwave perturbations) are allowed to vary - ! in space (dimension(N_pert_kind,N_x,N_y)). - - real, dimension(:,:,:), pointer :: ccorr - - ! Spatial and temporal correlation scales must be constant in space. - ! For non-zero cross-correlations they must also be the same for - ! all kinds for perturbations (eg. if precip and radiation - ! perturbations are cross-correlated, their xcorr, ycorr and tcorr - ! must be the same). - - real :: xcorr ! correlation length along latitudes [deg] - real :: ycorr ! correlation length along longitudes [deg] - real :: tcorr ! temporal correlation length [s] - - end type pert_param_type - - ! ********************************************************************** - - type T_PERT - ! private - integer :: npert ! number of perturbation - !In situation that a processor has no tiles, this processor can still participate parallel fft - integer :: fft_npert - integer :: dtstep - type(ESMF_Time) :: TimePrv, TimeNxt - type(pert_param_type), pointer :: param(:)=>null() - real, allocatable :: DataPrv(:,:), DataNxt(:,:) - end type T_PERT - - ! Internal state and its wrapper - type T_LANDPERT_STATE - !private - integer :: PERTURBATIONS ! 1: perturb variables; 0: no perturbation - integer :: ens_id - integer :: NUM_ENSEMBLE - logical :: isCubedSphere - - integer,allocatable :: i_indgs(:) - integer,allocatable :: j_indgs(:) - ! if it is cubed-sphere grid, swith to internal start - real,allocatable :: fpert_ntrmdt(:,:,:) - real,allocatable :: ppert_ntrmdt(:,:,:) - real(kind=ESMF_KIND_R8), allocatable :: pert_rseed_r8(:) - ! force/progn perturbations - type(T_PERT) :: ForcePert, PrognPert - end type T_LANDPERT_STATE - type LANDPERT_WRAP - type(T_LANDPERT_STATE), pointer :: ptr=>null() - end type LANDPERT_WRAP - -contains - - subroutine allocate_pert_param(N_pert, N_x, N_y, pert_param) - - implicit none - - integer, intent(in) :: N_pert, N_x, N_y - - type(pert_param_type), dimension(:), pointer :: pert_param - - ! local variables - - integer :: k - - ! -------------------------------------------------------- - - nullify(pert_param) - - allocate(pert_param(N_pert)) - - do k=1,N_pert - - allocate(pert_param(k)%mean(N_x,N_y)) - allocate(pert_param(k)%std(N_x,N_y)) - allocate(pert_param(k)%ccorr(N_pert,N_x,N_y)) - - end do - - end subroutine allocate_pert_param - - ! ********************************************************************** - - subroutine deallocate_pert_param(N_pert, pert_param) - - implicit none - - integer, intent(in) :: N_pert - - type(pert_param_type), dimension(:), pointer :: pert_param - - ! local variables - - integer :: k - - ! -------------------------------------------------------- - - do k=1,N_pert - - deallocate(pert_param(k)%mean) - deallocate(pert_param(k)%std) - deallocate(pert_param(k)%ccorr) - - end do - - deallocate(pert_param) - - end subroutine deallocate_pert_param - - ! ********************************************************************** - -end module LDAS_PertTypes - - -! =============== EOF ================================================= diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_RepairForcing.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_RepairForcing.F90 deleted file mode 100644 index 979e8fb2..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_RepairForcing.F90 +++ /dev/null @@ -1,563 +0,0 @@ -module RepairForcingMod - - use LDAS_DriverTypes, only: met_force_type - use LDAS_TileCoordType, only: tile_coord_type - use LDAS_ExceptionsMod, only: ldas_abort, LDAS_GENERIC_ERROR - use MAPL_SatVaporMod, only: MAPL_EQsat - use LDAS_ensdrv_Globals, only: logunit, LDAS_is_nodata - use MAPL_ConstantsMod, only: stefan_boltzmann=>MAPL_STFBOL - use LDAS_ensdrv_Globals, only: root_logit - implicit none - - private - - public :: repair_forcing - - real, parameter :: SWDN_MAX = 1360. ! W/m2 - real, parameter :: LWDN_EMISS_MIN = 0.5 ! min effective emissivity for LWdown - real, parameter :: LWDN_EMISS_MAX = 1.0 ! max effective emissivity for LWdown - -contains - - subroutine repair_forcing( N_catd, met_force, echo, tile_coord, fieldname, & - unlimited_Qair, unlimited_LWdown ) - - ! check forcing for unphysical values, reset, print optional warning - ! - ! if optional input "fieldname" is present, only the corresponding - ! forcing fields will be repaired - ! - ! reichle, 30 Mar 2004 - ! reichle+qliu, 8 Oct 2008 - added optional input "unlimited_Qair" - ! reichle, 11 Feb 2009 - added optional input "unlimited_LWdown" - ! reichle, 2 Dec 2009 - eliminated "trim(field)==" to avoid memory - ! leak due to Absoft 9 bug - ! reichle, 24 Dec 2013 - limited number of warnings to N_tile_warn_max - ! STILL TO DO: fix format specification for warning - ! statements to avoid line breaks within - ! a given statement - - implicit none - - integer, intent(in) :: N_catd - - type(met_force_type), dimension(N_catd), intent(inout) :: met_force - - logical, intent(in), optional :: echo, unlimited_Qair, unlimited_LWdown - - type(tile_coord_type), dimension(:), pointer, optional :: tile_coord ! in - - character(*), intent(in), optional :: fieldname - - ! local variables - - ! turn warnings off if warnings have been printed for N_warn_max tiles - - integer, parameter :: N_tile_warn_max = 3 - - ! min/max values for allowable range of forcing fields - - real, parameter :: min_Tair = 190. ! [K] - real, parameter :: max_Tair = 340. ! [K] - - real, parameter :: max_PSurf = 115000. ! [Pa] - - ! slack parameters beyond which warnings are printed (if requested) - - ! specific humidity is often a tiny bit above saturated specific humidity - ! (but sometimes much larger...) - ! - ! ALWAYS limit Qair <= Qair_sat - ! - ! *warning* ONLY for Qair <= tmpfac*Qair_sat - ! - ! tmpfac=1.02 corresponds approximately to relative humidity above 1.02 - - real, parameter :: tmpfac_warn_Qair = 1.2 ! [-] - - real, parameter :: tmpadd_warn_PAR = 1.e-2 ! [W/m2] - - real, parameter :: tmp_warn_Prec = 3.e-10 ! [m/s] (1.e-10m/s ~ 3mm/year) - - - logical :: warn, unlimited_Qair_tmp, unlimited_LWdown_tmp, problem_tile - - integer :: i, kk - - real :: tmp_LWdown, min_LWdown, max_LWdown, Qair_sat, tmp_maxPar - - character(10) :: SWDN_MAX_string - character(10) :: min_Tair_string, max_Tair_string, max_Psurf_string - character(13) :: tmpstr13a, tmpstr13b - character(16) :: tile_id_str, tmpstr16 - character(40) :: field - - character(len=*), parameter :: Iam = 'repair_forcing' - character(len=400) :: err_msg - - ! ------------------------------------------------------------ - - if (present(echo)) then - if (present(tile_coord)) then - warn = echo - else - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'inconsistent optional args') - end if - else - warn = .false. - end if - - if (present(unlimited_Qair)) then - unlimited_Qair_tmp = unlimited_Qair - else - unlimited_Qair_tmp = .false. - end if - - if (present(unlimited_LWdown)) then - unlimited_LWdown_tmp = unlimited_LWdown - else - unlimited_LWdown_tmp = .false. - end if - - ! -------------------------------- - - if (present(fieldname)) then - field = fieldname - else - field = 'all' - end if - - ! -------------------------------- - - if (warn) then - - write (SWDN_MAX_string, '(f10.1)') SWDN_MAX - - write (min_Tair_string, '(f10.1)') min_Tair - write (max_Tair_string, '(f10.1)') max_Tair - write (max_PSurf_string,'(f10.1)') max_PSurf - - end if - - ! -------------------------------- - - kk = 0 ! counter for number of problematic tiles - - do i=1,N_catd - - problem_tile = .false. - - if (warn) write (tile_id_str,'(i16)') tile_coord(i)%tile_id ! convert integer to string - - ! precip and snowfall must be non-negative - - ! fix Rainf first, otherwise cannot use Rainf to constrain Rainf_C - ! reichle, 11 Aug 2010 - - if (field(1:3)=='all' .or. field(1:5)=='Rainf') then - - if ((warn) .and. (met_force(i)%Rainf < -tmp_warn_Prec)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Rainf ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Rainf < 0. in tile ID ' // & - tile_id_str // ': met_force(i)%Rainf = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%Rainf = max( 0., met_force(i)%Rainf) - - end if - - if (field(1:3)=='all' .or. field(1:7)=='Rainf_C') then - - if ((warn) .and. (met_force(i)%Rainf_C < -tmp_warn_Prec)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Rainf_C ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Rainf_C < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%Rainf_C = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%Rainf_C = max( 0., met_force(i)%Rainf_C) - - ! make sure convective precip is less than total precip - - if ((warn) .and. (met_force(i)%Rainf+tmp_warn_Prec < met_force(i)%Rainf_C)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Rainf ! convert real to string - write (tmpstr13b,'(e13.5)') met_force(i)%Rainf_C ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Rainf < Rainf_C in tile ID ' // & - tile_id_str // ': met_force(i)%Rainf = ' // tmpstr13a // & - ', met_force(i)%Rainf_C = ' // tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%Rainf_C = min( met_force(i)%Rainf, met_force(i)%Rainf_C) - - end if - - if (field(1:3)=='all' .or. field(1:5)=='Snowf') then - - if ((warn) .and. (met_force(i)%Snowf < -tmp_warn_Prec)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Snowf ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Snowf < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%Snowf = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%Snowf = max( 0., met_force(i)%Snowf) - - end if - - ! -------------------------------- - - if (field(1:3)=='all' .or. field(1:4)=='Tair') then - - ! temperatures must not be too low or too high - - ! NOTE: "warn" is turned on when repair_forcing is called first - ! time after the forcing has been read from files - - if ((warn) .and. (met_force(i)%Tair < 190.)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Tair ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') & - 'repair_forcing: Tair < '//min_Tair_string//' in tile ID ' // & - tile_id_str // ': met_force(i)%Tair = ' // tmpstr13a - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'Tair too low') - - end if - - if ((warn) .and. (met_force(i)%Tair > 340.)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Tair ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') & - 'repair_forcing: Tair > '//max_Tair_string//' in tile ID ' // & - tile_id_str // ': met_force(i)%Tair = ' // tmpstr13a - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'Tair too high') - - end if - - end if - - ! -------------------------------- - - if (field(1:3)=='all' .or. field(1:5)=='Psurf') then - - ! surface air pressure must not be too high - - if ((warn) .and. (met_force(i)%Psurf > max_Psurf)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%PSurf ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') & - 'repair_forcing: Psurf > '//max_PSurf_string//' in tile ID ' // & - tile_id_str // ': met_force(i)%PSurf = ' // tmpstr13a - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'Psurf too high') - - end if - - end if - - ! -------------------------------- - - ! specific humidity must not be negative - - if (field(1:3)=='all' .or. field(1:4)=='Qair') then - - if ((warn) .and. (met_force(i)%Qair < 0.)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Qair ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Qair < 0. in tile ID ' // & - tile_id_str // ': met_force(i)%Qair = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%Qair = max( 0., met_force(i)%Qair ) - - ! specific humidity should not exceed saturated specific humidity - - if (.not. unlimited_Qair_tmp) then - - Qair_sat = MAPL_EQsat(met_force(i)%Tair, met_force(i)%Psurf ) - - if ((warn) .and. (met_force(i)%Qair > tmpfac_warn_Qair*Qair_sat)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Qair ! convert real to string - write (tmpstr13b,'(e13.5)') met_force(i)%Qair/Qair_sat - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Qair > Qair_sat in tile ID ' // & - tile_id_str // ': met_force(i)%Qair = ' // tmpstr13a // & - ', met_force(i)%Qair/Qair_sat = ' // tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%Qair = min(Qair_sat, met_force(i)%Qair) - - end if - - end if - - ! -------------------------------- - - ! wind speed must be positive - ! (zero wind creates problem in turbulence calculations; - ! warn only if wind is negative) - - if (field(1:3)=='all' .or. field(1:4)=='Wind') then - - if ((warn) .and. (met_force(i)%Wind < 0.)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%Wind ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: Wind < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%Wind = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%Wind = max( 0.0001, met_force(i)%Wind) - - end if - - ! -------------------------------- - - if (field(1:3)=='all' .or. field(1:6)=='LWdown') then - - if (.not. unlimited_LWdown_tmp) then - - ! make sure radiation is between min and max - - tmp_LWdown = met_force(i)%Tair*met_force(i)%Tair - tmp_LWdown = stefan_boltzmann*tmp_LWdown*tmp_LWdown - - min_LWdown = LWDN_EMISS_MIN*tmp_LWdown - max_LWdown = LWDN_EMISS_MAX*tmp_LWdown - - if ((warn) .and. (met_force(i)%LWdown < min_LWdown)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%LWdown ! convert real to string - write (tmpstr13b,'(e13.5)') min_LWdown - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: LWdown < min_LWdown in tile ID ' // & - tile_id_str // ': met_force(i)%LWdown = ' // tmpstr13a // & - ', min_LWdown = ' // tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%LWdown = max( min_LWdown, met_force(i)%LWdown) - - if ((warn) .and. (met_force(i)%LWdown > max_LWdown)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%LWdown ! convert real to string - write (tmpstr13b,'(e13.5)') max_LWdown - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: LWdown > max_LWdown in tile ID ' // & - tile_id_str // ': met_force(i)%LWdown = ' // tmpstr13a // & - ', max_LWdown = ' // tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%LWdown = min( max_LWdown, met_force(i)%LWdown) - - end if - - end if - - ! ----------------------------------- - - if (field(1:3)=='all' .or. field(1:6)=='SWdown') then - - if ((warn) .and. (met_force(i)%SWdown < 0. )) then - - write (tmpstr13a,'(e13.5)') met_force(i)%SWdown ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: SWdown < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%SWdown = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%SWdown = max( 0., met_force(i)%SWdown) - - ! shortwave must be less than solar constant - ! (see also subroutine interpolate_to_timestep() for interpolated - ! shortwave forcing) - - if ((warn) .and. (met_force(i)%SWdown > SWDN_MAX)) then - - write (tmpstr13a,'(e13.5)') met_force(i)%SWdown ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: SWdown > ' // SWDN_MAX_string // & - ' in tile ID ' // tile_id_str // ': met_force(i)%SWdown = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%SWdown = min( SWDN_MAX, met_force(i)%SWdown) - - end if - - ! ----------------------------------- - - ! PARdrct and PARdffs (must be repaired together) - ! - ! "PARdrct" and "PARdffs" now backfilled and checked for nodata-values before this - ! subroutine is first called. - wjiang+reichle, 22 Apr 2021 - - if (field(1:3)=='all' .or. field(1:3)=='PAR') then - - if ((warn) .and. (met_force(i)%PARdffs < 0. )) then - - write (tmpstr13a,'(e13.5)') met_force(i)%PARdffs ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: PARdffs < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%PARdffs = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%PARdffs = max( 0., met_force(i)%PARdffs) - - ! upper threshold for PARdffs = 0.6 of solar incoming radiation - ! (after analysis if May and Dec cases from MERRA Scout) - ! - reichle, 24 Feb 2009) - - ! updated to threshold of 0.8 after brief analysis of hourly MERRA data - ! for Jul 2003 (courtesy of Greg Walker) - ! - reichle, 20 Dec 2011 - - tmp_maxPar = 0.8*met_force(i)%SWdown - - if ((warn) .and. (met_force(i)%PARdffs > tmp_maxPar+tmpadd_warn_PAR )) then - - write (tmpstr13a,'(e13.5)') tmp_maxPar ! convert real to string - write (tmpstr13b,'(e13.5)') met_force(i)%PARdffs ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: PARdffs > ' // tmpstr13a // & - ' in tile ID ' // tile_id_str // ': met_force(i)%PARdffs = ' // & - tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%PARdffs = min( met_force(i)%PARdffs,tmp_maxPar) - - ! --------------------------------------- - ! - ! MUST "repair" PARdrct *after* PARdffs - - if ((warn) .and. (met_force(i)%PARdrct < 0. )) then - - write (tmpstr13a,'(e13.5)') met_force(i)%PARdrct ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: PARdrct < 0. in tile ID ' //& - tile_id_str // ': met_force(i)%PARdrct = ' // tmpstr13a - - problem_tile=.true. - - end if - - met_force(i)%PARdrct = max( 0., met_force(i)%PARdrct) - - ! upper threshold for PARdrct = SWdown - PARdffs - - tmp_maxPar = met_force(i)%SWdown - met_force(i)%PARdffs - - if ((warn) .and. (met_force(i)%PARdrct > tmp_maxPar+tmpadd_warn_PAR )) then - - write (tmpstr13a,'(e13.5)') tmp_maxPar ! convert real to string - write (tmpstr13b,'(e13.5)') met_force(i)%PARdrct ! convert real to string - - if (root_logit) & - write (logunit,'(200A)') 'repair_forcing: PARdrct > ' // tmpstr13a // & - ' in tile ID ' // tile_id_str // ': met_force(i)%PARdrct = ' // & - tmpstr13b - - problem_tile=.true. - - end if - - met_force(i)%PARdrct = min( met_force(i)%PARdrct,tmp_maxPar) - - end if - - ! ------------------------------------------------------ - ! - ! count problematic tiles - - if (problem_tile) kk=kk+1 - - ! turn off warnings if number of problem tiles gets too large - - if ((warn) .and. (kk>N_tile_warn_max)) then - - warn = .false. ! turn off warnings for the remainder of the loop through tiles - - write (tmpstr16,'(i16)') kk ! convert integer to string - - if (root_logit) & - write (logunit,'(200A)') & - 'repair_forcing: turning OFF warnings after detecting ' // & - trim(tmpstr16) // ' tiles with problematic forcing' - - end if - - ! ------------------------------------------------------ - - end do ! do i=1,N_catd (loop through tiles) - - end subroutine repair_forcing - -end module RepairForcingMod - -! ========================== EOF =========================================== diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordRoutines.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordRoutines.F90 deleted file mode 100644 index 7ddd5b55..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordRoutines.F90 +++ /dev/null @@ -1,1532 +0,0 @@ - -! this file contains types and subroutines for tile coordinates and domain -! -! reichle, 26 Jan 2005 -! reichle, 14 Apr 2006 - split tile_coord.F90 into 2 files to avoid -! having more than one module per file -! reichle, 5 Apr 2013 - added EASEv2 grid, minimal change to max lat/lon for EASE (v1) -! -! ======================================================================== - -module LDAS_TileCoordRoutines - - use LDAS_TileCoordType, ONLY: & - tile_coord_type, & - grid_def_type, & - init_grid_def_type, & - io_grid_def_type, & - io_tile_coord_type - - use LDAS_ensdrv_Globals, ONLY: & - logit, & - logunit, & - nodata_generic, & - nodata_tol_generic - - use MAPL_ConstantsMod, ONLY: & - MAPL_RADIUS ! Earth radius - - use EASE_conv, ONLY: & - ease_convert, & - ease_inverse, & - ease_extent - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use LDAS_ensdrv_functions, ONLY: & - get_io_filename - - implicit none - - private - - public :: get_minExtent_grid - public :: get_number_of_tiles_in_cell_ij - public :: get_tile_num_in_cell_ij - public :: get_tile_num_in_ellipse - public :: get_tile_num_from_latlon - public :: get_ij_ind_from_latlon - public :: tile2grid_simple - public :: grid2tile - public :: tile_mask_grid - public :: LDAS_create_grid_g - public :: io_domain_files - - character(10) :: tmpstring10 - character(40) :: tmpstring40 - - interface grid2tile - module procedure grid2tile_real, grid2tile_real8 - end interface grid2tile - -contains - - ! ********************************************************************** - - subroutine io_domain_files( action, work_path, exp_id, & - N_cat_domain, d2g, tile_coord, tile_grid_g, tile_grid_d, rc ) - - ! reichle, 23 July 2010 - ! reichle, 7 Jan 2014 - changed tile_coord and tile_grids I/O to binary - ! reichle, 3 Aug 2020 - moved here from LDAS_ensdrv_init_routines.F90 - - implicit none - - character, intent(in) :: action - - character(*), intent(in) :: work_path - character(*), intent(in) :: exp_id - - integer, intent(inout) :: N_cat_domain - - integer, dimension(:), pointer :: d2g - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! inout - - type(grid_def_type), intent(inout) :: tile_grid_g - type(grid_def_type), intent(inout) :: tile_grid_d - - integer, intent( out) :: rc - - ! local - - integer, parameter :: unitnumber = 10 - - integer :: n, istat - - logical :: writing - - character(300) :: fname - character( 40) :: file_tag, dir_name, file_ext, tmp_action, tmp_status - - character(len=*), parameter :: Iam = 'io_domain_files' - character(len=400) :: err_msg - - ! ----------------------------------------------------------- - ! - ! read or write? - - select case (action) - - case ('w','W') - - tmp_action = 'write' - tmp_status = 'unknown' - - writing = .true. - - case ('r','R') - - tmp_action = 'read' - tmp_status = 'old' - - writing = .false. - - case default - - err_msg = 'io_domain_files: unknown action ' // action - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - ! ----------------------------------------------------------- - ! - ! *.ldas_domain*txt file - - file_tag = 'ldas_domain' - dir_name = 'rc_out' - file_ext = '.txt' - - fname = get_io_filename( trim(work_path), trim(exp_id), file_tag, & - dir_name=dir_name, option=1, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') ' ' // trim(tmp_action) // ' ' // trim(fname) - - open(unitnumber, file=fname, form='formatted', action=trim(tmp_action), & - iostat=istat, status=trim(tmp_status)) - - if (istat/=0) then - - if (logit) write (logunit,*) 'cannot open for ', trim(tmp_action) - if (logit) write (logunit,*) - - rc = 1 - - return - - else - - if (writing) then - - write (unitnumber,*) N_cat_domain - - do n=1,N_cat_domain - write (unitnumber,*) tile_coord(n)%tile_id, d2g(n) - end do - - else - - read (unitnumber,*) N_cat_domain - - allocate(tile_coord(N_cat_domain)) - allocate(d2g( N_cat_domain)) - - do n=1,N_cat_domain - read (unitnumber,*) tile_coord(n)%tile_id, d2g(n) - end do - - end if - - close (unitnumber,status='keep') - - if (logit) write (logunit,*) 'done with ', trim(tmp_action) - if (logit) write (logunit,*) - - end if - - ! ----------------------------------------------------------- - ! - ! *.ldas_tile_coord.txt file - - file_tag = 'ldas_tilecoord' - dir_name = 'rc_out' - file_ext = '.bin' - - fname = get_io_filename( work_path, exp_id, file_tag, & - dir_name=dir_name, option=1, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') ' ' // trim(tmp_action) // ' ' // trim(fname) - - open(unitnumber, file=fname, form='unformatted', action=trim(tmp_action), & - iostat=istat, status=trim(tmp_status)) - - if (istat/=0) then - - if (logit) write (logunit,*) 'cannot open for ', trim(tmp_action) - if (logit) write (logunit,*) - - rc = 2 - - return - - else - - call io_tile_coord_type( action, unitnumber, N_cat_domain, tile_coord ) - - close (unitnumber,status='keep') - - if (logit) write (logunit,*) 'done with ', trim(tmp_action) - if (logit) write (logunit,*) - - end if - - ! ----------------------------------------------------------- - ! - ! *.ldas_tilegrids.txt file - - file_tag = 'ldas_tilegrids' - dir_name = 'rc_out' - file_ext = '.bin' - - fname = get_io_filename( work_path, exp_id, file_tag, & - dir_name=dir_name, option=1, file_ext=file_ext ) - - if (logit) write (logunit,'(400A)') ' ' // trim(tmp_action) // ' ' // trim(fname) - - open(unitnumber, file=fname, form='unformatted', action=trim(tmp_action), & - iostat=istat, status=trim(tmp_status)) - - if (istat/=0) then - - if (logit) write (logunit,*) 'cannot open for ', trim(tmp_action) - if (logit) write (logunit,*) - - rc = 3 - - return - - else - - ! read/write 'tile_grid_g' - call io_grid_def_type( action, unitnumber, tile_grid_g ) - - ! read/write 'tile_grid_d' - call io_grid_def_type( action, unitnumber, tile_grid_d ) - - close (unitnumber,status='keep') - - if (logit) write (logunit,*) 'done with ', trim(tmp_action) - if (logit) write (logunit,*) - - end if - - ! ------------------------------------------------------------------------ - - rc = 0 ! successful read or write of all files - - end subroutine io_domain_files - - ! ********************************************************************** - - subroutine LDAS_create_grid_g( gridname, n_lon, n_lat, & - tile_grid, i_indg_offset, j_indg_offset, cell_area) - - ! inputs: - ! gridname, n_lon, n_lat - ! - ! inouts: - ! tile_grid : parameters of tile definition grid - ! - ! outputs: - ! offsets - ! cell_area [m^2] (optional, for EASE grids only) - - implicit none - - character(*), intent(in) :: gridname - integer, intent(in) :: n_lon, n_lat - type(grid_def_type), intent(inout) :: tile_grid - integer, intent(out) :: i_indg_offset, j_indg_offset - real, optional, intent(out) :: cell_area - - ! locals - - real :: ease_cell_area - logical :: date_line_on_center, pole_on_center - logical :: ease_grid, c3_grid, latlon_grid - logical :: file_exist - integer :: k, rows, cols - character(len=*), parameter :: Iam = 'create global ldas_grid ' - character(len=400) :: err_msg - - ! initialize all fields to no-data values - - i_indg_offset = 0 - j_indg_offset = 0 - - call init_grid_def_type(tile_grid) - - tile_grid%N_lon = N_lon - tile_grid%N_lat = N_lat - - tile_grid%i_offg = 0 ! tile_grid refers to *global* grid - tile_grid%j_offg = 0 ! tile_grid refers to *global* grid - - date_line_on_center = .false. - pole_on_center = .false. - ease_grid = .false. - c3_grid = .false. - latlon_grid = .true. - - if (index(gridname,"DC") /=0) then - date_line_on_center = .true. - endif - - if (index(gridname,"PC") /=0) then - pole_on_center = .true. - endif - - if( index(gridname,"FV") /=0 ) then - pole_on_center = .true. - endif - - if (index(gridname,"EASEv") /=0) then - ease_grid = .true. - latlon_grid = .false. - endif - - if (index(gridname,"CF") /=0) then - c3_grid = .true. - latlon_grid = .false. - endif - - ! special cases , inconsistent of naming - ! find out whether date line is on edge or through center of grid cell - if( index(gridname,"FV_380x180") /=0) then - pole_on_center = .false. - endif - - ! Weiyuan Note, we should fix the tile file and the naming - if( index(gridname,"PE_720x360_DE") /=0) then - i_indg_offset = 110 - j_indg_offset = 230 - endif - if( index(gridname,"PE_2880x1440_DE") /=0) then - i_indg_offset = 440 - j_indg_offset = 920 - endif - - ! ---------------- - - if (ease_grid) then - - ! gridname may be EASEv2-M36 or EASEv2_M36 (to be cleaned up later) - - k = index(gridname, 'EASEv') - - if (k == 0) then - err_msg = 'unknown EASE grid tile defs, gridname = ' // trim( gridname) - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - tile_grid%gridtype = trim(gridname(k:)) - - tile_grid%ind_base = 0 - - ! global cylindrical EASE grid - - tile_grid%i_dir = +1 - tile_grid%j_dir = -1 - - call ease_extent ( & - gridname, cols, rows, & - cell_area = ease_cell_area, & ! [m^2] - ll_lon = tile_grid%ll_lon, & - ll_lat = tile_grid%ll_lat, & - ur_lon = tile_grid%ur_lon, & - ur_lat = tile_grid%ur_lat & - ) - - tile_grid%dlon = 360./real(tile_grid%N_lon) - tile_grid%dlat = (tile_grid%ur_lat-tile_grid%ll_lat)/real(tile_grid%N_lat) ! *avg* dlat! - - if(present(cell_area)) then - cell_area=ease_cell_area - endif - - endif ! EASE grid - - if (latlon_grid) then ! regular LatLon grid - - tile_grid%gridtype = 'LatLon' - - tile_grid%ind_base = 1 - - tile_grid%dlon = 360./real(tile_grid%N_lon) - - tile_grid%i_dir = +1 - tile_grid%j_dir = +1 - - if (pole_on_center) then - - tile_grid%dlat = 180./real(tile_grid%N_lat-1) - - tile_grid%ll_lat = -90. - tile_grid%dlat/2. - tile_grid%ur_lat = 90. + tile_grid%dlat/2. - - else - - tile_grid%dlat = 180./real(tile_grid%N_lat) - - tile_grid%ll_lat = -90. - tile_grid%ur_lat = 90. - - end if - - if (date_line_on_center) then - - tile_grid%ll_lon = -180. - tile_grid%dlon/2. - tile_grid%ur_lon = 180. - tile_grid%dlon/2. ! fixed 20 sep 2010, reichle - - else - - tile_grid%ll_lon = -180. - tile_grid%ur_lon = 180. - - end if - - end if ! lat lon grid - - if( c3_grid) then - - tile_grid%gridtype = 'c3' - tile_grid%ind_base = 1 - tile_grid%i_dir = +1 - tile_grid%j_dir = +1 - tile_grid%ll_lon = -180. - tile_grid%ur_lon = 180. - tile_grid%ll_lat = -90. - tile_grid%ur_lat = 90. - - ! dlon and dlat are approximate! - tile_grid%dlon = 360./real(4*tile_grid%N_lon) - tile_grid%dlat = tile_grid%dlon - - endif - - end subroutine LDAS_create_grid_g - - ! ******************************************************************* - - function get_minExtent_grid( N_tile, tc_i_indg, tc_j_indg, tc_minlon, tc_minlat, tc_maxlon, tc_maxlat, & - tile_grid_g) result( tile_grid ) - - ! get tile_grid with smallest extent for given set of tiles in tile_coord on (global) tile_grid_g - ! - ! make sure to pass in consistent tile_coord (tc) and tile_grid_g inputs: - ! - ! iff tile_grid_g is the grid that is associated with the tile space definition, - ! then input tc_[x]_indg must be tile_coord%[x]_indg - ! - ! iff tile_grid_g is the grid that supports efficient mapping for perts and the EnKF analysis, - ! then input tc_[x]_indg must be tile_coord%pert_[x]_indg - ! - ! reichle, 20 June 2012 -- moved from within domain_setup() - ! for re-use in get_obs_pred() - ! - ! reichle+wjiang, 19 Aug 2020 -- changed interface to generically accommodate use of - ! tile_coord%[x]_indg or tile_coord%pert_[x]_indg - ! - ! ------------------------------------------------------------------- - - integer, intent(in) :: N_tile - - integer, intent(in), dimension(N_tile) :: tc_i_indg, tc_j_indg - real, intent(in), dimension(N_tile) :: tc_minlon, tc_minlat - real, intent(in), dimension(N_tile) :: tc_maxlon, tc_maxlat - - type(grid_def_type), intent(in) :: tile_grid_g - type(grid_def_type) :: tile_grid - - ! local variables - - integer :: n - - real :: this_minlon, this_minlat, this_maxlon, this_maxlat - - real :: min_min_lon, min_min_lat, max_max_lon, max_max_lat - - integer :: ind_i_min, ind_i_max, ind_j_min, ind_j_max - - integer :: this_i_indg, this_j_indg - integer , allocatable :: i_indg_(:), j_indg_(:) - logical :: c3_grid - character(len=*), parameter :: Iam = 'get_minExtent_grid' - character(len=400) :: err_msg - - ! ------------------------------------------------- - - min_min_lon = 180. ! initialize - min_min_lat = 90. - max_max_lon = -180. - max_max_lat = -90. - - ind_i_min = tile_grid_g%N_lon+1 ! initialize - ind_j_min = tile_grid_g%N_lat+1 - ind_i_max = -1 - ind_j_max = -1 - - ! THIS COMMENT SEEMS OUTDATED (reichle, 2 Aug 2020) - ! for c3 grid, only get the ll_,ur_ lat and lon, the index is meaningless; - ! it will be used in creating the lat_lon pert_grid - - if(index(tile_grid_g%gridtype,"c3") /=0) then - - ! for cube-sphere grids, do NOT zoom in - - tile_grid=tile_grid_g - - return - - endif - - if (N_tile == 0) then - tile_grid=tile_grid_g - tile_grid%n_lon = 0 - tile_grid%n_lat = 0 - return - endif - - do n=1,N_tile - - this_minlon = tc_minlon(n) - this_minlat = tc_minlat(n) - this_maxlon = tc_maxlon(n) - this_maxlat = tc_maxlat(n) - - this_i_indg = tc_i_indg(n) - this_j_indg = tc_j_indg(n) - - min_min_lon = min( min_min_lon, this_minlon) - min_min_lat = min( min_min_lat, this_minlat) - max_max_lon = max( max_max_lon, this_maxlon) - max_max_lat = max( max_max_lat, this_maxlat) - - ind_i_min = min( ind_i_min, this_i_indg) - ind_j_min = min( ind_j_min, this_j_indg) - ind_i_max = max( ind_i_max, this_i_indg) - ind_j_max = max( ind_j_max, this_j_indg) - - end do - - ! assemble tile_grid (revised 20 Sep 2010, reichle) - - tile_grid%N_lon = ind_i_max - ind_i_min + 1 - tile_grid%N_lat = ind_j_max - ind_j_min + 1 - - tile_grid%i_offg = ind_i_min - tile_grid_g%ind_base - tile_grid%j_offg = ind_j_min - tile_grid_g%ind_base - - tile_grid%dlon = tile_grid_g%dlon - - if (index(tile_grid_g%gridtype,'LatLon')/=0) then - - tile_grid%dlat = tile_grid_g%dlat - - tile_grid%ll_lon = tile_grid_g%ll_lon + real(tile_grid%i_offg)*tile_grid%dlon - tile_grid%ll_lat = tile_grid_g%ll_lat + real(tile_grid%j_offg)*tile_grid%dlat - - tile_grid%ur_lon = tile_grid%ll_lon + real(tile_grid%N_lon)*tile_grid%dlon - tile_grid%ur_lat = tile_grid%ll_lat + real(tile_grid%N_lat)*tile_grid%dlat - - elseif ( index(tile_grid_g%gridtype,'EASEv') /=0 ) then - - ! *average* dlat over the domain - - tile_grid%dlat = (max_max_lat - min_min_lat)/real(tile_grid%N_lat) - - tile_grid%ll_lon = min_min_lon - tile_grid%ll_lat = min_min_lat - - tile_grid%ur_lon = max_max_lon - tile_grid%ur_lat = max_max_lat - - else - - err_msg = 'not yet implemented for ' // tile_grid_g%gridtype - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - tile_grid%gridtype = tile_grid_g%gridtype - - tile_grid%ind_base = tile_grid_g%ind_base ! should this be inherited??? - - tile_grid%i_dir = tile_grid_g%i_dir - tile_grid%j_dir = tile_grid_g%j_dir - - end function get_minExtent_grid - - ! ********************************************************************** - - subroutine get_number_of_tiles_in_cell_ij( N_tile, tc_i_indg, tc_j_indg, tile_grid, & - N_tile_in_cell_ij) - - ! find out how many tiles are in a given tile definition grid cell - ! reichle, 22 Jul 2005 - ! - ! make sure to pass in consistent tile_coord (tc) and tile_grid_g inputs: - ! - ! iff tile_grid_g is the grid that is associated with the tile space definition, - ! then tc_[x]_indg must be tile_coord%[x]_indg - ! - ! iff tile_grid_g is the grid that supports efficient mapping for perts and the EnKF analysis, - ! then tc_[x]_indg must be tile_coord%pert_[x]_indg - ! - ! wjiang(?) -- split off from LDASsa legacy subroutine get_tile_num_in_cell_ij() - ! - ! reichle+wjiang, 19 Aug 2020 -- changed interface to generically accommodate use of - ! tile_coord%[x]_indg or tile_coord%pert_[x]_indg - ! - ! ---------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_tile - - integer, intent(in), dimension(N_tile) :: tc_i_indg, tc_j_indg - - type(grid_def_type), intent(in) :: tile_grid - - integer, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(inout) :: & - N_tile_in_cell_ij - - ! locals - - integer :: i, j, k, n, off_i, off_j - - - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - ! (re-)initialize - - N_tile_in_cell_ij = 0 - - do n=1,N_tile - - i = tc_i_indg(n) - off_i - j = tc_j_indg(n) - off_j - - N_tile_in_cell_ij(i,j) = N_tile_in_cell_ij(i,j) + 1 - - enddo - - if (logit) write (logunit,*) & - 'Maximum number of tiles in tile def grid cell = ', maxval(N_tile_in_cell_ij) - if (logit) write (logunit,*) - - end subroutine get_number_of_tiles_in_cell_ij - - ! ********************************************************************** - - subroutine get_tile_num_in_cell_ij( N_tile, tc_i_indg, tc_j_indg, tile_grid, & - max_N_tile_in_cells, tile_num_in_cell_ij ) - - ! find out tile_num in given cells - ! - ! The indices tile_coord%i_indg and tile_coord%j_indg refer to the *global* - ! tile definition grid (as obtained from the tile_coord_file). - ! Integers "off_i" and "off_j" describe the offset between the global - ! "tile_grid_g" and a smaller "tile_grid_d" for the domain of interest. - ! With these offsets tile2grid() can be used to map from a - ! subgrid of "tile_grid_g" to tile space - ! - ! reichle, 22 Jul 2005 - ! - ! make sure to pass in consistent tile_coord (tc) and tile_grid_g inputs: - ! - ! iff tile_grid_g is the grid that is associated with the tile space definition, - ! then tc_[x]_indg must be tile_coord%[x]_indg - ! - ! iff tile_grid_g is the grid that supports efficient mapping for perts and the EnKF analysis, - ! then tc_[x]_indg must be tile_coord%pert_[x]_indg - ! - ! wjiang(?) -- split off from LDASsa legacy subroutine get_tile_num_in_cell_ij() - ! - ! reichle+wjiang, 19 Aug 2020 -- changed interface to generically accommodate use of - ! tile_coord%[x]_indg or tile_coord%pert_[x]_indg - ! - ! ---------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_tile - - integer, intent(in), dimension(N_tile) :: tc_i_indg, tc_j_indg - - type(grid_def_type), intent(in) :: tile_grid - - integer, intent(in) :: max_N_tile_in_cells - - ! the pointer is an output arguments that is allocated here - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij - - integer, dimension(tile_grid%N_lon,tile_grid%N_lat) :: & - N_tile_in_cell_ij - - ! locals - - integer, parameter :: nodata = -9999. - - integer :: i, j, k, n, off_i, off_j - - ! ----------------------------------------------------------------- - ! - ! allocate and initialize pointers if present - - - allocate(tile_num_in_cell_ij(tile_grid%N_lon,tile_grid%N_lat, & - max_N_tile_in_cells)) - - tile_num_in_cell_ij = nodata - - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - ! (re-)initialize - - N_tile_in_cell_ij = 0 - - do n=1,N_tile - - i = tc_i_indg(n) - off_i - j = tc_j_indg(n) - off_j - - N_tile_in_cell_ij(i,j) = N_tile_in_cell_ij(i,j) + 1 - - k = N_tile_in_cell_ij(i,j) - - tile_num_in_cell_ij(i,j,k) = n - - end do - - end subroutine get_tile_num_in_cell_ij - - ! ******************************************************************* - - subroutine get_tile_num_from_latlon(N_catd, tile_coord, & - tile_grid, N_tile_in_cell_ij, tile_num_in_cell_ij, N_latlon, lat, lon, & - tile_num, max_dist_x, max_dist_y ) - - ! bug fix re. "check that lat/lon is inside tile_grid" - ! - reichle, 2005/11/17 - ! - ! added optional input "max_dist" that permits returning a valid tile_num - ! even if lat/lon is not within the bounding box of the chosen tile - ! - reichle, 2008/03/28 - ! - ! distance units are in [deg]; added functionality for latitude-dependent - ! meridional max distance (max_dist_x) - ! - reichle, 2014/12/23 - - implicit none - - integer, intent(in) :: N_catd, N_latlon - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid - - integer, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(in) :: N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - real, dimension(N_latlon), intent(in) :: lat, lon - - integer, dimension(N_latlon), intent(out) :: tile_num - - real, dimension(N_latlon), optional, intent(in) :: max_dist_x ! vector [deg] - real, optional, intent(in) :: max_dist_y ! scalar [deg] - - - ! local variables - - integer, parameter :: nodata_tilenum = -9999 - - integer :: n, k, i_ind, j_ind, this_tile_num - - logical :: outside_bbox, too_far_away - - real :: tmp_dist, min_dist - real :: tmp_dist_y, min_dist_y, max_dist_tmp_y - real :: tmp_dist_x, min_dist_x - real, dimension(N_latlon) :: max_dist_tmp_x - - character(len=*), parameter :: Iam = 'get_tile_num_from_latlon' - character(len=400) :: err_msg - - ! ----------------------------------------------------------- - - ! initialize - - max_dist_tmp_x = 0. - max_dist_tmp_y = 0. - - if (present(max_dist_x)) max_dist_tmp_x = max_dist_x - if (present(max_dist_y)) max_dist_tmp_y = max_dist_y - - tile_num = nodata_tilenum ! initialize to negative value - - ! loop through observations - - do n=1,N_latlon - - ! Make sure lat/lon is *inside* tile_grid, otherwise do nothing. - ! Do *not* allow obs outside tile_grid because obs perturbations - ! routines are not set up to generate perturbations for such obs, - ! and obs_pred would be questionable anyway. - ! - reichle+csdraper, 29 Jan 2016 - - if ( tile_grid%ll_lat < (lat(n) ) .and. & - tile_grid%ll_lon < (lon(n) ) .and. & - (lat(n) ) < tile_grid%ur_lat .and. & - (lon(n) ) < tile_grid%ur_lon ) then - - ! min_dist = distance betw lat/lon in question and center-of-mass of - ! matching tile - - min_dist = 1.e10 ! initialize (bug fix, csdraper+reichle, 30 Jun 2015) - min_dist_x = 1.e10 ! initialize - min_dist_y = 1.e10 ! initialize - - ! determine grid cell that contains lat/lon - - call get_ij_ind_from_latlon( tile_grid, lat(n), lon(n), i_ind, j_ind ) - - ! make sure that i/j_ind is still within bounds - ! (works in conjunction with if statement above re. ll/ur_lat/lon) - - i_ind = min( max(i_ind, 1), tile_grid%N_lon ) - j_ind = min( max(j_ind, 1), tile_grid%N_lat ) - - ! map from i_ind, j_ind to tile_num - - if ( index(tile_grid%gridtype, 'EASEv') /=0 ) then - - ! ASSUMPTION: tiles match EASE grid cells exactly - ! (unless "outside" the domain, eg. water surface) - - if (N_tile_in_cell_ij(i_ind,j_ind)==1) then - - tile_num(n)=tile_num_in_cell_ij(i_ind,j_ind,1) - - min_dist_x = abs(lon(n) - tile_coord(tile_num(n))%com_lon) - min_dist_y = abs(lat(n) - tile_coord(tile_num(n))%com_lat) - - elseif (N_tile_in_cell_ij(i_ind,j_ind)==0) then - - ! Do nothing. If given EASE grid cell is not land, - ! tile_num will not change from its initialized value. - - else - - err_msg = 'something wrong for EASE grid' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end if - - elseif (index(tile_grid%gridtype, 'LatLon')/=0) then - - ! Loop through all tiles within grid cell that contain lat/lon and - ! find minimum distance (Minkowski norm). - ! If there are no land tiles in given tile definition grid cell, - ! tile_num will not change from its initialized value. - - do k=1,N_tile_in_cell_ij(i_ind,j_ind) - - this_tile_num = tile_num_in_cell_ij(i_ind,j_ind,k) - - tmp_dist_x = abs(lon(n) - tile_coord(this_tile_num)%com_lon) - tmp_dist_y = abs(lat(n) - tile_coord(this_tile_num)%com_lat) - - tmp_dist = tmp_dist_x + tmp_dist_y ! Minkowski norm - - if (tmp_dist0) then - - outside_bbox = ( & - lon(n) < tile_coord(tile_num(n))%min_lon .or. & - lon(n) > tile_coord(tile_num(n))%max_lon .or. & - lat(n) < tile_coord(tile_num(n))%min_lat .or. & - lat(n) > tile_coord(tile_num(n))%max_lat ) - - too_far_away = ( & - min_dist_x > max_dist_tmp_x(n) .or. & - min_dist_y > max_dist_tmp_y ) - - ! keep tile_num unless obs is outside the bounding box *and* too far away - - if (outside_bbox .and. too_far_away) tile_num(n) = nodata_tilenum - - end if - - end if - - end do - - end subroutine get_tile_num_from_latlon - - ! ******************************************************************* - - subroutine get_ij_ind_from_latlon( tile_grid, lat, lon, i_ind, j_ind ) - - ! NOTE order of input arguments ("lat", "lon", "lon_ind", "lat_ind") - - ! find i/j_ind of grid cell that contains lat/lon - ! - ! that is, for given lat/lon, find out corresponding i/j_ind into an array - ! of size N_lon-by-N_lat whose lat/lon coordinates are defined by tile_grid - - ! NOTE: ALL arrays in LDASsa are declared with base 1 - - ! typical use: have lat/lon of an obs, want to know i/j_ind within the - ! grid (array) that defines the tile space ("tile_grid_d") - - ! major revision by reichle, 11 May 2011 - - implicit none - - type(grid_def_type), intent(in) :: tile_grid - - real, intent(in) :: lat, lon - integer, intent(out) :: i_ind, j_ind - - real :: lats(1), lons(1) - integer :: i_inds(1), j_inds(1) - - ! local variables - - real :: r, s, i_indg, j_indg - - character(len=*), parameter :: Iam = 'get_ij_ind_from_latlon' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - ! - ! select grid type - - if (index(tile_grid%gridtype, 'EASEv')/=0) then - - ! EASE grid lat/lon to index provides *global*, *0-based* index! - - call ease_convert(tile_grid%gridtype, lat, lon, r, s) - - i_indg = nint(r) ! i_ind or lon_ind - j_indg = nint(s) ! j_ind or lat_ind - - ! convert to index into array defined by tile_grid_d - - i_ind = i_indg - tile_grid%i_offg - (tile_grid%ind_base - 1) - j_ind = j_indg - tile_grid%j_offg - (tile_grid%ind_base - 1) - - elseif (index(tile_grid%gridtype, 'LatLon')/=0) then - - ! ll_lon and ll_lat refer to lower left corner of grid cell - ! ur_lon and ur_lat refer to upper right corner of grid cell - ! (as opposed to the grid point in the center of the grid cell) - ! - ! ALL arrays in LDASsa are declared with base 1 (--> use "ceiling") - - if (tile_grid%i_dir==1) then - - i_ind = ceiling( (lon - tile_grid%ll_lon)/tile_grid%dlon ) - - else - - i_ind = ceiling( (tile_grid%ur_lon - lon)/tile_grid%dlon ) - - end if - - - if (tile_grid%j_dir==1) then - - j_ind = ceiling( (lat - tile_grid%ll_lat)/tile_grid%dlat ) - - else - - j_ind = ceiling( (tile_grid%ur_lat - lat)/tile_grid%dlat ) - - end if - - else - - call ldas_abort(LDAS_GENERIC_ERROR, Iam, 'unknown grid type') - - end if - - end subroutine get_ij_ind_from_latlon - - ! ******************************************************************* - - subroutine get_tile_num_in_ellipse( lon, lat, r_x, r_y, & - N_tile, tile_coord, tile_grid, & - N_tile_in_cell_ij, tile_num_in_cell_ij, & - N_tile_in_ellipse, tile_num_in_ellipse, norm_square_distance ) - - ! reichle, 22 Feb 2015 - - ! return tile numbers of all tiles within ellipse with center at lat/lon - ! and axes r_x, r_y - ! - ! also return normalized square distance of tile center-of-mass lat/lon from lat/lon - - ! TO DO: what about dateline? poles? [ignore for now] - - ! NOTE: get_tile_num_in_ellipse() returns zero tiles (N_tile_in_ellipse=0) - ! if ellipse straddles date line and EASE[v2] grid is used - ! - reichle, 17 Apr 2017 - - - implicit none - - real, intent(in) :: lon, lat, r_x, r_y - - integer, intent(in) :: N_tile - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid - - integer, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(in) :: & - N_tile_in_cell_ij - - integer, dimension(:,:,:), pointer :: tile_num_in_cell_ij ! input - - integer, intent(out) :: N_tile_in_ellipse - - integer, dimension(N_tile), intent(out) :: tile_num_in_ellipse - - real, dimension(N_tile), intent(out) :: norm_square_distance - - ! local variables - - real :: minlat, maxlat, minlon, maxlon, tmp_dx, tmp_dy, tmp_dist - real :: r_x_square, r_y_square - - integer :: i_ind_ll, i_ind_ur, i_min, i_max - integer :: j_ind_ll, j_ind_ur, j_min, j_max - - integer :: ii, jj, kk, mm, nn - - ! ------------------------------------------------------------- - ! - ! initialize - - N_tile_in_ellipse = 0 - - tile_num_in_ellipse = nodata_generic - - r_x_square = r_x**2 - r_y_square = r_y**2 - - ! identify rectangle +/- r_x and +/- r_y around lat/lon - - tmp_dx = tile_grid%dlon ! broaden rectangle to avoid missing tiles - tmp_dy = tile_grid%dlon ! use *dlon* because for EASE grid *dlat* is ill-defined - - minlon = lon - r_x - tmp_dx - maxlon = lon + r_x + tmp_dx - minlat = lat - r_y - tmp_dy - maxlat = lat + r_y + tmp_dy - - ! find i,j indices of two opposite corners (lower left and upper right) - - call get_ij_ind_from_latlon( tile_grid, minlat, minlon, i_ind_ll, j_ind_ll ) - call get_ij_ind_from_latlon( tile_grid, maxlat, maxlon, i_ind_ur, j_ind_ur ) - - ! restrict i_ind_* and j_ind_* to fall within tile_grid - - i_ind_ll = min( tile_grid%N_lon, max( 1, i_ind_ll )) - j_ind_ll = min( tile_grid%N_lat, max( 1, j_ind_ll )) - i_ind_ur = min( tile_grid%N_lon, max( 1, i_ind_ur )) - j_ind_ur = min( tile_grid%N_lat, max( 1, j_ind_ur )) - - ! find smaller and larger of the two indices - ! (index may run north-to-south/west-to-east depending on i_dir/j_dir) - - i_min = min( i_ind_ll, i_ind_ur ) - i_max = max( i_ind_ll, i_ind_ur ) - - j_min = min( j_ind_ll, j_ind_ur ) - j_max = max( j_ind_ll, j_ind_ur ) - - ! loop through all grid cells "inside" rectangle and identify tiles w/in ellipse - - norm_square_distance = nodata_generic - - mm = 0 - - do ii=i_min,i_max - do jj=j_min,j_max - - do kk=1,N_tile_in_cell_ij(ii,jj) - - nn = tile_num_in_cell_ij(ii,jj,kk) - - tmp_dist = ( & - (tile_coord(nn)%com_lon - lon)**2 / r_x_square + & - (tile_coord(nn)%com_lat - lat)**2 / r_y_square ) - - if (tmp_dist <= 1.) then - - ! record tile number and distance - - mm = mm+1 - - tile_num_in_ellipse(mm) = nn - - norm_square_distance(mm) = tmp_dist - - end if - - end do - - end do - end do - - N_tile_in_ellipse = mm - - end subroutine get_tile_num_in_ellipse - - ! ********************************************************************** - - subroutine tile2grid_simple( N_tile, i_indgs, j_indgs, tile_grid, tile_data, grid_data) - - ! Interpolate from tile space to grid space without interpolation/weighted/no-data-handling. - ! Simply assign the tile value to the grid cell (last assignment prevails) - - implicit none - - integer, intent(in) :: N_tile - - integer, intent(in) :: i_indgs(:) ! dimension(N_tile) - integer, intent(in) :: j_indgs(:) ! dimension(N_tile) - - type(grid_def_type), intent(in) :: tile_grid - - real, dimension(N_tile), intent(in) :: tile_data - - real, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(out) :: grid_data - - ! local variables - - integer :: n, i, j, off_i, off_j - real, parameter :: no_data= -9999. - character(len=*), parameter :: Iam = 'tile2grid_simple' - character(len=400) :: err_msg - - ! ------------------------------------ - - if (size(i_indgs)/=N_tile .or. size(j_indgs)/=N_tile) then - err_msg = '[i,j]_indg and tile_data do not match.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - ! - ! adjust for 0-based indexing (eg., EASE grids) - ! - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - ! loop through tile space - - grid_data = no_data - do n=1,N_tile - i = i_indgs(n) - off_i - j = j_indgs(n) - off_j - grid_data(i,j) = tile_data(n) - end do - - end subroutine tile2grid_simple - - ! ******************************************************************* - ! - ! The subroutine tile2grid_full() is the original LDASsa tile2grid() - ! subroutine with weighted averaging and no-data-handling. - ! - ! This subroutine should no longer be used and is provided here for - ! reference only. Use MAPL LocationStream instead. - ! - ! - reichle, 13 July 2020 - - subroutine tile2grid_full( N_tile, tile_coord, tile_grid, tile_data, & - grid_data, no_data_value, no_data_tol, echo ) - - ! map from tile space to tile definition grid - ! - ! NOTE: tile_coord must match tile_data - ! - ! optional inputs: - ! no_data_value : - ! no_data_tol : tolerance when checking tile_data - ! against no_data_value - ! echo : echo no_data_value and tolerance - ! - ! The indices tile_coord%i_indg and tile_coord%j_indg refer to the *global* - ! tile definition grid (as obtained from the tile_coord_file). - ! Integers "off_i" and "off_j" describe the offset between the global - ! "tile_grid_g" and a smaller "tile_grid_d" for the domaim of interest. - ! With these offsets tile2grid() can be used to map from tile space to a - ! subgrid of "tile_grid_g" - - ! reichle, 28 Jan 2005 - ! reichle, 16 May 2005 - added offset for "domain" grid - ! reichle, 21 May 2010 - off_i, off_j now part of grid_def_type - - implicit none - - integer, intent(in) :: N_tile - - type(tile_coord_type), dimension(:), pointer :: tile_coord ! input - - type(grid_def_type), intent(in) :: tile_grid - - real, dimension(N_tile), intent(in) :: tile_data - - real, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(out) :: grid_data - - real, intent(in), optional :: no_data_value, no_data_tol - - logical, intent(in), optional :: echo - - ! local variables - - integer :: n, i, j, off_i, off_j - - real :: w, no_data, tol - - real, parameter :: no_data_default = -9999. - real, parameter :: no_data_tol_default = 1e-4 - - real, dimension(tile_grid%N_lon,tile_grid%N_lat) :: wgrid - - character(len=*), parameter :: Iam = 'tile2grid' - character(len=400) :: err_msg - - ! ------------------------------------ - - if (size(tile_coord)/=N_tile) then - err_msg = 'tile_coord and tile_data do not match.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (present(no_data_value)) then - no_data = no_data_value - else - no_data = no_data_default - end if - - if (present(no_data_tol)) then - tol = no_data_tol - else - tol = no_data_tol_default - end if - - if (present(echo)) then - if (echo .and. logit) then - write (logunit,*) 'tile2grid: using no-data-value = ', no_data , & - ' with tolerance = ', tol - end if - end if - - ! ------------------------------------------------------ - ! - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - ! initialize - - grid_data = 0. - wgrid = 0. - - ! loop through tile space - - do n=1,N_tile - - i = tile_coord(n)%i_indg - off_i - j = tile_coord(n)%j_indg - off_j - - w = tile_coord(n)%frac_cell - - if (abs(tile_data(n)-no_data)>tol) then - - grid_data(i,j) = grid_data(i,j) + w*tile_data(n) - - wgrid(i,j) = wgrid(i,j) + w - - end if - - end do - - ! normalize and set no-data-value - - do i=1,tile_grid%N_lon - do j=1,tile_grid%N_lat - - if (wgrid(i,j)>0.) then - - grid_data(i,j) = grid_data(i,j)/wgrid(i,j) - - else - - grid_data(i,j) = no_data - - end if - - end do - end do - - end subroutine tile2grid_full - - ! ******************************************************************* - - subroutine tile_mask_grid( tile_grid, N_tile, i_indgs,j_indgs, grid_data) - - ! set grid cell to no value if there is no tile in it - - implicit none - - type(grid_def_type), intent(in) :: tile_grid - - integer, intent(in) :: N_tile - - integer, intent(in) :: i_indgs(:) - integer, intent(in) :: j_indgs(:) - - real, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(inout) :: grid_data - - real, dimension(tile_grid%N_lon,tile_grid%N_lat) :: grid - - ! local variables - real, parameter :: no_data= -9999. - integer :: n, i, j, off_i, off_j - - character(len=*), parameter :: Iam = 'tile_mask_grid' - character(len=400) :: err_msg - - ! ------------------------------------ - - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - grid = no_data - do n=1,N_tile - i = i_indgs(n) - off_i - j = j_indgs(n) - off_j - grid(i,j) = grid_data(i,j) - end do - grid_data = grid - - end subroutine tile_mask_grid - - ! ********************************************************************** - - subroutine grid2tile_real( tile_grid, N_tile, i_indgs,j_indgs, grid_data, tile_data) - - ! map from grid to tile space - ! - ! The indices tile_coord%i_indg and tile_coord%j_indg refer to the *global* - ! tile definition grid (as obtained from the tile_coord_file). - ! Integers "off_i" and "off_j" describe the offset between the global - ! "tile_grid_g" and a smaller "tile_grid_d" for the domain of interest. - ! With these offsets grid2tile() can be used to map from a - ! subgrid of "tile_grid_g" to tile space - ! - ! reichle, 28 Jan 2005 - ! reichle, 16 May 2005 - added offset for "domain" grid - - implicit none - - type(grid_def_type), intent(in) :: tile_grid - - integer, intent(in) :: N_tile - - integer, intent(in) :: i_indgs(:) - integer, intent(in) :: j_indgs(:) - - real, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(in) :: grid_data - - real, dimension(N_tile), intent(out) :: tile_data - - ! local variables - - integer :: n, i, j, off_i, off_j - - character(len=*), parameter :: Iam = 'grid2tile_real' - character(len=400) :: err_msg - - ! ------------------------------------ - - if (size(i_indgs)/=N_tile .or. size(j_indgs)/=N_tile) then - err_msg = '[i,j]_indg and tile_data do not match.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - do n=1,N_tile - - i = i_indgs(n) - off_i - j = j_indgs(n) - off_j - - tile_data(n) = grid_data(i,j) - - end do - - end subroutine grid2tile_real - - ! ********************************************************************** - - subroutine grid2tile_real8( tile_grid, N_tile, i_indgs,j_indgs, grid_data_8, tile_data_8) - - ! same as grid2tile_real but for real*8 - ! - ! reichle, 3 Feb 2014 - - implicit none - - type(grid_def_type), intent(in) :: tile_grid - - integer, intent(in) :: N_tile - integer, intent(in) :: i_indgs(:) - integer, intent(in) :: j_indgs(:) - - real*8, dimension(tile_grid%N_lon,tile_grid%N_lat), intent(in) :: grid_data_8 - - real*8, dimension(N_tile), intent(out) :: tile_data_8 - - ! local variables - - integer :: n, i, j, off_i, off_j - - character(len=*), parameter :: Iam = 'grid2tile_real8' - character(len=400) :: err_msg - - ! ------------------------------------ - - if (size(i_indgs)/=N_tile .or. size(j_indgs)/=N_tile) then - err_msg = '[i,j]_indg and tile_data do not match.' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - ! adjust for 0-based indexing (eg., EASE grids) - - off_i = tile_grid%i_offg + (tile_grid%ind_base - 1) - off_j = tile_grid%j_offg + (tile_grid%ind_base - 1) - - do n=1,N_tile - - i = i_indgs(n) - off_i - j = j_indgs(n) - off_j - - tile_data_8(n) = grid_data_8(i,j) - - end do - - end subroutine grid2tile_real8 - - ! ********************************************************************** - -end module LDAS_TileCoordRoutines - - -! ================================= EOF ======================================= diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordType.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordType.F90 deleted file mode 100644 index 4861ddce..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_TileCoordType.F90 +++ /dev/null @@ -1,488 +0,0 @@ - -! type definitions for tile coordinates and domain -! -! reichle, 26 Jan 2005 -! reichle, 14 Apr 2006 - split tile_coord.F90 into 2 files to avoid -! having more than one module per file -! reichle, 2 Aug 2020 - removed tile_typ_* (use MAPL_Ocean, MAPL_Land, etc instead) -! -! ======================================================================== -! -! type definition for tile coordinates - -module LDAS_TileCoordType - - ! TODO: Replace ldas_abort with MAPL_ABORT - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - use LDAS_ensdrv_Globals, ONLY: & - nodata_generic - - use iso_fortran_env - - implicit none - - private - - public :: tile_coord_type - public :: grid_def_type - - public :: init_grid_def_type - public :: io_grid_def_type - public :: io_tile_coord_type - public :: T_TILECOORD_STATE - public :: TILECOORD_WRAP - - public :: operator (==) - - ! ------------------------------------------------------------ - - type :: tile_coord_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer :: tile_id ! unique tile ID - integer :: f_num ! full domain ID - integer :: typ ! (0=MAPL_Ocean, 100=MAPL_Land, 19=MAPL_Lake, 20=MAPL_LandIce) - integer :: pfaf ! Pfafstetter number (for land tiles, NOT unique) - real :: com_lon ! center-of-mass longitude - real :: com_lat ! center-of-mass latitude - real :: min_lon ! minimum longitude (bounding box for tile) - real :: max_lon ! maximum longitude (bounding box for tile) - real :: min_lat ! minimum latitude (bounding box for tile) - real :: max_lat ! maximum latitude (bounding box for tile) - integer :: i_indg ! i index (w.r.t. *global* grid that cuts tiles) - integer :: j_indg ! j index (w.r.t. *global* grid that cuts tiles) - ! For cubed-sphere tile spaces, pert_[x]_indg refers to a lat-lon perturbation grid that will - ! be created at runtime to support efficient mapping for perturbations and the EnKF analysis. - ! For EASE and LatLon tile spaces, pert_[x]_indg is identical to [x]_indg - integer :: pert_i_indg ! i index (w.r.t. *global* pert_grid for perts and EnKF) - integer :: pert_j_indg ! j index (w.r.t. *global* pert_grid for perts and EnKF) - real :: frac_cell ! area fraction of grid cell covered by tile - real :: frac_pfaf ! fraction of Pfafstetter catchment for land tiles - real :: area ! area [km^2] - real :: elev ! elevation above sea level [m] - - - end type tile_coord_type - - - ! ------------------------------------------------------------ - ! - ! definition of *rectangular* (regular) grid - ! - ! Possible grid types (structure field "gridtype"): - ! - ! - "LatLon" : regular lat/lon grid (constant dlon, dlat) - ! - "EASEv1_Mxx" : cylindrical EASEv1 grid (constant dlon, variable dlat) - ! - "EASEv2_Mxx" : cylindrical EASEv2 grid (constant dlon, variable dlat) - ! - ! Grid orientation (convention): - ! - ! "LatLon" : 1-based indexing, SouthWest to NorthEast - ! "EASEv1_Mxx" : 0-based indexing, NorthWest to SouthEast - ! "EASEv2_Mxx" : 0-based indexing, NorthWest to SouthEast - ! - ! Grids are defined by the following fields: - ! - ! --------------------------------------------------------- - ! | || "LatLon" | "EASEv1_Mxx" | - ! | || | "EASEv2_Mxx" | - ! --------------------------------------------------------- - ! | indexing || ind_base | ind_base | - ! | || i_dir, j_dir | i_dir, j_dir | - ! --------------------------------------------------------- - ! | extent || N_lon, N_lat | N_lon, N_lat | - ! --------------------------------------------------------- - ! | position || ll_lon, ll_lat | i_offg, j_offg | - ! --------------------------------------------------------- - ! | spacing || dlon, dlat | gridtype ('Mxx') | - ! --------------------------------------------------------- - ! - ! All other fields are derived from the above parameters - ! (except "descr", which is just a descriptor) - ! - ! Lon, lat convention is -180<=lon<=180, -90<=lat<=90 - ! - ! ll_lon/ll_lat denote the coordinates of the lower left hand - ! corner of the lower left grid cell (=southwestern corner of domain) - ! ur_lon/ur_lat denote the coordinates of the upper right hand - ! corner of the upper right grid cell (=northeastern corner of domain) - - type :: grid_def_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - character(40) :: gridtype ! type of grid, eg. "LatLon", "EASEv1_M36", "EASEv2_M09", ... - integer :: ind_base ! 0=zero-based indices (EASE), 1=one-based indices (LatLon) - integer :: i_dir ! direction of indices (+1=W-to-E, -1=E-to-W) - integer :: j_dir ! direction of indices (+1=S-to-N, -1=N-to-S) - integer :: N_lon ! number of longitude nodes - integer :: N_lat ! number of latitude nodes - integer :: i_offg ! minimum lon index (offset from *global* grid) - integer :: j_offg ! minimum lat index (offset from *global* grid) - ! ! "LatLon" : i_offg -> westernmost longitude - ! ! j_offg -> southernmost latitude - ! ! "EASEv1_Mxx": i_offg -> westernmost longitude - ! ! j_offg -> northernmost latitude - ! ! "EASEv2_Mxx": i_offg -> westernmost longitude - ! ! j_offg -> northernmost latitude - real :: ll_lon ! lower left longitude of grid cell edge [deg] - real :: ll_lat ! lower left latitude of grid cell edge [deg] - real :: ur_lon ! upper right longitude of grid cell edge [deg] - real :: ur_lat ! upper right latitude of grid cell edge [deg] - real :: dlon ! longitude grid spacing [deg] - real :: dlat ! latitude grid spacing [deg] - ! ! "LatLon" : constant - ! ! "EASEv1_Mxx": *average* dlat over grid extent - ! ! "EASEv2_Mxx": *average* dlat over grid extent - - !CLSM_ENSDRV_MPI is NOT updated. will not be saved and bcasted - real(kind=REAL64), dimension(:,:,:), pointer :: LonEdge =>null() - real(kind=REAL64), dimension(:,:,:), pointer :: LatEdge =>null() - - end type grid_def_type - - ! ------------------------------------------------------------ - - ! Wrapper for tile_coord structure - - type T_TILECOORD_STATE - type(tile_coord_type), pointer, contiguous :: tile_coord(:)=>null() - type(tile_coord_type), pointer, contiguous :: tile_coord_f(:)=>null() - integer, pointer :: l2f(:)=>null() - type(grid_def_type) :: tgrid_g ! tile_grid_g - type(grid_def_type) :: pgrid_g ! pert_grid_g - type(grid_def_type) :: pgrid_f ! pert_grid_f - type(grid_def_type) :: pgrid_l ! pert_grid_l - end type T_TILECOORD_STATE - - type TILECOORD_WRAP - type(T_TILECOORD_STATE), pointer :: ptr=>null() - end type TILECOORD_WRAP - - ! -------------------------------------------------------------- - - interface operator (==) - module procedure eq_grid_def_type - end interface - - ! ******************************************************************* - -contains - - subroutine init_grid_def_type( grid ) - - implicit none - - type(grid_def_type), intent(out) :: grid - - grid%gridtype = 'undefined' - grid%ind_base = nint(nodata_generic) - grid%i_dir = nint(nodata_generic) - grid%j_dir = nint(nodata_generic) - grid%N_lon = nint(nodata_generic) - grid%N_lat = nint(nodata_generic) - grid%i_offg = nint(nodata_generic) - grid%j_offg = nint(nodata_generic) - grid%ll_lon = nodata_generic - grid%ll_lat = nodata_generic - grid%ur_lon = nodata_generic - grid%ur_lat = nodata_generic - grid%dlon = nodata_generic - grid%dlat = nodata_generic - - end subroutine init_grid_def_type - - ! ******************************************************************* - - function eq_grid_def_type( grid_1, grid_2 ) - - ! reichle, 24 July 2010 - - logical :: eq_grid_def_type - - type(grid_def_type), intent(in) :: grid_1, grid_2 - - if ( trim(grid_1%gridtype) == trim(grid_2%gridtype) .and. & - grid_1%ind_base == grid_2%ind_base .and. & - grid_1%i_dir == grid_2%i_dir .and. & - grid_1%j_dir == grid_2%j_dir .and. & - grid_1%N_lon == grid_2%N_lon .and. & - grid_1%N_lat == grid_2%N_lat .and. & - grid_1%i_offg == grid_2%i_offg .and. & - grid_1%j_offg == grid_2%j_offg .and. & - abs(grid_1%ll_lon-grid_2%ll_lon)<1e-4 .and. & - abs(grid_1%ll_lat-grid_2%ll_lat)<1e-4 .and. & - abs(grid_1%ur_lon-grid_2%ur_lon)<1e-4 .and. & - abs(grid_1%ur_lat-grid_2%ur_lat)<1e-4 .and. & - abs(grid_1%dlon -grid_2%dlon )<1e-4 .and. & - abs(grid_1%dlat -grid_2%dlat )<1e-4 & - ) then - - eq_grid_def_type = .true. - - else - - eq_grid_def_type = .false. - - end if - - end function eq_grid_def_type - - - ! ******************************************************************* - - subroutine io_grid_def_type( action, unitnum, grid, varname ) - - ! reichle, 24 July 2010 - - implicit none - - character, intent(in) :: action - - integer, intent(in) :: unitnum - - type(grid_def_type), intent(inout) :: grid - - character(*), intent(in), optional :: varname - - ! local variables - - character(40) :: vname, tmpstr40, tmpstr40b - - character(len=*), parameter :: Iam = 'io_grid_def_type' - character(len=400) :: err_msg - - ! ------------------------------------------------------------- - - if (present(varname)) then - vname = varname - else - vname = 'grid' - end if - - inquire(unit=unitnum, form=tmpstr40) - - select case (action) - - case ('w','W') - - if ( index(tmpstr40,'UNFORMATTED') /=0 .or. & - index(tmpstr40,'unformatted') /=0 ) then - - ! unformatted output - - write (unitnum) & - grid%gridtype, grid%ind_base, & - grid%i_dir, grid%j_dir, & - grid%N_lon, grid%N_lat, & - grid%i_offg, grid%j_offg, & - grid%ll_lon, grid%ll_lat, & - grid%ur_lon, grid%ur_lat, & - grid%dlon, grid%dlat - - else - - ! write formatted file for easy reading into Matlab - - write(unitnum,*) trim(vname)//".gridtype = '", trim(grid%gridtype),"' ;" - write(unitnum,*) trim(vname)//".ind_base = ", grid%ind_base, " ;" - write(unitnum,*) trim(vname)//".i_dir = ", grid%i_dir, " ;" - write(unitnum,*) trim(vname)//".j_dir = ", grid%j_dir, " ;" - write(unitnum,*) trim(vname)//".N_lon = ", grid%N_lon, " ;" - write(unitnum,*) trim(vname)//".N_lat = ", grid%N_lat, " ;" - write(unitnum,*) trim(vname)//".i_offg = ", grid%i_offg, " ;" - write(unitnum,*) trim(vname)//".j_offg = ", grid%j_offg, " ;" - write(unitnum,*) trim(vname)//".ll_lon = ", grid%ll_lon, " ;" - write(unitnum,*) trim(vname)//".ll_lat = ", grid%ll_lat, " ;" - write(unitnum,*) trim(vname)//".ur_lon = ", grid%ur_lon, " ;" - write(unitnum,*) trim(vname)//".ur_lat = ", grid%ur_lat, " ;" - write(unitnum,*) trim(vname)//".dlon = ", grid%dlon, " ;" - write(unitnum,*) trim(vname)//".dlat = ", grid%dlat, " ;" - write(unitnum,*) - - end if - - case ('r','R') - - if ( index(tmpstr40,'UNFORMATTED') /=0 .or. & - index(tmpstr40,'unformatted') /=0 ) then - - ! unformatted output - - read (unitnum) & - grid%gridtype, grid%ind_base, & - grid%i_dir, grid%j_dir, & - grid%N_lon, grid%N_lat, & - grid%i_offg, grid%j_offg, & - grid%ll_lon, grid%ll_lat, & - grid%ur_lon, grid%ur_lat, & - grid%dlon, grid%dlat - - else - - ! read formatted file - - read(unitnum,*) tmpstr40, tmpstr40b, grid%gridtype - read(unitnum,*) tmpstr40, tmpstr40b, grid%ind_base - read(unitnum,*) tmpstr40, tmpstr40b, grid%i_dir - read(unitnum,*) tmpstr40, tmpstr40b, grid%j_dir - read(unitnum,*) tmpstr40, tmpstr40b, grid%N_lon - read(unitnum,*) tmpstr40, tmpstr40b, grid%N_lat - read(unitnum,*) tmpstr40, tmpstr40b, grid%i_offg - read(unitnum,*) tmpstr40, tmpstr40b, grid%j_offg - read(unitnum,*) tmpstr40, tmpstr40b, grid%ll_lon - read(unitnum,*) tmpstr40, tmpstr40b, grid%ll_lat - read(unitnum,*) tmpstr40, tmpstr40b, grid%ur_lon - read(unitnum,*) tmpstr40, tmpstr40b, grid%ur_lat - read(unitnum,*) tmpstr40, tmpstr40b, grid%dlon - read(unitnum,*) tmpstr40, tmpstr40b, grid%dlat - read(unitnum,*) - - end if - - case default - - err_msg = 'unknown action ' // action - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end subroutine io_grid_def_type - - ! ******************************************************************* - - subroutine io_tile_coord_type( action, unitnum, N_tile, tile_coord ) - - ! reichle, 24 July 2010 - ! reichle, 2 May 2013 - changed N_tile to intent(in) - ! reichle, 7 Jan 2014 - changed to binary (unformatted) I/O - ! wjiang, reichle, 18 Aug 2020 - Added initialization of %pert_[x]_indg during read. - ! Note that %pert_[x]_indg is NOT written out. - - implicit none - - character, intent(in) :: action - - integer, intent(in) :: unitnum - - integer, intent(in) :: N_tile - - type(tile_coord_type), dimension(N_tile), intent(inout) :: tile_coord - - ! local - - integer :: n, istat, N_tile_tmp - - character(len=*), parameter :: Iam = 'io_tile_coord_type' - character(len=400) :: err_msg - integer, allocatable :: tmp_int(:) - real , allocatable :: tmp_real(:) - - ! ------------------------------------------------------------- - - select case (action) - - case ('w','W') - - write (unitnum) N_tile - - write (unitnum) (tile_coord(n)%tile_id, n=1,N_tile) - write (unitnum) (tile_coord(n)%typ, n=1,N_tile) - write (unitnum) (tile_coord(n)%pfaf, n=1,N_tile) - write (unitnum) (tile_coord(n)%com_lon, n=1,N_tile) - write (unitnum) (tile_coord(n)%com_lat, n=1,N_tile) - write (unitnum) (tile_coord(n)%min_lon, n=1,N_tile) - write (unitnum) (tile_coord(n)%max_lon, n=1,N_tile) - write (unitnum) (tile_coord(n)%min_lat, n=1,N_tile) - write (unitnum) (tile_coord(n)%max_lat, n=1,N_tile) - write (unitnum) (tile_coord(n)%i_indg, n=1,N_tile) - write (unitnum) (tile_coord(n)%j_indg, n=1,N_tile) - write (unitnum) (tile_coord(n)%frac_cell, n=1,N_tile) - write (unitnum) (tile_coord(n)%frac_pfaf, n=1,N_tile) - write (unitnum) (tile_coord(n)%area, n=1,N_tile) - write (unitnum) (tile_coord(n)%elev, n=1,N_tile) - - case ('r','R') - - read (unitnum, iostat=istat) N_tile_tmp - - if (istat>0) then - err_msg = 'ERROR reading tile_coord_file. (1)' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - if (N_tile/=N_tile_tmp) then - err_msg = 'inconsistent N_tile' - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - end if - - err_msg = 'ERROR reading tile_coord_file. (2)' - allocate(tmp_int(N_tile)) - allocate(tmp_real(N_tile)) - - read (unitnum, iostat=istat) tmp_int; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%tile_id = tmp_int(:) - read (unitnum, iostat=istat) tmp_int; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%typ = tmp_int(:) - read (unitnum, iostat=istat) tmp_int; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%pfaf = tmp_int(:) - - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%com_lon = tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%com_lat= tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%min_lon= tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%max_lon= tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%min_lat= tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%max_lat= tmp_real(:) - - read (unitnum, iostat=istat) tmp_int; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%i_indg = tmp_int(:) - read (unitnum, iostat=istat) tmp_int; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%j_indg = tmp_int(:) - - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%frac_cell = tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%frac_pfaf = tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%area= tmp_real(:) - read (unitnum, iostat=istat) tmp_real; if (istat>0) call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - tile_coord(:)%elev= tmp_real(:) - - ! Initialize [x]_indg to pert_[x]_indg. For cs tile spaces, pert_[x]_indg will be redefined - tile_coord(:)%pert_i_indg = tile_coord(:)%i_indg - tile_coord(:)%pert_j_indg = tile_coord(:)%j_indg - tile_coord(:)%f_num = -9999 ! not assigned values yet - deallocate(tmp_int, tmp_real) - case default - - err_msg = 'unknown action ' // action - call ldas_abort(LDAS_GENERIC_ERROR, Iam, err_msg) - - end select - - end subroutine io_tile_coord_type - - ! ******************************************************************* - -end module LDAS_TileCoordType - -! ===== EOF ============================================================== - diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_Globals.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_Globals.F90 deleted file mode 100644 index c690c55c..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_Globals.F90 +++ /dev/null @@ -1,176 +0,0 @@ -module LDAS_ensdrv_Globals - - ! global parameters for LDAS ens driver - ! - ! reichle, 25 Mar 2004 - ! reichle, 6 May 2005 - ! reichle, 29 Nov 2010 - deleted N_outselect (obsolete) - ! - added sfc_turb_scheme (choose Louis or Helfand Monin-Obukhov) - ! reichle, 5 Apr 2013 - removed N_out_fields as global parameter - ! wjiang+reichle, - ! 21 May 2020 - added "LDAS_is_nodata" function, checks if "nodata_generic" or "MAPL_UNDEF" - - use, intrinsic :: iso_fortran_env, only : output_unit - - use MAPL_BaseMod, only : MAPL_UNDEF - use LDAS_ExceptionsMod, only: ldas_abort, LDAS_GENERIC_ERROR - - implicit none - - private - - public :: nodata_generic - public :: nodata_tolfrac_generic - public :: nodata_tol_generic - public :: LDAS_is_nodata - public :: logunit - public :: logit - public :: root_logit - public :: log_root_only - - public :: echo_clsm_ensdrv_glob_param - public :: write_status - public :: get_ensid_string - - ! ---------------------------------------------------------------------- - - ! generic no-data-value - - real, parameter :: nodata_generic = -9999. - real, parameter :: nodata_tolfrac_generic = 1.e-4 - - real :: nodata_tol_generic = abs(nodata_generic*nodata_tolfrac_generic) - real :: MAPL_UNDEF_tol_generic = abs(MAPL_UNDEF *nodata_tolfrac_generic) - - ! ---------------------------------------------------------------- - ! - ! log file - - ! Avoid I/O buffering for the log file by setting "logunit" to stdout, - ! then redirect stdout to the log file via driver script ("ldsetup"). - ! In case of an error during execution, this allows capturing of all log messages - ! until the job terminates. - ! - ! NOTE: "logunit=stdout" is disabled if log messages are requested from *all* processors - ! (that is, for "log_root_only=.false.") to avoid garbled output - - integer, parameter :: logunit = output_unit ! defined in iso_fortran_env - - logical, parameter :: log_root_only = .true. - - logical :: logit,root_logit - - -contains - - subroutine echo_clsm_ensdrv_glob_param() - - ! echo all global parameters - - ! call only AFTER opening log file!!! - - implicit none - - write (logunit,*) - write (logunit,*) '-----------------------------------------------------------' - write (logunit,*) - write (logunit,*) 'echo_clsm_ensdrv_glob_param():' - write (logunit,*) - write (logunit,*) 'nodata_generic = ', nodata_generic - write (logunit,*) - write (logunit,*) 'nodata_tolfrac_generic = ', nodata_tolfrac_generic - write (logunit,*) - write (logunit,*) 'nodata_tol_generic = ', nodata_tol_generic - write (logunit,*) - write (logunit,*) 'logunit = ', logunit - write (logunit,*) - write (logunit,*) 'log_root_only = ', log_root_only - write (logunit,*) - write (logunit,*) 'logit = ', logit - write (logunit,*) - - write (logunit,*) - write (logunit,*) 'end echo_clsm_ensdrv_glob_param()' - write (logunit,*) - write (logunit,*) '-----------------------------------------------------------' - write (logunit,*) - - end subroutine echo_clsm_ensdrv_glob_param - - ! ******************************************************************** - - subroutine write_status(lenkf_status) - - ! write status message (success/failure) to designated file - ! - ! hardwired filename, used by ADAS scripts - - ! Draper, reichle, 27 Feb 2012 - - implicit none - - logical, intent(in) :: lenkf_status - - ! -------------------------------------------------- - - open( unit=10, file='lenkf_job_completed.txt' ) - - if (lenkf_status) then - - write (10,*) 'SUCCEEDED' - - else - - write (10,*) 'FAILED' - - endif - - close(unit=10) - - end subroutine write_status - - ! ******************************************************************** - - elemental function LDAS_is_nodata(data) result(no_data) - - real, intent(in) :: data - logical :: no_data - - no_data = & - ( abs(data-nodata_generic) < nodata_tol_generic ) .or. & - ( abs(data-MAPL_UNDEF) < MAPL_UNDEF_tol_generic) - - end function LDAS_is_nodata - - ! ************************************************************* - ! - ! return ensemble id string "_eXXXX" - - subroutine get_ensid_string(ensid_string, id, ens_id_width, num_ensemble) - - ! ens_id_with = 2 + number of digits = total number of chars in ensid_string ("_eXXXX") - - character(*), intent(inout) :: ensid_string - integer, intent(in) :: id - integer, intent(in) :: ens_id_width - integer, intent(in) :: num_ensemble - - character(len=100) :: fmt_str - - if (num_ensemble == 1) then - ensid_string = '' - return - endif - - ! the following format string works only if ens_id_width<=2+9 (see _ASSERT in GEOS_LdasGridcomp.F90) - - write (fmt_str, "(A2,I1,A1,I1,A1)") "(I", ens_id_width-2,".",ens_id_width-2,")" - write (ensid_string, fmt_str) id - ensid_string = '_e'//trim(ensid_string) - - end subroutine get_ensid_string - -end module LDAS_ensdrv_Globals - - -!======== EOF ============================================================== diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_functions.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_functions.F90 deleted file mode 100644 index 6ed8b33c..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_functions.F90 +++ /dev/null @@ -1,384 +0,0 @@ - -module LDAS_ensdrv_functions - - use LDAS_DateTimeMod, ONLY: & - date_time_type, & - get_dofyr_pentad, & - augment_date_time, & - is_leap_year - - use LDAS_ensdrv_Globals, ONLY: & - logit, & - logunit - - use LDAS_ExceptionsMod, ONLY: & - ldas_abort, & - LDAS_GENERIC_ERROR - - implicit none - - private - - public :: get_io_filename - public :: is_in_rectangle - - character(300), private :: tmpstring300 - -contains - - ! ******************************************************************** - - character(300) function get_io_filename( io_path, exp_id, file_tag, & - date_time, dir_name, ens_id, option, file_ext, no_subdirs ) - - ! compose file name for input/output - ! - ! file name = io_path/dir_name/[ensXXXX]/Yyyyy/Mmm/ - ! "exp_id"."file_tag".[ensXXXX.]YYYYMMDD_HHMMz"file_ext" - ! - ! example: iopath = /disk1/output/run1/GLOBAL/ (incl exp_id and domain name) - ! - ! example file_name = iopath/rs/ens0001/Y2005/M05/ - ! run1.ens0001.catch_ldas_rst.20050510_0600z.bin - ! - ! NOTE: if ens_id<0 then ens_id_string==ensXXXX="ens_avg" - ! if ens_id is not present ensXXXX='' (empty string) - ! - ! NOTE: option=1: return "io_path/dir_name/[ensXXXX]/*.ext" - ! option=2: return "io_path/dir_name/[ensXXXX]/Yyyyy/Mmm/*.YYYYMM.ext" - ! option=3: return "io_path/dir_name/[ensXXXX]/Yyyyy/Mmm/*.YYYYpPP.ext" - ! option=4: return "io_path/dir_name/[ensXXXX]/Yyyyy/Mmm/*.YYYYMMDD.ext" - ! option=5: return "io_path/dir_name/[ensXXXX]/Yyyyy/Mmm/*.YYYYMMDD_HHMMz.ext" - ! - ! optional arguments: - ! - ! date_time date and time info (must be present unless option=1) - ! option default=5 controls date/time directories and string - ! dir_name default='cat' what type of output (eg "rs/", "rc_out/", "ana/") - ! ens_id default='' (see note above) - ! file_ext default='.bin' file name extension - ! no_subdirs default=.false. if .true., omit all sub-directories after "io_path" - ! - ! reichle, 2 Sep 2008 - overhaul for new dir and file name conventions - ! reichle, 28 Apr 2020 - added optional "no_subdirs" to facilitate writing to ./scratch - - implicit none - - character(*) :: io_path - character(*) :: exp_id, file_tag ! (eg "catch_ldas_rst") - - type(date_time_type), optional :: date_time - - integer, optional :: ens_id - integer, optional :: option - - character(*), optional :: dir_name ! default = 'cat' - character(*), optional :: file_ext ! default = '.bin' - - logical, optional :: no_subdirs ! default = .false. - - character(len=*), parameter :: Iam = 'get_io_filename' - - ! locals - - integer :: tmp_option - - character(300) :: tmp_string - character( 40) :: tmp_dir_name, tmp_file_ext, date_time_string - character( 8) :: ens_id_string - character( 4) :: YYYY, MMDD, HHMM, tmpstring4 - character( 2) :: PP - logical :: tmp_no_subdirs - - ! -------------------------------------------------------- - ! - ! initialize optional arguments - - if (present(option)) then - tmp_option = option - else - tmp_option = 5 - end if - - if (present(dir_name)) then - tmp_dir_name = dir_name - else - tmp_dir_name = 'cat' - end if - - if (present(file_ext)) then - tmp_file_ext = file_ext - else - tmp_file_ext = '.bin' - end if - - if (present(no_subdirs)) then - tmp_no_subdirs = no_subdirs - else - tmp_no_subdirs = .false. - end if - - ! create date/time strings - - if (tmp_option==1) then - - date_time_string = '' - - else - - if (present(date_time)) then - - write (YYYY,'(i4.4)') date_time%year - write (MMDD,'(i4.4)') date_time%month*100 + date_time%day - write (HHMM,'(i4.4)') date_time%hour*100 + date_time%min - - if (tmp_option==3) then - - ! determine %pentad if out of range - ! - this might happen if only %year/%month/%day were set in "date_time" - ! - if %pentad is within range, assume that %year/%month/%day and %pentad - ! are consistent and do nothing - - if (date_time%pentad<1 .or. date_time%pentad>73) call get_dofyr_pentad(date_time) - - write (PP,'(i2.2)') date_time%pentad - - end if - - else - - tmpstring300 = 'get_io_filename(): need optional argument date_time' - - if (logit) write (logunit,*) tmpstring300 - write(6,*) tmpstring300 - write(0,*) tmpstring300 - stop - - end if - - if (tmp_option==2) then - - date_time_string = '.' // YYYY // MMDD(1:2) - - elseif (tmp_option==3) then - - date_time_string = '.' // YYYY // 'p' // PP - - elseif (tmp_option==4) then - - date_time_string = '.' // YYYY // MMDD - - elseif (tmp_option==5) then - - date_time_string = '.' // YYYY // MMDD // '_' // HHMM // 'z' - - end if - - end if - - ! create ens ID string - - if (present(ens_id)) then - - if (ens_id<0) then - - ens_id_string = '.ens_avg' - - else - - write (tmpstring4,'(i4.4)') ens_id - - ens_id_string = '.ens' // tmpstring4 - - end if - - else - - ens_id_string = '' - - end if - - ! compose output path - - tmp_string = trim(io_path) // '/' - - if (.not. tmp_no_subdirs) then - - tmp_string = trim(tmp_string) // trim(tmp_dir_name) // '/' // & - trim(ens_id_string(2:8)) // '/' - - if (tmp_option>1) & - tmp_string = trim(tmp_string) // '/Y'// YYYY // '/M'//MMDD(1:2) // '/' - - end if - - ! append file name to path - - get_io_filename = trim(tmp_string) // trim(exp_id) // & - trim(ens_id_string) // '.' // trim(file_tag) // & - trim(date_time_string) // trim(tmp_file_ext) - - end function get_io_filename - - ! **************************************************************** - -! character(2) function int2char2(int_in) -! -! ! Generates a length-2 character from an integer -! -! implicit none -! -! integer :: int_in -! -! write(int2char2, '(i2.2)') int_in -! -! end function int2char2 - - ! ***************************************************************** - -! character(2) function int2char4(int_in) -! -! ! Generates a length-4 character from an integer -! -! implicit none -! -! integer :: int_in -! -! write(int2char4, '(i4.4)') int_in -! -! end function int2char4 - - ! ******************************************************************** - -! character(7) function timetag(int_day,int_hour) -! -! ! Generates a character time tag from an integer day and integer hour -! -! implicit none -! integer :: int_day, int_hour -! -! character(3) :: char_day -! character(4) :: char_hour -! -! write(char_day, '(i3.3)') int_day -! write(char_hour, '(i4.4)') int_hour -! -! timetag = char_day//char_hour -! -! return -! -! end function timetag - - ! ******************************************************************** - -! character(6) function my_date(month,year) -! -! ! Generates a character date tag from an integer year and integer month -! -! implicit none -! integer month,year -! -! character(4) :: char_year -! character(2) :: char_month -! -! write(char_year, '(i4.4)') year -! write(char_month, '(i2.2)') month -! -! my_date = char_year//char_month -! -! return -! -! end function my_date - - ! ****************************************************************** - - logical function is_in_rectangle( & - this_lon, this_lat, ll_lon, ll_lat, ur_lon, ur_lat ) - - ! determine whether point (this_lon, this_lat) is in rectangle defined by - ! ll_lon, ll_lat, ur_lon, ur_lat - - ! - reichle, 2 Aug 2011 - - implicit none - - real :: this_lon, this_lat, ll_lon, ll_lat, ur_lon, ur_lat - - if ( (this_lon >= ll_lon) .and. & - (this_lon <= ur_lon) .and. & - (this_lat >= ll_lat) .and. & - (this_lat <= ur_lat) ) then - is_in_rectangle = .true. - else - is_in_rectangle = .false. - end if - - end function is_in_rectangle - - ! ****************************************************************** - -end module LDAS_ensdrv_functions - - -! ****************************************************************** - -! driver routines for testing - -#if 0 - -program test_get_io_filename - - use date_time_util - use clsm_ensdrv_functions - - implicit none - - type(date_time_type) :: date_time - - character(300) :: io_path - character(40) :: io_run, file_tag, dir_name, file_ext - - integer :: option, ens_id - - ! --------------------------------- - - io_path = './output/ens_prop/N_AMER/run1/' - io_run = 'run1' - file_tag = 'ldas_driver_inputs' - dir_name = 'rc_out' - file_ext = '.nml' - - ens_id = 12 - - date_time%year = 1992 ! 4-digit year - date_time%month = 11 ! month in year - date_time%day = 1 ! day in month - date_time%hour = 3 ! hour of day - date_time%min = 0 ! minute of hour - date_time%sec = 0 ! seconds of minute - date_time%pentad = -9999 ! pentad of year - date_time%dofyr = -9999 ! day of year - - - call get_dofyr_pentad(date_time) - - write (*,*) get_io_filename( io_path, io_run, & - date_time, file_tag, file_ext=file_ext ) - - do option=1,7 - - - write (*,*) option, get_io_filename( io_path, io_run, & - date_time, file_tag, option=option, & - file_ext=file_ext) - - end do - -end program test_get_io_filename - -#endif - - - -! ****** EOF ******************************************************* - diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_mpi.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_mpi.F90 deleted file mode 100644 index 07cf17bd..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/LDAS_ensdrv_mpi.F90 +++ /dev/null @@ -1,954 +0,0 @@ - -! ******************************************************************************** - -! IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT - -! When a derived type is defined elsewhere in the code and then replicated -! as an MPI STRUCTURE here, make sure the original type is defined in such -! a way that it is compatible with the "-align" compiler flag. -! -! See page 106 of "MPI: A Message-Passing Interface Standard, Version 3.0", -! Message Passing Interface Forum, September 21, 2012: -! -! Structures combining different basic datatypes should be defined so that -! there will be no gaps based on alignment rules. If such a datatype is used -! to create an array of structures, users should *also* avoid an alignment-gap -! at the end of the structure. -! -! [...] -! -! Example: Instead of -! -! TYPE, BIND(C) :: my_data -! REAL, DIMENSION(3) :: x -! ! there may be a gap of the size of one REAL -! ! if the alignment of a DOUBLE PRECISION is -! ! two times the size of a REAL -! DOUBLE PRECISION :: p -! END TYPE -! -! one should define -! -! TYPE, BIND(C) :: my_data -! REAL, DIMENSION(3) :: x -! REAL :: gap1 -! DOUBLE PRECISION :: p -! END TYPE -! -! and also include gap1 in the matching MPI derived datatype. - -! IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT - -! ******************************************************************************** - -module LDAS_ensdrv_mpi - - use catch_constants, only: N_gt => CATCH_N_GT - - use catch_types, only: N_cat_progn, N_cat_diagS, N_cat_diagF - - use enkf_types, only: N_obs_ang_max - - implicit none - - include 'mpif.h' - - public :: init_MPI_types - ! initialize to non-MPI values - - integer, public :: myid=0, numprocs=1, mpicomm - integer, public :: mpierr, mpistatus(MPI_STATUS_SIZE) - - logical, public :: root_proc=.true. - - integer, public :: MPI_tile_coord_type, MPI_grid_def_type - integer, public :: MPI_cat_param_type, MPI_cat_progn_type - integer, public :: MPI_cat_diagS_type, MPI_cat_diagF_type - integer, public :: MPI_met_force_type, MPI_veg_param_type - integer, public :: MPI_bal_diagn_type, MPI_alb_param_type - integer, public :: MPI_date_time_type - integer, public :: MPI_mwRTM_param_type,MPI_obs_type, MPI_obs_param_type - integer, public :: MPI_cat_progn_int_type, MPI_cat_bias_param_type - integer, public :: MPI_obs_bias_type - - integer, private :: N_real, N_int - - -contains - - ! ***************************************************************************** - - subroutine init_MPI_types() - - integer :: icount - integer, allocatable, dimension(:) :: iblock, itype - integer(KIND=MPI_ADDRESS_KIND), allocatable, dimension(:) :: idisp - - ! --------------------------------------------------------------------- - ! - ! WARNING: do not confuse date_time_type with the f90 intrisic - ! function "date_and_time()" - ! - ! type :: date_time_type - ! integer :: year ! 4-digit year - ! integer :: month ! month in year - ! integer :: day ! day in month - ! integer :: hour ! hour of day - ! integer :: min ! minute of hour - ! integer :: sec ! seconds of minute - ! integer :: pentad ! pentad of year - ! integer :: dofyr ! day of year - ! end type date_time_type - - icount = 1 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_INTEGER - - iblock(1) = 8 - - idisp(1) = 0 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_date_time_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_date_time_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - - ! -------------------------------------------------------------------------------- - ! - ! type :: tile_coord_type - ! - ! integer :: tile_id ! unique tile ID - ! integer :: f_num ! full domain ID - ! integer :: typ ! (0=MAPL_Ocean, 100=MAPL_Land, 19=MAPL_Lake, 20=MAPL_LandIce) - ! integer :: pfaf ! Pfafstetter number (for land tiles, NOT unique) - ! real :: com_lon ! center-of-mass longitude - ! real :: com_lat ! center-of-mass latitude - ! real :: min_lon ! minimum longitude (bounding box for tile) - ! real :: max_lon ! maximum longitude (bounding box for tile) - ! real :: min_lat ! minimum latitude (bounding box for tile) - ! real :: max_lat ! maximum latitude (bounding box for tile) - ! integer :: i_indg ! i index (w.r.t. *global* grid that cuts tiles) - ! integer :: j_indg ! j index (w.r.t. *global* grid that cuts tiles) - ! ! For cubed-sphere tile spaces, pert_[x]_indg refers to a lat-lon perturbation grid that will - ! ! be created at runtime to support efficient mapping for perturbations and the EnKF analysis. - ! ! For EASE and LatLon tile spaces, pert_[x]_indg is identical to [x]_indg - ! integer :: pert_i_indg ! i index (w.r.t. *global* pert_grid for perts and EnKF) - ! integer :: pert_j_indg ! j index (w.r.t. *global* pert_grid for perts and EnKF) - ! real :: frac_cell ! area fraction of grid cell covered by tile - ! real :: frac_pfaf ! fraction of Pfafstetter catchment for land tiles - ! real :: area ! area [km^2] - ! real :: elev ! elevation above sea level [m] - - icount = 4 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_INTEGER - itype(2) = MPI_REAL - itype(3) = MPI_INTEGER - itype(4) = MPI_REAL - - iblock(1) = 4 - iblock(2) = 6 - iblock(3) = 4 ! i_indg, j_indg, pert_i_indg and pert_j_indg - iblock(4) = 4 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - idisp(3) = idisp(2) + iblock(2)*4 - idisp(4) = idisp(3) + iblock(3)*4 - - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_tile_coord_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_tile_coord_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type :: grid_def_type - ! - ! character(40) :: gridtype ! grid type, eg. "LatLon", "EASE_M36", "EASE_M09", ... - ! integer :: ind_base ! 0=zero-based indices (EASE), 1=one-based indices (LatLon) - ! integer :: i_dir ! direction of indices (+1=W-to-E, -1=E-to-W) - ! integer :: j_dir ! direction of indices (+1=S-to-N, -1=N-to-S) - ! integer :: N_lon ! number of longitude nodes - ! integer :: N_lat ! number of latitude nodes - ! integer :: i_offg ! minimum lon index (offset from global grid) - ! integer :: j_offg ! minimum lat index (offset from global grid) - ! real :: ll_lon ! lower left longitude of grid cell edge [deg] - ! real :: ll_lat ! lower left latitude of grid cell edge [deg] - ! real :: ur_lon ! upper right longitude of grid cell edge [deg] - ! real :: ur_lat ! upper right latitude of grid cell edge [deg] - ! real :: dlon ! longitude grid spacing [deg] - ! real :: dlat ! latitude grid spacing [deg] - - icount = 3 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_CHARACTER - itype(2) = MPI_INTEGER - itype(3) = MPI_REAL - - iblock(1) = 40 - iblock(2) = 7 - iblock(3) = 6 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*1 ! each character is 1 byte - idisp(3) = idisp(2) + iblock(2)*4 ! each integer is 4 bytes - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_grid_def_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_grid_def_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! type cat_param_type - ! - ! real :: dpth ! depth to bedrock from data file (dpth/=dzpr in general!) - ! real :: dzsf ! "surface layer" formerly zdep1 - ! real :: dzrz ! "root zone layer" formerly zdep2 - ! real :: dzpr ! "profile layer" (unsaturated zone) formerly zdep3 - ! real, dimension(N_gt) :: dzgt - ! real :: poros ! porosity - ! real :: cond ! saturated hydraulic conductivity - ! real :: psis ! Clapp-Hornberger parameter - ! real :: bee ! Clapp-Hornberger parameter - ! real :: wpwet ! wilting poing wetness - ! real :: gnu ! vertical decay factor for transmissivity - ! real :: vgwmax ! max amount of water available to vegetation - ! integer :: vegcls ! vegetation class - ! integer :: soilcls30 ! soil_class_top (0- 30cm) - ! integer :: soilcls100 ! soil_class_com (0-100cm) - ! real :: bf1 - ! real :: bf2 - ! real :: bf3 - ! real :: cdcr1 - ! real :: cdcr2 - ! real :: ars1 - ! real :: ars2 - ! real :: ars3 - ! real :: ara1 - ! real :: ara2 - ! real :: ara3 - ! real :: ara4 - ! real :: arw1 - ! real :: arw2 - ! real :: arw3 - ! real :: arw4 - ! real :: tsa1 - ! real :: tsa2 - ! real :: tsb1 - ! real :: tsb2 - ! real :: atau - ! real :: btau - ! real :: gravel30 - ! real :: orgC30 - ! real :: orgC - ! real :: sand30 - ! real :: clay30 - ! real :: sand - ! real :: clay - ! real :: wpwet30 - ! real :: poros30 - ! real :: veghght - - icount = 3 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_REAL - itype(2) = MPI_INTEGER - itype(3) = MPI_REAL - - iblock(1) = 4+N_gt+7 - iblock(2) = 3 - iblock(3) = 32 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - idisp(3) = idisp(2) + iblock(2)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! integer, parameter :: N_cat_progn = 10 + N_gt + 3*N_snow - ! - ! type :: cat_progn_type - ! - ! real :: tc1 ! surface/canopy temperature - ! real :: tc2 - ! real :: tc4 - ! real :: qa1 ! specific humidity in canopy air - ! real :: qa2 - ! real :: qa4 - ! real :: capac ! canopy interception water - ! real :: catdef ! catchment deficit - ! real :: rzexc ! root zone excess - ! real :: srfexc ! surface excess - ! real, dimension(N_gt) :: ght ! ground heat content - ! real, dimension(N_snow) :: wesn ! snow water equivalent - ! real, dimension(N_snow) :: htsn ! snow heat content - ! real, dimension(N_snow) :: sndz ! snow depth - - N_real = N_cat_progn - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_cat_progn MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_progn_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_progn_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! integer, parameter :: N_cat_diagS = 7 + N_gt + N_snow - ! - ! type :: cat_diagS_type - ! - ! real :: ar1 ! area fraction of saturated zone - ! real :: ar2 ! area fraction of unsaturated and unstressed zone - ! real :: asnow ! area fraction of snow - ! real :: sfmc ! surface moisture content - ! real :: rzmc ! root zone moisture content - ! real :: prmc ! profile moisture content - ! real :: tsurf ! mean surface temperature over entire catchment - ! real, dimension(N_gt) :: tp ! temperature of soil layers - ! real, dimension(N_snow) :: tpsn ! temperature of snow layers - - N_real = N_cat_diagS - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_cat_diagS MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_diagS_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_diagS_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! integer, parameter :: N_cat_diagF = 22 - ! - ! type :: cat_diagF_type - ! - ! real :: shflux ! sensible heat flux - ! real :: lhflux ! total latent heat flux - ! real :: ghflux ! ground heat flux to top soil layer - ! real :: evap ! total evaporation - ! real :: eint ! interception loss - ! real :: esoi ! evaporation from bare soil - ! real :: eveg ! transpiration - ! real :: esno ! evaporation from snow - ! real :: runoff ! total runoff - ! real :: runsrf ! surface runoff - ! real :: bflow ! baseflow - ! real :: snmelt ! snow melt - ! real :: lwup ! outgoing/upward longwave radiation - ! real :: swup ! outgoing/upward shortwave radiation - ! real :: qinfil ! infiltration - ! real :: hsnacc ! accounting term for energy related to snowfall etc. - ! real :: evacc ! accounting term for evaporation (see catchment()) - ! real :: shacc ! accounting term for sensible heat (see catchment()) - ! real :: lhacc ! accounting term for latent heat (see catchment()) - ! real :: eacc_0 ! accounting term for oscillations (see catchment()) - ! real :: t2m ! air temperature at 2m above the displacement height - ! real :: q2m ! specific humidity at 2m above the displacement height - - N_real = N_cat_diagF - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_cat_diagF MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_diagF_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_diagF_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type met_force_type - ! - ! real :: Tair ! air temperature at RefH [K] - ! real :: Qair ! specific humidity at RefH [kg/kg] - ! real :: Psurf ! surface pressure [Pa] - ! real :: Rainf_C ! convective rainfall [kg/m2/s] - ! real :: Rainf ! total rainfall [kg/m2/s] - ! real :: Snowf ! total snowfall [kg/m2/s] - ! real :: LWdown ! downward longwave radiation [W/m2] - ! real :: SWdown ! downward shortwave radiation [W/m2] - ! real :: PARdrct ! Photosynth. Active Radiation (direct) [W/m2] - ! real :: PARdffs ! Photosynth. Active Radiation (diffuse) [W/m2] - ! real :: Wind ! wind speed at RefH [m/s] - ! real :: RefH ! reference height for Tair, Qair, Wind [m] - - N_real = 12 - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_met_force MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_met_force_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_met_force_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type veg_param_type - ! - ! real :: grn ! vegetation greenness fraction [-] - ! real :: lai ! leaf-area-index [m2/m2] - - N_real = 2 - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_veg_param MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_veg_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_veg_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type bal_diagn_type - ! - ! real :: etotl ! total energy store (in all model progn) [J/m2] - ! real :: echng ! energy change per unit time (model only) [W/m2] - ! real :: eincr ! energy analysis increment per unit time [W/m2] - ! real :: wtotl ! total water store (in all model progn) [kg/m2] - ! real :: wchng ! water change per unit time (model only) [kg/m2/s] - ! real :: wincr ! water analysis increment per unit time [kg/m2/s] - - N_real = 6 - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_bal_diagn MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_bal_diagn_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_bal_diagn_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type alb_param_type - ! - ! reichle, 5 Apr 2013 - removed alb_param_type fields "sc_albvr" and "sc_albnr" - ! - ! !real :: sc_albvr ! Scaling factor for direct visible or blacksky 0.3-0.7 - ! !real :: sc_albnr ! Scaling factor for direct infrared or blacksky 0.7-5.0 - ! real :: sc_albvf ! Scaling factor for diffuse visible or whitesky 0.3-0.7 - ! real :: sc_albnf ! Scaling factor for diffuse infrared or whitesky 0.7-5.0 - - N_real = 2 - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - ! split MPI type into two blocks of real numbers - ! (having just one with N_alb_param MPI_REAL entries did not work) - - itype(1) = MPI_REAL - itype(2) = MPI_REAL - - iblock(1) = 1 - iblock(2) = N_real-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_alb_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_alb_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! -------------------------------------------------------------------------------- - ! - ! type mwRTM_param_type - ! - ! integer :: vegcls - ! integer :: soilcls - ! real :: sand - ! real :: clay - ! real :: poros - ! real :: wang_wt - ! real :: wang_wp - ! real :: rgh_hmin - ! real :: rgh_hmax - ! real :: rgh_wmin - ! real :: rgh_wmax - ! real :: rgh_Nrh - ! real :: rgh_Nrv - ! real :: rgh_polmix - ! real :: omega - ! real :: bh - ! real :: bv - ! real :: lewt - ! real :: vegopacity - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_INTEGER - itype(2) = MPI_REAL - - iblock(1) = 2 - iblock(2) = 17 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_mwRTM_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_mwRTM_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! type obs_type - ! - ! logical :: assim - ! integer :: species - ! integer :: tilenum - ! integer :: DUMMYGAP ! fill gap so that MPI STRUCT works with "-align" compiler flag - ! real*8 :: time - ! real :: lon - ! real :: lat - ! real :: obs - ! real :: obsvar - ! real :: fcst - ! real :: fcstvar - ! real :: ana - ! real :: anavar - - icount = 4 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_LOGICAL - itype(2) = MPI_INTEGER - itype(3) = MPI_REAL8 - itype(4) = MPI_REAL - - iblock(1) = 1 - iblock(2) = 3 - iblock(3) = 1 - iblock(4) = 8 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - idisp(3) = idisp(2) + iblock(2)*4 - idisp(4) = idisp(3) + iblock(3)*8 ! real*8 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_obs_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_obs_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! type obs_param_type - ! - ! character(40) :: descr ! block #1 (character) - ! integer :: species ! block #2 (integer) - ! integer :: orbit - ! integer :: pol - ! integer :: N_ang - ! real, & - ! dimension(N_obs_ang_max) :: ang ! block #3 (real) - ! real :: freq - ! real :: FOV - ! character(40) :: FOV_units ! block #4 (character) - ! logical :: assim ! block #5 (logical) - ! logical :: scale - ! logical :: getinnov - ! integer :: RTM_ID ! block #6 (integer) - ! integer :: bias_Npar - ! integer :: bias_trel - ! integer :: bias_tcut - ! real :: nodata ! block #7 (real) - ! character(40) :: varname ! block #8 (character) - ! character(40) :: units - ! character(200) :: path - ! character(80) :: name - ! character(200) :: maskpath - ! character(80) :: maskname - ! character(200) :: scalepath - ! character(80) :: scalename - ! character(200) :: flistpath - ! character(80) :: flistname - ! real :: errstd ! block #9 (real) - ! real :: std_normal_max - ! logical :: zeromean ! block #10 (logical) - ! logical :: coarsen_pert - ! real :: xcorr ! block #11 (real) - ! real :: ycorr - ! integer :: adapt ! block #12 (integer) - - icount = 12 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype( 1) = MPI_CHARACTER - itype( 2) = MPI_INTEGER - itype( 3) = MPI_REAL - itype( 4) = MPI_CHARACTER - itype( 5) = MPI_LOGICAL - itype( 6) = MPI_INTEGER - itype( 7) = MPI_REAL - itype( 8) = MPI_CHARACTER - itype( 9) = MPI_REAL - itype(10) = MPI_LOGICAL - itype(11) = MPI_REAL - itype(12) = MPI_INTEGER - - iblock( 1) = 40 - iblock( 2) = 4 - iblock( 3) = N_obs_ang_max+2 - iblock( 4) = 40 - iblock( 5) = 3 - iblock( 6) = 4 - iblock( 7) = 1 - iblock( 8) = 40+40+200+80+200+80+200+80+200+80 - iblock( 9) = 2 - iblock(10) = 2 - iblock(11) = 2 - iblock(12) = 1 - - idisp( 1) = 0 - idisp( 2) = idisp( 1) + iblock( 1) ! CHARACTER*1 !!! - idisp( 3) = idisp( 2) + iblock( 2)*4 - idisp( 4) = idisp( 3) + iblock( 3)*4 - idisp( 5) = idisp( 4) + iblock( 4) ! CHARACTER*1 !!! - idisp( 6) = idisp( 5) + iblock( 5)*4 - idisp( 7) = idisp( 6) + iblock( 6)*4 - idisp( 8) = idisp( 7) + iblock( 7)*4 - idisp( 9) = idisp( 8) + iblock( 8) ! CHARACTER*1 !!! - idisp(10) = idisp( 9) + iblock( 9)*4 - idisp(11) = idisp(10) + iblock(10)*4 - idisp(12) = idisp(11) + iblock(11)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_obs_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_obs_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - - - - !-------------------------------------------------------------------------------- - ! - ! type :: cat_progn_int_type - ! - ! integer :: tc1 ! surface/canopy temperature - ! integer :: tc2 - ! integer :: tc4 - ! integer :: qa1 ! specific humidity in canopy air - ! integer :: qa2 - ! integer :: qa4 - ! integer :: capac ! canopy interception water - ! integer :: catdef ! catchment deficit - ! integer :: rzexc ! root zone excess - ! integer :: srfexc ! surface excess - ! integer, dimension(N_gt) :: ght ! ground heat content - ! integer, dimension(N_snow) :: wesn ! snow water equivalent - ! integer, dimension(N_snow) :: htsn ! snow heat content - ! integer, dimension(N_snow) :: sndz ! snow depth - - N_int = N_cat_progn - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_INTEGER - itype(2) = MPI_INTEGER - - iblock(1) = 1 - iblock(2) = N_int-1 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_progn_int_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_progn_int_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - ! --------------------------------------------------------------------------------- - ! - ! type :: cat_bias_param_type - ! - ! type(cat_progn_type) :: tconst - ! type(cat_progn_type) :: trelax - ! type(cat_progn_int_type) :: Nparam - - N_real = 2*N_cat_progn - N_int = N_cat_progn - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_REAL - itype(2) = MPI_INTEGER - - iblock(1) = N_real - iblock(2) = N_int - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_cat_bias_param_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_cat_bias_param_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - - ! --------------------------------------------------------------------------------- - ! - ! type :: obs_bias_type - ! - ! real :: bias - ! integer, dimension(2) :: tcount - ! - - icount = 2 - - allocate(iblock(icount)) - allocate(idisp( icount)) - allocate(itype( icount)) - - itype(1) = MPI_REAL - itype(2) = MPI_INTEGER - - iblock(1) = 1 - iblock(2) = 2 - - idisp(1) = 0 - idisp(2) = idisp(1) + iblock(1)*4 - - call MPI_TYPE_CREATE_STRUCT( icount, iblock, idisp, itype, & - MPI_obs_bias_type, mpierr ) - - call MPI_TYPE_COMMIT(MPI_obs_bias_type, mpierr) - - deallocate(iblock) - deallocate(idisp) - deallocate(itype) - - - ! --------------------------------------------------------------------------------- - - end subroutine init_MPI_types - - ! ***************************************************************************** - -! subroutine mpi_call_out(my_message) -! -! character(200) :: my_message -! -! character( 8) :: date_string -! character( 10) :: time_string -! -! character( 2) :: tmpstr2 -! -! call date_and_time(date_string, time_string) -! -! write (tmpstr2,'(i2.2)') myid -! -! write (*,*) trim(my_message), ": myid ", tmpstr2, ', ', date_string, time_string -! -! end subroutine mpi_call_out - - ! ***************************************************************************** - -end module LDAS_ensdrv_mpi diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/catch_types.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/catch_types.F90 deleted file mode 100644 index d26e5521..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/catch_types.F90 +++ /dev/null @@ -1,1435 +0,0 @@ - -module catch_types - - ! definition of types and associated operators for Catchment Model - ! - ! IMPORTANT: - ! When adding a field to any of the derived types, must also update - ! the associated assignment and operator definitions. - ! THERE IS NO WARNING/ERROR IF OPERATOR IS NOT DEFINED FOR ALL FIELDS! - ! - ! reichle, 21 May 2003 - ! reichle, 25 Jan 2005 - added cat_force_type - ! reichle, 28 Oct 2010 - added soilcls30 and soilcls100 - ! reichle, 9 Dec 2011 - removed water/energy balance terms from cat_diagn - ! (now done in new "bal_diagn_type" in driver_types.F90) - ! reichle, 28 Dec 2011 - removed field totalb from cat_diagn structure - ! (now done via swup/SWdown) - ! reichle, 30 Oct 2013 - removed field rzeq from cat_diagn structure - ! reichle, 31 Oct 2013 - split "cat_diagn" structure into "cat_diagS" and "cat_diagF" - ! reichle, 16 Nov 2015 - added vegetation height - ! - ! -------------------------------------------------------------------------- - - use catch_constants, ONLY: & - N_snow => CATCH_N_SNOW, & - N_gt => CATCH_N_GT - - implicit none - - ! everything is private by default unless made public - - private - - - public :: N_cat_progn, N_cat_diagS, N_cat_diagF - public :: cat_progn_type, cat_diagS_type, cat_diagF_type - public :: cat_param_type, cat_force_type - - public :: assignment (=), operator (*), operator (/), operator (+), operator (-) - - public :: cat_diagS_sqrt, cat_diagS_max - - public :: catprogn2wesn, catprogn2htsn, catprogn2sndz, catprogn2ghtcnt - - ! ------------------------------------------------------------------------- - ! - ! N_cat_progn = total # states in Catchment model, incl. 3*N_snow states for - ! snow (water equivalent, depth, and heat content) and N_gt states for ground - ! temperature, where N_* is the number of layers. - - integer, parameter :: N_cat_progn = 10 + N_gt + 3*N_snow - - ! -------------------------------------------------------------------------- - - ! Catchment model prognostic variables - - type :: cat_progn_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! horizontally, the surface is divided into four fractions: - ! - ! "1" - saturated - ! "2" - unsaturated but not stressed - ! "4" - stressed - ! "S" - snow - ! - ! ------------------------------------------------------------ - - real :: tc1 ! surface/canopy temperature - real :: tc2 - real :: tc4 - - real :: qa1 ! specific humidity in canopy air - real :: qa2 - real :: qa4 - - real :: capac ! canopy interception water - - real :: catdef ! catchment deficit - real :: rzexc ! root zone excess - real :: srfexc ! surface excess - - real, dimension(N_gt) :: ght ! ground heat content - - real, dimension(N_snow) :: wesn ! snow water equivalent - real, dimension(N_snow) :: htsn ! snow heat content - real, dimension(N_snow) :: sndz ! snow depth - - end type cat_progn_type - - ! --------------------------------------------------------- - - ! Catchment model diagnostic variables - - ! Catchment model diagnostics are split into two groups: - ! - ! cat_diagS = diagnostic "state" variables that can be computed from prognostics - ! cat_diagF = diagnostic variables such as "fluxes" that are outputs of subroutine - ! catchment() but cannot be computed directly from prognostics only - - integer, parameter :: N_cat_diagS = 7 + N_gt + N_snow - - type :: cat_diagS_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: ar1 ! area fraction of saturated zone - real :: ar2 ! area fraction of unsaturated and unstressed zone - - real :: asnow ! area fraction of snow - - real :: sfmc ! surface moisture content - real :: rzmc ! root zone moisture content - real :: prmc ! profile moisture content - - real :: tsurf ! mean surface temperature over entire catchment - - real, dimension(N_gt) :: tp ! temperature of soil layers - - real, dimension(N_snow) :: tpsn ! temperature of snow layers - - end type cat_diagS_type - - ! -------------------------- - - integer, parameter :: N_cat_diagF = 22 - - type :: cat_diagF_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: shflux ! sensible heat flux - real :: lhflux ! total latent heat flux - real :: ghflux ! ground heat flux to top soil layer - - real :: evap ! total evaporation - real :: eint ! interception loss - real :: esoi ! evaporation from bare soil - real :: eveg ! transpiration - real :: esno ! evaporation from snow - - real :: runoff ! total runoff - real :: runsrf ! surface runoff - real :: bflow ! baseflow - - real :: snmelt ! snow melt - - real :: lwup ! outgoing/upward longwave radiation - real :: swup ! outgoing/upward shortwave radiation - - real :: qinfil ! infiltration - - real :: hsnacc ! accounting term for energy related to snowfall etc. - real :: evacc ! accounting term for evaporation (see catchment()) - real :: shacc ! accounting term for sensible heat (see catchment()) - real :: lhacc ! accounting term for latent heat (see catchment()) - real :: eacc_0 ! accounting term for oscillations (see catchment()) - - ! t2m and q2m depend on fluxes and cannot be computed from prognostics only - - real :: t2m ! air temperature at 2m above the displacement height - real :: q2m ! specific humidity at 2m above the displacement height - - end type cat_diagF_type - - ! --------------------------------------------------------- - - ! Catchment model parameters - - type :: cat_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: dpth ! depth to bedrock from data file (dpth/=dzpr in general!) [mm] - - ! layer thicknesses for soil moisture model (in [mm]!!!!) - - real :: dzsf ! "surface layer" formerly zdep1 [mm] - real :: dzrz ! "root zone layer" formerly zdep2 [mm] - real :: dzpr ! "profile layer" (unsaturated zone) formerly zdep3 [mm] - - ! layer thicknesses for ground temperature model (in [m]!!!!) - ! - ! dzgt SHOULD REPLACE data dz /.../ STATEMENT IN gndtp0 AND gndtmp - ! - real, dimension(N_gt) :: dzgt ! [m] - - ! soil hydraulic parameters - - real :: poros ! porosity [m3 m-3] - real :: cond ! saturated hydraulic conductivity [m s-1] - real :: psis ! Clapp-Hornberger parameter [m H2O] - real :: bee ! Clapp-Hornberger parameter [-] - - real :: wpwet ! wilting poing wetness [-] - - real :: gnu ! vertical decay factor for transmissivity [m-1] - - ! constant parameters related to vegetation - - real :: vgwmax ! max amount of water available to vegetation [kg m-2] - - ! veg and soil classes - - integer :: vegcls ! vegetation class [-] - integer :: soilcls30 ! soil_class_top (0- 30cm) [-] - integer :: soilcls100 ! soil_class_com (0-100cm) [-] - - ! parameters specific to Catchment Model - ! (Equation and Figure numbers refer to Ducharne et al., 2000, doi:10.1029/2000JD900328) - - real :: bf1 ! baseflow parameter (A in Eq 9) [kg m-4] - real :: bf2 ! baseflow parameter (B in Eq 9) [m] - real :: bf3 ! baseflow parameter (XBAR in Eq 8) [log(m)] - - real :: cdcr1 ! catdef threshold (water table at bedrock) [kg m-2] - real :: cdcr2 ! catdef threshold () [kg m-2] - - ! area partitioning parameters - - real :: ars1 ! A in Eq 12 for Asat [m2 kg-1] - real :: ars2 ! B in Eq 12 for Asat [m2 kg-1] - real :: ars3 ! C in Eq 12 for Asat [m4 kg-2] - real :: ara1 ! A in Eq 14 of segment1 if skew < 0.25 else ara1=ara3 [m2 kg-1] - real :: ara2 ! B in Eq 14 of segment1 if skew < 0.25 else ara2=ara4 [-] - real :: ara3 ! A in Eq 14 of segment1 if skew < 0.25 [m2 kg-1] - real :: ara4 ! B in Eq 14 of segment1 if skew < 0.25 [-] - real :: arw1 ! A in Eq 12 for THETA0 [m2 kg-1] - real :: arw2 ! B in Eq 12 for THETA0 [m2 kg-1] - real :: arw3 ! C in Eq 12 for THETA0 [m4 kg-2] - real :: arw4 ! Y_infinity in Eq 12 for THETA0 [-] - - ! time scale param for moisture transfer between root zone and water table - - real :: tsa1 ! atau1 in Eq 16 for root zone excess > 0 (Fig 6) [-] - real :: tsa2 ! atau1 in Eq 16 for root zone excess < 0 (Fig 6) [-] - real :: tsb1 ! btau1 in Eq 16 for root zone excess > 0 (Fig 6) [-] - real :: tsb2 ! btau1 in Eq 16 for root zone excess < 0 (Fig 6) [-] - - ! time scale param for moisture transfer between surface excess and root zone excess - - real :: atau ! atau2 in Eq 17 [-] - real :: btau ! btau2 in Eq 17 [-] - - ! additional soil parameters from recent versions of "soil_param.dat" - ! (eg. for use in calibration of the microwave radiative transfer model) - ! - reichle, 1 Apr 2015 - - real :: gravel30 ! gravel in 0- 30cm layer [percent by vol] - real :: orgC30 ! organic carbon in 0- 30cm layer [percent by weight] - real :: orgC ! organic carbon in 0-100cm layer [percent by weight] - real :: sand30 ! sand fraction in 0- 30cm layer [percent by weight] - real :: clay30 ! clay fraction in 0- 30cm layer [percent by weight] - real :: sand ! sand fraction in 0-100cm layer [percent by weight] - real :: clay ! clay fraction in 0-100cm layer [percent by weight] - real :: wpwet30 ! wilting point wetness in 0- 30cm layer [-] - real :: poros30 ! porosity in 0- 30cm layer [m3 m-3] - - ! static (time-invariant) vegetation parameters - - real :: veghght ! vegetation height [m] - - end type cat_param_type - - ! --------------------------------------------------------- - ! - ! input forcings (or boundary conditions) and related variables - ! - ! horizontally, the surface is divided into four fractions: - ! - ! "1" - saturated - ! "2" - unsaturated but not stressed - ! "4" - stressed - ! "S" - snow - - type :: cat_force_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - real :: TRAINC ! convective rain rate - real :: TRAINL ! large-scale rain rate - real :: TSNOW ! snowfall - real :: UM ! wind - real :: ETURB1 - real :: DEDQA1 - real :: DEDTC1 - real :: HSTURB1 - real :: DHSDQA1 - real :: DHSDTC1 - real :: ETURB2 - real :: DEDQA2 - real :: DEDTC2 - real :: HSTURB2 - real :: DHSDQA2 - real :: DHSDTC2 - real :: ETURB4 - real :: DEDQA4 - real :: DEDTC4 - real :: HSTURB4 - real :: DHSDQA4 - real :: DHSDTC4 - real :: ETURBS - real :: DEDQAS - real :: DEDTCS - real :: HSTURBS - real :: DHSDQAS - real :: DHSDTCS - real :: TM ! 2m temperature - real :: QM ! 2m humidity - real :: ra1 - real :: ra2 - real :: ra4 - real :: raS - real :: SUNANG ! sun angle - real :: PARDIR ! direct photosynthetically active radiation - real :: PARDIF ! diffuse photosynthetically active radiation - real :: SWNETF ! net shortwave radiation (?) - real :: SWNETS ! net shortwave radiation (?) - real :: HLWDWN ! downward longwave radiation - real :: PSUR ! surface pressure - real :: ZLAI ! leaf area index - real :: GREEN ! greenness - real :: Z2 - real :: SQSCAT - real :: RSOIL1 - real :: RSOIL2 - real :: RDC - real :: QSAT1 - real :: DQS1 - real :: ALW1 - real :: BLW1 - real :: QSAT2 - real :: DQS2 - real :: ALW2 - real :: BLW2 - real :: QSAT4 - real :: DQS4 - real :: ALW4 - real :: BLW4 - real :: QSATS - real :: DQSS - real :: ALWS - real :: BLWS - - end type cat_force_type - - ! ---------------------------------------------------------------- - - interface assignment (=) - module procedure scalar2cat_progn - module procedure scalar2cat_diagS - module procedure scalar2cat_diagF - module procedure scalar2cat_param - module procedure scalar2cat_force - end interface - - interface operator (*) - module procedure scalar_mult_cat_diagS - module procedure scalar_mult_cat_diagF - module procedure cat_diagS_mult_cat_diagS - end interface - - interface operator (/) - module procedure cat_progn_div_scalar - module procedure cat_diagS_div_scalar - module procedure cat_diagF_div_scalar - module procedure cat_force_div_scalar - end interface - - interface operator (+) - module procedure add_cat_progn - module procedure add_cat_diagS - module procedure add_cat_diagF - module procedure add_cat_force - end interface - - interface operator (-) - module procedure subtract_cat_diagS - module procedure subtract_cat_diagF - end interface - - ! ---------------------------------------------------------------- - -contains - - subroutine scalar2cat_diagS( cat_diagS, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(cat_diagS_type), intent(out) :: cat_diagS - - integer :: i ! local - - cat_diagS%ar1 = scalar - cat_diagS%ar2 = scalar - - cat_diagS%asnow = scalar - - cat_diagS%sfmc = scalar - cat_diagS%rzmc = scalar - cat_diagS%prmc = scalar - - cat_diagS%tsurf = scalar - - do i=1,N_gt - cat_diagS%tp(i) = scalar - end do - - do i=1,N_snow - cat_diagS%tpsn(i)= scalar - end do - - end subroutine scalar2cat_diagS - - ! ----------------------------------------------------------- - - subroutine scalar2cat_diagF( cat_diagF, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(cat_diagF_type), intent(out) :: cat_diagF - - cat_diagF%shflux = scalar - cat_diagF%lhflux = scalar - cat_diagF%ghflux = scalar - - cat_diagF%evap = scalar - cat_diagF%eint = scalar - cat_diagF%esoi = scalar - cat_diagF%eveg = scalar - cat_diagF%esno = scalar - - cat_diagF%runoff = scalar - cat_diagF%runsrf = scalar - cat_diagF%bflow = scalar - - cat_diagF%snmelt = scalar - - cat_diagF%lwup = scalar - cat_diagF%swup = scalar - - cat_diagF%qinfil = scalar - - cat_diagF%hsnacc = scalar - cat_diagF%evacc = scalar - cat_diagF%shacc = scalar - cat_diagF%lhacc = scalar - cat_diagF%eacc_0 = scalar - - cat_diagF%t2m = scalar - cat_diagF%q2m = scalar - - end subroutine scalar2cat_diagF - - ! ----------------------------------------------------------- - - function scalar_mult_cat_diagS( scalar, cat_diagS ) - - implicit none - - type(cat_diagS_type) :: scalar_mult_cat_diagS - type(cat_diagS_type), intent(in) :: cat_diagS - - real, intent(in) :: scalar - - integer :: i ! local - - scalar_mult_cat_diagS%ar1 = scalar * cat_diagS%ar1 - scalar_mult_cat_diagS%ar2 = scalar * cat_diagS%ar2 - - scalar_mult_cat_diagS%asnow = scalar * cat_diagS%asnow - - scalar_mult_cat_diagS%sfmc = scalar * cat_diagS%sfmc - scalar_mult_cat_diagS%rzmc = scalar * cat_diagS%rzmc - scalar_mult_cat_diagS%prmc = scalar * cat_diagS%prmc - - scalar_mult_cat_diagS%tsurf = scalar * cat_diagS%tsurf - - do i=1,N_gt - scalar_mult_cat_diagS%tp(i) = scalar * cat_diagS%tp(i) - end do - - do i=1,N_snow - scalar_mult_cat_diagS%tpsn(i) = scalar * cat_diagS%tpsn(i) - end do - - end function scalar_mult_cat_diagS - - ! ----------------------------------------------------------- - - function cat_diagS_mult_cat_diagS( cat_diagS_1, cat_diagS_2 ) - - implicit none - - type(cat_diagS_type) :: cat_diagS_mult_cat_diagS - type(cat_diagS_type), intent(in) :: cat_diagS_1, cat_diagS_2 - - integer :: i ! local - - cat_diagS_mult_cat_diagS%ar1 = cat_diagS_1%ar1 * cat_diagS_2%ar1 - cat_diagS_mult_cat_diagS%ar2 = cat_diagS_1%ar2 * cat_diagS_2%ar2 - - cat_diagS_mult_cat_diagS%asnow = cat_diagS_1%asnow * cat_diagS_2%asnow - - cat_diagS_mult_cat_diagS%sfmc = cat_diagS_1%sfmc * cat_diagS_2%sfmc - cat_diagS_mult_cat_diagS%rzmc = cat_diagS_1%rzmc * cat_diagS_2%rzmc - cat_diagS_mult_cat_diagS%prmc = cat_diagS_1%prmc * cat_diagS_2%prmc - - cat_diagS_mult_cat_diagS%tsurf = cat_diagS_1%tsurf * cat_diagS_2%tsurf - - do i=1,N_gt - cat_diagS_mult_cat_diagS%tp(i) = cat_diagS_1%tp(i) * cat_diagS_2%tp(i) - end do - - do i=1,N_snow - cat_diagS_mult_cat_diagS%tpsn(i) = cat_diagS_1%tpsn(i) * cat_diagS_2%tpsn(i) - end do - - end function cat_diagS_mult_cat_diagS - - ! ----------------------------------------------------------- - - function scalar_mult_cat_diagF( scalar, cat_diagF ) - - implicit none - - type(cat_diagF_type) :: scalar_mult_cat_diagF - type(cat_diagF_type), intent(in) :: cat_diagF - - real, intent(in) :: scalar - - scalar_mult_cat_diagF%shflux = scalar * cat_diagF%shflux - scalar_mult_cat_diagF%lhflux = scalar * cat_diagF%lhflux - scalar_mult_cat_diagF%ghflux = scalar * cat_diagF%ghflux - - scalar_mult_cat_diagF%evap = scalar * cat_diagF%evap - scalar_mult_cat_diagF%eint = scalar * cat_diagF%eint - scalar_mult_cat_diagF%esoi = scalar * cat_diagF%esoi - scalar_mult_cat_diagF%eveg = scalar * cat_diagF%eveg - scalar_mult_cat_diagF%esno = scalar * cat_diagF%esno - - - scalar_mult_cat_diagF%runoff = scalar * cat_diagF%runoff - scalar_mult_cat_diagF%runsrf = scalar * cat_diagF%runsrf - scalar_mult_cat_diagF%bflow = scalar * cat_diagF%bflow - - scalar_mult_cat_diagF%snmelt = scalar * cat_diagF%snmelt - - scalar_mult_cat_diagF%lwup = scalar * cat_diagF%lwup - scalar_mult_cat_diagF%swup = scalar * cat_diagF%swup - - scalar_mult_cat_diagF%qinfil = scalar * cat_diagF%qinfil - - scalar_mult_cat_diagF%hsnacc = scalar * cat_diagF%hsnacc - scalar_mult_cat_diagF%evacc = scalar * cat_diagF%evacc - scalar_mult_cat_diagF%shacc = scalar * cat_diagF%shacc - scalar_mult_cat_diagF%lhacc = scalar * cat_diagF%lhacc - scalar_mult_cat_diagF%eacc_0 = scalar * cat_diagF%eacc_0 - - scalar_mult_cat_diagF%t2m = scalar * cat_diagF%t2m - scalar_mult_cat_diagF%q2m = scalar * cat_diagF%q2m - - - end function scalar_mult_cat_diagF - - ! ----------------------------------------------------------- - - function cat_diagS_div_scalar( cat_diagS, scalar ) - - implicit none - - type(cat_diagS_type) :: cat_diagS_div_scalar - type(cat_diagS_type), intent(in) :: cat_diagS - - real, intent(in) :: scalar - - integer :: i ! local - - cat_diagS_div_scalar%ar1 = cat_diagS%ar1 / scalar - cat_diagS_div_scalar%ar2 = cat_diagS%ar2 / scalar - - cat_diagS_div_scalar%asnow = cat_diagS%asnow / scalar - - cat_diagS_div_scalar%sfmc = cat_diagS%sfmc / scalar - cat_diagS_div_scalar%rzmc = cat_diagS%rzmc / scalar - cat_diagS_div_scalar%prmc = cat_diagS%prmc / scalar - - cat_diagS_div_scalar%tsurf = cat_diagS%tsurf / scalar - - do i=1,N_gt - cat_diagS_div_scalar%tp(i) = cat_diagS%tp(i) / scalar - end do - - do i=1,N_snow - cat_diagS_div_scalar%tpsn(i) = cat_diagS%tpsn(i)/ scalar - end do - - end function cat_diagS_div_scalar - - ! ----------------------------------------------------------- - - function cat_diagF_div_scalar( cat_diagF, scalar ) - - implicit none - - type(cat_diagF_type) :: cat_diagF_div_scalar - type(cat_diagF_type), intent(in) :: cat_diagF - - real, intent(in) :: scalar - - cat_diagF_div_scalar%shflux = cat_diagF%shflux / scalar - cat_diagF_div_scalar%lhflux = cat_diagF%lhflux / scalar - cat_diagF_div_scalar%ghflux = cat_diagF%ghflux / scalar - - cat_diagF_div_scalar%evap = cat_diagF%evap / scalar - cat_diagF_div_scalar%eint = cat_diagF%eint / scalar - cat_diagF_div_scalar%esoi = cat_diagF%esoi / scalar - cat_diagF_div_scalar%eveg = cat_diagF%eveg / scalar - cat_diagF_div_scalar%esno = cat_diagF%esno / scalar - - - cat_diagF_div_scalar%runoff = cat_diagF%runoff / scalar - cat_diagF_div_scalar%runsrf = cat_diagF%runsrf / scalar - cat_diagF_div_scalar%bflow = cat_diagF%bflow / scalar - - cat_diagF_div_scalar%snmelt = cat_diagF%snmelt / scalar - - cat_diagF_div_scalar%lwup = cat_diagF%lwup / scalar - cat_diagF_div_scalar%swup = cat_diagF%swup / scalar - - cat_diagF_div_scalar%qinfil = cat_diagF%qinfil / scalar - - cat_diagF_div_scalar%hsnacc = cat_diagF%hsnacc / scalar - cat_diagF_div_scalar%evacc = cat_diagF%evacc / scalar - cat_diagF_div_scalar%shacc = cat_diagF%shacc / scalar - cat_diagF_div_scalar%lhacc = cat_diagF%lhacc / scalar - cat_diagF_div_scalar%eacc_0 = cat_diagF%eacc_0 / scalar - - cat_diagF_div_scalar%t2m = cat_diagF%t2m / scalar - cat_diagF_div_scalar%q2m = cat_diagF%q2m / scalar - - - end function cat_diagF_div_scalar - - ! ----------------------------------------------------------- - - function add_cat_diagS( cat_diagS_1, cat_diagS_2 ) - - implicit none - - type(cat_diagS_type) :: add_cat_diagS - type(cat_diagS_type), intent(in) :: cat_diagS_1, cat_diagS_2 - - integer :: i ! local - - add_cat_diagS%ar1 = cat_diagS_1%ar1 + cat_diagS_2%ar1 - add_cat_diagS%ar2 = cat_diagS_1%ar2 + cat_diagS_2%ar2 - - add_cat_diagS%asnow = cat_diagS_1%asnow + cat_diagS_2%asnow - - add_cat_diagS%sfmc = cat_diagS_1%sfmc + cat_diagS_2%sfmc - add_cat_diagS%rzmc = cat_diagS_1%rzmc + cat_diagS_2%rzmc - add_cat_diagS%prmc = cat_diagS_1%prmc + cat_diagS_2%prmc - - add_cat_diagS%tsurf = cat_diagS_1%tsurf + cat_diagS_2%tsurf - - do i=1,N_gt - add_cat_diagS%tp(i) = cat_diagS_1%tp(i) + cat_diagS_2%tp(i) - end do - - do i=1,N_snow - add_cat_diagS%tpsn(i)= cat_diagS_1%tpsn(i)+ cat_diagS_2%tpsn(i) - end do - - end function add_cat_diagS - - ! ----------------------------------------------------------- - - function add_cat_diagF( cat_diagF_1, cat_diagF_2 ) - - implicit none - - type(cat_diagF_type) :: add_cat_diagF - type(cat_diagF_type), intent(in) :: cat_diagF_1, cat_diagF_2 - - add_cat_diagF%shflux = cat_diagF_1%shflux + cat_diagF_2%shflux - add_cat_diagF%lhflux = cat_diagF_1%lhflux + cat_diagF_2%lhflux - add_cat_diagF%ghflux = cat_diagF_1%ghflux + cat_diagF_2%ghflux - - add_cat_diagF%evap = cat_diagF_1%evap + cat_diagF_2%evap - add_cat_diagF%eint = cat_diagF_1%eint + cat_diagF_2%eint - add_cat_diagF%esoi = cat_diagF_1%esoi + cat_diagF_2%esoi - add_cat_diagF%eveg = cat_diagF_1%eveg + cat_diagF_2%eveg - add_cat_diagF%esno = cat_diagF_1%esno + cat_diagF_2%esno - - add_cat_diagF%runoff = cat_diagF_1%runoff + cat_diagF_2%runoff - add_cat_diagF%runsrf = cat_diagF_1%runsrf + cat_diagF_2%runsrf - add_cat_diagF%bflow = cat_diagF_1%bflow + cat_diagF_2%bflow - - add_cat_diagF%snmelt = cat_diagF_1%snmelt + cat_diagF_2%snmelt - - add_cat_diagF%lwup = cat_diagF_1%lwup + cat_diagF_2%lwup - add_cat_diagF%swup = cat_diagF_1%swup + cat_diagF_2%swup - - add_cat_diagF%qinfil = cat_diagF_1%qinfil + cat_diagF_2%qinfil - - add_cat_diagF%hsnacc = cat_diagF_1%hsnacc + cat_diagF_2%hsnacc - add_cat_diagF%evacc = cat_diagF_1%evacc + cat_diagF_2%evacc - add_cat_diagF%shacc = cat_diagF_1%shacc + cat_diagF_2%shacc - add_cat_diagF%lhacc = cat_diagF_1%lhacc + cat_diagF_2%lhacc - add_cat_diagF%eacc_0 = cat_diagF_1%eacc_0 + cat_diagF_2%eacc_0 - - add_cat_diagF%t2m = cat_diagF_1%t2m + cat_diagF_2%t2m - add_cat_diagF%q2m = cat_diagF_1%q2m + cat_diagF_2%q2m - - - end function add_cat_diagF - - ! ----------------------------------------------------------- - - function subtract_cat_diagS( cat_diagS_1, cat_diagS_2 ) - - implicit none - - type(cat_diagS_type) :: subtract_cat_diagS - type(cat_diagS_type), intent(in) :: cat_diagS_1, cat_diagS_2 - - integer :: i ! local - - subtract_cat_diagS%ar1 = cat_diagS_1%ar1 - cat_diagS_2%ar1 - subtract_cat_diagS%ar2 = cat_diagS_1%ar2 - cat_diagS_2%ar2 - - subtract_cat_diagS%asnow = cat_diagS_1%asnow - cat_diagS_2%asnow - - subtract_cat_diagS%sfmc = cat_diagS_1%sfmc - cat_diagS_2%sfmc - subtract_cat_diagS%rzmc = cat_diagS_1%rzmc - cat_diagS_2%rzmc - subtract_cat_diagS%prmc = cat_diagS_1%prmc - cat_diagS_2%prmc - - subtract_cat_diagS%tsurf = cat_diagS_1%tsurf - cat_diagS_2%tsurf - - do i=1,N_gt - subtract_cat_diagS%tp(i) = cat_diagS_1%tp(i) - cat_diagS_2%tp(i) - end do - - do i=1,N_snow - subtract_cat_diagS%tpsn(i) = cat_diagS_1%tpsn(i) - cat_diagS_2%tpsn(i) - end do - - end function subtract_cat_diagS - - ! ----------------------------------------------------------- - - function subtract_cat_diagF( cat_diagF_1, cat_diagF_2 ) - - implicit none - - type(cat_diagF_type) :: subtract_cat_diagF - type(cat_diagF_type), intent(in) :: cat_diagF_1, cat_diagF_2 - - subtract_cat_diagF%shflux = cat_diagF_1%shflux - cat_diagF_2%shflux - subtract_cat_diagF%lhflux = cat_diagF_1%lhflux - cat_diagF_2%lhflux - subtract_cat_diagF%ghflux = cat_diagF_1%ghflux - cat_diagF_2%ghflux - - subtract_cat_diagF%evap = cat_diagF_1%evap - cat_diagF_2%evap - subtract_cat_diagF%eint = cat_diagF_1%eint - cat_diagF_2%eint - subtract_cat_diagF%esoi = cat_diagF_1%esoi - cat_diagF_2%esoi - subtract_cat_diagF%eveg = cat_diagF_1%eveg - cat_diagF_2%eveg - subtract_cat_diagF%esno = cat_diagF_1%esno - cat_diagF_2%esno - - subtract_cat_diagF%runoff = cat_diagF_1%runoff - cat_diagF_2%runoff - subtract_cat_diagF%runsrf = cat_diagF_1%runsrf - cat_diagF_2%runsrf - subtract_cat_diagF%bflow = cat_diagF_1%bflow - cat_diagF_2%bflow - - subtract_cat_diagF%snmelt = cat_diagF_1%snmelt - cat_diagF_2%snmelt - - subtract_cat_diagF%lwup = cat_diagF_1%lwup - cat_diagF_2%lwup - subtract_cat_diagF%swup = cat_diagF_1%swup - cat_diagF_2%swup - - subtract_cat_diagF%qinfil = cat_diagF_1%qinfil - cat_diagF_2%qinfil - - subtract_cat_diagF%hsnacc = cat_diagF_1%hsnacc - cat_diagF_2%hsnacc - subtract_cat_diagF%evacc = cat_diagF_1%evacc - cat_diagF_2%evacc - subtract_cat_diagF%shacc = cat_diagF_1%shacc - cat_diagF_2%shacc - subtract_cat_diagF%lhacc = cat_diagF_1%lhacc - cat_diagF_2%lhacc - subtract_cat_diagF%eacc_0 = cat_diagF_1%eacc_0 - cat_diagF_2%eacc_0 - - subtract_cat_diagF%t2m = cat_diagF_1%t2m - cat_diagF_2%t2m - subtract_cat_diagF%q2m = cat_diagF_1%q2m - cat_diagF_2%q2m - - - end function subtract_cat_diagF - - ! ----------------------------------------------------------- - - function cat_diagS_sqrt( cat_diagS ) - - implicit none - - type(cat_diagS_type) :: cat_diagS_sqrt - type(cat_diagS_type), intent(in) :: cat_diagS - - integer :: i ! local - - cat_diagS_sqrt%ar1 = sqrt( cat_diagS%ar1 ) - cat_diagS_sqrt%ar2 = sqrt( cat_diagS%ar2 ) - - cat_diagS_sqrt%asnow = sqrt( cat_diagS%asnow ) - - cat_diagS_sqrt%sfmc = sqrt( cat_diagS%sfmc ) - cat_diagS_sqrt%rzmc = sqrt( cat_diagS%rzmc ) - cat_diagS_sqrt%prmc = sqrt( cat_diagS%prmc ) - - cat_diagS_sqrt%tsurf = sqrt( cat_diagS%tsurf ) - - do i=1,N_gt - cat_diagS_sqrt%tp(i) = sqrt( cat_diagS%tp(i) ) - end do - - do i=1,N_snow - cat_diagS_sqrt%tpsn(i) = sqrt( cat_diagS%tpsn(i) ) - end do - - end function cat_diagS_sqrt - - ! ******************************************************************* - - subroutine scalar2cat_progn( cat_progn, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(cat_progn_type), intent(out) :: cat_progn - - integer :: i ! local - - cat_progn%tc1 = scalar - cat_progn%tc2 = scalar - cat_progn%tc4 = scalar - cat_progn%qa1 = scalar - cat_progn%qa2 = scalar - cat_progn%qa4 = scalar - cat_progn%capac = scalar - cat_progn%catdef = scalar - cat_progn%rzexc = scalar - cat_progn%srfexc = scalar - - do i=1,N_gt - cat_progn%ght(i) = scalar - end do - - do i=1,N_snow - cat_progn%wesn(i) = scalar - cat_progn%htsn(i) = scalar - cat_progn%sndz(i) = scalar - end do - - end subroutine scalar2cat_progn - - ! --------------------------------------------------- - - function cat_progn_div_scalar( cat_progn, scalar ) - - implicit none - - type(cat_progn_type) :: cat_progn_div_scalar - type(cat_progn_type), intent(in) :: cat_progn - - real, intent(in) :: scalar - - integer :: i ! local - - cat_progn_div_scalar%tc1 = cat_progn%tc1 / scalar - cat_progn_div_scalar%tc2 = cat_progn%tc2 / scalar - cat_progn_div_scalar%tc4 = cat_progn%tc4 / scalar - cat_progn_div_scalar%qa1 = cat_progn%qa1 / scalar - cat_progn_div_scalar%qa2 = cat_progn%qa2 / scalar - cat_progn_div_scalar%qa4 = cat_progn%qa4 / scalar - cat_progn_div_scalar%capac = cat_progn%capac / scalar - cat_progn_div_scalar%catdef = cat_progn%catdef / scalar - cat_progn_div_scalar%rzexc = cat_progn%rzexc / scalar - cat_progn_div_scalar%srfexc = cat_progn%srfexc / scalar - - do i=1,N_gt - cat_progn_div_scalar%ght(i) = cat_progn%ght(i) / scalar - end do - - do i=1,N_snow - cat_progn_div_scalar%wesn(i) = cat_progn%wesn(i) / scalar - cat_progn_div_scalar%htsn(i) = cat_progn%htsn(i) / scalar - cat_progn_div_scalar%sndz(i) = cat_progn%sndz(i) / scalar - end do - - end function cat_progn_div_scalar - - ! ----------------------------------------------------------- - - function add_cat_progn( cat_progn_1, cat_progn_2 ) - - implicit none - - type(cat_progn_type) :: add_cat_progn - type(cat_progn_type), intent(in) :: cat_progn_1, cat_progn_2 - - integer :: i ! local - - add_cat_progn%tc1 = cat_progn_1%tc1 + cat_progn_2%tc1 - add_cat_progn%tc2 = cat_progn_1%tc2 + cat_progn_2%tc2 - add_cat_progn%tc4 = cat_progn_1%tc4 + cat_progn_2%tc4 - add_cat_progn%qa1 = cat_progn_1%qa1 + cat_progn_2%qa1 - add_cat_progn%qa2 = cat_progn_1%qa2 + cat_progn_2%qa2 - add_cat_progn%qa4 = cat_progn_1%qa4 + cat_progn_2%qa4 - add_cat_progn%capac = cat_progn_1%capac + cat_progn_2%capac - add_cat_progn%catdef = cat_progn_1%catdef + cat_progn_2%catdef - add_cat_progn%rzexc = cat_progn_1%rzexc + cat_progn_2%rzexc - add_cat_progn%srfexc = cat_progn_1%srfexc + cat_progn_2%srfexc - - do i=1,N_gt - add_cat_progn%ght(i) = cat_progn_1%ght(i) + cat_progn_2%ght(i) - end do - - do i=1,N_snow - add_cat_progn%wesn(i) = cat_progn_1%wesn(i) + cat_progn_2%wesn(i) - add_cat_progn%htsn(i) = cat_progn_1%htsn(i) + cat_progn_2%htsn(i) - add_cat_progn%sndz(i) = cat_progn_1%sndz(i) + cat_progn_2%sndz(i) - end do - - - end function add_cat_progn - - ! **************************************************** - - subroutine scalar2cat_force( cat_force, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(cat_force_type), intent(out) :: cat_force - - cat_force%TRAINC = scalar - cat_force%TRAINL = scalar - cat_force%TSNOW = scalar - cat_force%UM = scalar - cat_force%ETURB1 = scalar - cat_force%DEDQA1 = scalar - cat_force%DEDTC1 = scalar - cat_force%HSTURB1 = scalar - cat_force%DHSDQA1 = scalar - cat_force%DHSDTC1 = scalar - cat_force%ETURB2 = scalar - cat_force%DEDQA2 = scalar - cat_force%DEDTC2 = scalar - cat_force%HSTURB2 = scalar - cat_force%DHSDQA2 = scalar - cat_force%DHSDTC2 = scalar - cat_force%ETURB4 = scalar - cat_force%DEDQA4 = scalar - cat_force%DEDTC4 = scalar - cat_force%HSTURB4 = scalar - cat_force%DHSDQA4 = scalar - cat_force%DHSDTC4 = scalar - cat_force%ETURBS = scalar - cat_force%DEDQAS = scalar - cat_force%DEDTCS = scalar - cat_force%HSTURBS = scalar - cat_force%DHSDQAS = scalar - cat_force%DHSDTCS = scalar - cat_force%TM = scalar - cat_force%QM = scalar - cat_force%ra1 = scalar - cat_force%ra2 = scalar - cat_force%ra4 = scalar - cat_force%raS = scalar - cat_force%SUNANG = scalar - cat_force%PARDIR = scalar - cat_force%PARDIF = scalar - cat_force%SWNETF = scalar - cat_force%SWNETS = scalar - cat_force%HLWDWN = scalar - cat_force%PSUR = scalar - cat_force%ZLAI = scalar - cat_force%GREEN = scalar - cat_force%Z2 = scalar - cat_force%SQSCAT = scalar - cat_force%RSOIL1 = scalar - cat_force%RSOIL2 = scalar - cat_force%RDC = scalar - cat_force%QSAT1 = scalar - cat_force%DQS1 = scalar - cat_force%ALW1 = scalar - cat_force%BLW1 = scalar - cat_force%QSAT2 = scalar - cat_force%DQS2 = scalar - cat_force%ALW2 = scalar - cat_force%BLW2 = scalar - cat_force%QSAT4 = scalar - cat_force%DQS4 = scalar - cat_force%ALW4 = scalar - cat_force%BLW4 = scalar - cat_force%QSATS = scalar - cat_force%DQSS = scalar - cat_force%ALWS = scalar - cat_force%BLWS = scalar - - end subroutine scalar2cat_force - - ! ------------------------------------------------------------- - - function cat_force_div_scalar( cat_force, scalar ) - - implicit none - - type(cat_force_type) :: cat_force_div_scalar - type(cat_force_type), intent(in) :: cat_force - - real, intent(in) :: scalar - - cat_force_div_scalar%TRAINC = cat_force%TRAINC / scalar - cat_force_div_scalar%TRAINL = cat_force%TRAINL / scalar - cat_force_div_scalar%TSNOW = cat_force%TSNOW / scalar - cat_force_div_scalar%UM = cat_force%UM / scalar - cat_force_div_scalar%ETURB1 = cat_force%ETURB1 / scalar - cat_force_div_scalar%DEDQA1 = cat_force%DEDQA1 / scalar - cat_force_div_scalar%DEDTC1 = cat_force%DEDTC1 / scalar - cat_force_div_scalar%HSTURB1 = cat_force%HSTURB1 / scalar - cat_force_div_scalar%DHSDQA1 = cat_force%DHSDQA1 / scalar - cat_force_div_scalar%DHSDTC1 = cat_force%DHSDTC1 / scalar - cat_force_div_scalar%ETURB2 = cat_force%ETURB2 / scalar - cat_force_div_scalar%DEDQA2 = cat_force%DEDQA2 / scalar - cat_force_div_scalar%DEDTC2 = cat_force%DEDTC2 / scalar - cat_force_div_scalar%HSTURB2 = cat_force%HSTURB2 / scalar - cat_force_div_scalar%DHSDQA2 = cat_force%DHSDQA2 / scalar - cat_force_div_scalar%DHSDTC2 = cat_force%DHSDTC2 / scalar - cat_force_div_scalar%ETURB4 = cat_force%ETURB4 / scalar - cat_force_div_scalar%DEDQA4 = cat_force%DEDQA4 / scalar - cat_force_div_scalar%DEDTC4 = cat_force%DEDTC4 / scalar - cat_force_div_scalar%HSTURB4 = cat_force%HSTURB4 / scalar - cat_force_div_scalar%DHSDQA4 = cat_force%DHSDQA4 / scalar - cat_force_div_scalar%DHSDTC4 = cat_force%DHSDTC4 / scalar - cat_force_div_scalar%ETURBS = cat_force%ETURBS / scalar - cat_force_div_scalar%DEDQAS = cat_force%DEDQAS / scalar - cat_force_div_scalar%DEDTCS = cat_force%DEDTCS / scalar - cat_force_div_scalar%HSTURBS = cat_force%HSTURBS / scalar - cat_force_div_scalar%DHSDQAS = cat_force%DHSDQAS / scalar - cat_force_div_scalar%DHSDTCS = cat_force%DHSDTCS / scalar - cat_force_div_scalar%TM = cat_force%TM / scalar - cat_force_div_scalar%QM = cat_force%QM / scalar - cat_force_div_scalar%ra1 = cat_force%ra1 / scalar - cat_force_div_scalar%ra2 = cat_force%ra2 / scalar - cat_force_div_scalar%ra4 = cat_force%ra4 / scalar - cat_force_div_scalar%raS = cat_force%raS / scalar - cat_force_div_scalar%SUNANG = cat_force%SUNANG / scalar - cat_force_div_scalar%PARDIR = cat_force%PARDIR / scalar - cat_force_div_scalar%PARDIF = cat_force%PARDIF / scalar - cat_force_div_scalar%SWNETF = cat_force%SWNETF / scalar - cat_force_div_scalar%SWNETS = cat_force%SWNETS / scalar - cat_force_div_scalar%HLWDWN = cat_force%HLWDWN / scalar - cat_force_div_scalar%PSUR = cat_force%PSUR / scalar - cat_force_div_scalar%ZLAI = cat_force%ZLAI / scalar - cat_force_div_scalar%GREEN = cat_force%GREEN / scalar - cat_force_div_scalar%Z2 = cat_force%Z2 / scalar - cat_force_div_scalar%SQSCAT = cat_force%SQSCAT / scalar - cat_force_div_scalar%RSOIL1 = cat_force%RSOIL1 / scalar - cat_force_div_scalar%RSOIL2 = cat_force%RSOIL2 / scalar - cat_force_div_scalar%RDC = cat_force%RDC / scalar - cat_force_div_scalar%QSAT1 = cat_force%QSAT1 / scalar - cat_force_div_scalar%DQS1 = cat_force%DQS1 / scalar - cat_force_div_scalar%ALW1 = cat_force%ALW1 / scalar - cat_force_div_scalar%BLW1 = cat_force%BLW1 / scalar - cat_force_div_scalar%QSAT2 = cat_force%QSAT2 / scalar - cat_force_div_scalar%DQS2 = cat_force%DQS2 / scalar - cat_force_div_scalar%ALW2 = cat_force%ALW2 / scalar - cat_force_div_scalar%BLW2 = cat_force%BLW2 / scalar - cat_force_div_scalar%QSAT4 = cat_force%QSAT4 / scalar - cat_force_div_scalar%DQS4 = cat_force%DQS4 / scalar - cat_force_div_scalar%ALW4 = cat_force%ALW4 / scalar - cat_force_div_scalar%BLW4 = cat_force%BLW4 / scalar - cat_force_div_scalar%QSATS = cat_force%QSATS / scalar - cat_force_div_scalar%DQSS = cat_force%DQSS / scalar - cat_force_div_scalar%ALWS = cat_force%ALWS / scalar - cat_force_div_scalar%BLWS = cat_force%BLWS / scalar - - end function cat_force_div_scalar - - ! ----------------------------------------------------------- - - function add_cat_force( cat_force_1, cat_force_2 ) - - implicit none - - type(cat_force_type) :: add_cat_force - type(cat_force_type), intent(in) :: cat_force_1, cat_force_2 - - add_cat_force%TRAINC = cat_force_1%TRAINC + cat_force_2%TRAINC - add_cat_force%TRAINL = cat_force_1%TRAINL + cat_force_2%TRAINL - add_cat_force%TSNOW = cat_force_1%TSNOW + cat_force_2%TSNOW - add_cat_force%UM = cat_force_1%UM + cat_force_2%UM - add_cat_force%ETURB1 = cat_force_1%ETURB1 + cat_force_2%ETURB1 - add_cat_force%DEDQA1 = cat_force_1%DEDQA1 + cat_force_2%DEDQA1 - add_cat_force%DEDTC1 = cat_force_1%DEDTC1 + cat_force_2%DEDTC1 - add_cat_force%HSTURB1 = cat_force_1%HSTURB1 + cat_force_2%HSTURB1 - add_cat_force%DHSDQA1 = cat_force_1%DHSDQA1 + cat_force_2%DHSDQA1 - add_cat_force%DHSDTC1 = cat_force_1%DHSDTC1 + cat_force_2%DHSDTC1 - add_cat_force%ETURB2 = cat_force_1%ETURB2 + cat_force_2%ETURB2 - add_cat_force%DEDQA2 = cat_force_1%DEDQA2 + cat_force_2%DEDQA2 - add_cat_force%DEDTC2 = cat_force_1%DEDTC2 + cat_force_2%DEDTC2 - add_cat_force%HSTURB2 = cat_force_1%HSTURB2 + cat_force_2%HSTURB2 - add_cat_force%DHSDQA2 = cat_force_1%DHSDQA2 + cat_force_2%DHSDQA2 - add_cat_force%DHSDTC2 = cat_force_1%DHSDTC2 + cat_force_2%DHSDTC2 - add_cat_force%ETURB4 = cat_force_1%ETURB4 + cat_force_2%ETURB4 - add_cat_force%DEDQA4 = cat_force_1%DEDQA4 + cat_force_2%DEDQA4 - add_cat_force%DEDTC4 = cat_force_1%DEDTC4 + cat_force_2%DEDTC4 - add_cat_force%HSTURB4 = cat_force_1%HSTURB4 + cat_force_2%HSTURB4 - add_cat_force%DHSDQA4 = cat_force_1%DHSDQA4 + cat_force_2%DHSDQA4 - add_cat_force%DHSDTC4 = cat_force_1%DHSDTC4 + cat_force_2%DHSDTC4 - add_cat_force%ETURBS = cat_force_1%ETURBS + cat_force_2%ETURBS - add_cat_force%DEDQAS = cat_force_1%DEDQAS + cat_force_2%DEDQAS - add_cat_force%DEDTCS = cat_force_1%DEDTCS + cat_force_2%DEDTCS - add_cat_force%HSTURBS = cat_force_1%HSTURBS + cat_force_2%HSTURBS - add_cat_force%DHSDQAS = cat_force_1%DHSDQAS + cat_force_2%DHSDQAS - add_cat_force%DHSDTCS = cat_force_1%DHSDTCS + cat_force_2%DHSDTCS - add_cat_force%TM = cat_force_1%TM + cat_force_2%TM - add_cat_force%QM = cat_force_1%QM + cat_force_2%QM - add_cat_force%ra1 = cat_force_1%ra1 + cat_force_2%ra1 - add_cat_force%ra2 = cat_force_1%ra2 + cat_force_2%ra2 - add_cat_force%ra4 = cat_force_1%ra4 + cat_force_2%ra4 - add_cat_force%raS = cat_force_1%raS + cat_force_2%raS - add_cat_force%SUNANG = cat_force_1%SUNANG + cat_force_2%SUNANG - add_cat_force%PARDIR = cat_force_1%PARDIR + cat_force_2%PARDIR - add_cat_force%PARDIF = cat_force_1%PARDIF + cat_force_2%PARDIF - add_cat_force%SWNETF = cat_force_1%SWNETF + cat_force_2%SWNETF - add_cat_force%SWNETS = cat_force_1%SWNETS + cat_force_2%SWNETS - add_cat_force%HLWDWN = cat_force_1%HLWDWN + cat_force_2%HLWDWN - add_cat_force%PSUR = cat_force_1%PSUR + cat_force_2%PSUR - add_cat_force%ZLAI = cat_force_1%ZLAI + cat_force_2%ZLAI - add_cat_force%GREEN = cat_force_1%GREEN + cat_force_2%GREEN - add_cat_force%Z2 = cat_force_1%Z2 + cat_force_2%Z2 - add_cat_force%SQSCAT = cat_force_1%SQSCAT + cat_force_2%SQSCAT - add_cat_force%RSOIL1 = cat_force_1%RSOIL1 + cat_force_2%RSOIL1 - add_cat_force%RSOIL2 = cat_force_1%RSOIL2 + cat_force_2%RSOIL2 - add_cat_force%RDC = cat_force_1%RDC + cat_force_2%RDC - add_cat_force%QSAT1 = cat_force_1%QSAT1 + cat_force_2%QSAT1 - add_cat_force%DQS1 = cat_force_1%DQS1 + cat_force_2%DQS1 - add_cat_force%ALW1 = cat_force_1%ALW1 + cat_force_2%ALW1 - add_cat_force%BLW1 = cat_force_1%BLW1 + cat_force_2%BLW1 - add_cat_force%QSAT2 = cat_force_1%QSAT2 + cat_force_2%QSAT2 - add_cat_force%DQS2 = cat_force_1%DQS2 + cat_force_2%DQS2 - add_cat_force%ALW2 = cat_force_1%ALW2 + cat_force_2%ALW2 - add_cat_force%BLW2 = cat_force_1%BLW2 + cat_force_2%BLW2 - add_cat_force%QSAT4 = cat_force_1%QSAT4 + cat_force_2%QSAT4 - add_cat_force%DQS4 = cat_force_1%DQS4 + cat_force_2%DQS4 - add_cat_force%ALW4 = cat_force_1%ALW4 + cat_force_2%ALW4 - add_cat_force%BLW4 = cat_force_1%BLW4 + cat_force_2%BLW4 - add_cat_force%QSATS = cat_force_1%QSATS + cat_force_2%QSATS - add_cat_force%DQSS = cat_force_1%DQSS + cat_force_2%DQSS - add_cat_force%ALWS = cat_force_1%ALWS + cat_force_2%ALWS - add_cat_force%BLWS = cat_force_1%BLWS + cat_force_2%BLWS - - end function add_cat_force - - ! ************************************************************ - - subroutine scalar2cat_param( cat_param, scalar ) - - implicit none - - real, intent(in) :: scalar - - type(cat_param_type), intent(out) :: cat_param - - integer :: i ! local - - ! --------------------- - - cat_param%dpth = scalar - - cat_param%dzsf = scalar - cat_param%dzrz = scalar - cat_param%dzpr = scalar - - do i=1,N_gt - cat_param%dzgt(i) = scalar - end do - - cat_param%poros = scalar - cat_param%cond = scalar - cat_param%psis = scalar - cat_param%bee = scalar - - cat_param%wpwet = scalar - - cat_param%gnu = scalar - - cat_param%vgwmax = scalar - - cat_param%vegcls = nint(scalar) - cat_param%soilcls30 = nint(scalar) - cat_param%soilcls100 = nint(scalar) - - cat_param%bf1 = scalar - cat_param%bf2 = scalar - cat_param%bf3 = scalar - cat_param%cdcr1 = scalar - cat_param%cdcr2 = scalar - cat_param%ars1 = scalar - cat_param%ars2 = scalar - cat_param%ars3 = scalar - cat_param%ara1 = scalar - cat_param%ara2 = scalar - cat_param%ara3 = scalar - cat_param%ara4 = scalar - cat_param%arw1 = scalar - cat_param%arw2 = scalar - cat_param%arw3 = scalar - cat_param%arw4 = scalar - cat_param%tsa1 = scalar - cat_param%tsa2 = scalar - cat_param%tsb1 = scalar - cat_param%tsb2 = scalar - cat_param%atau = scalar - cat_param%btau = scalar - - cat_param%gravel30 = scalar - cat_param%orgC30 = scalar - cat_param%orgC = scalar - cat_param%sand30 = scalar - cat_param%clay30 = scalar - cat_param%sand = scalar - cat_param%clay = scalar - cat_param%wpwet30 = scalar - cat_param%poros30 = scalar - - cat_param%veghght = scalar - - end subroutine scalar2cat_param - - ! ************************************************************************** - ! - ! utilities to convert from "cat_progn" type to regular arrays - ! - ! NOTE: the functions catprogn2xxx can only be used within the argument list - ! of a subroutine when the prognostic variables are "intent(in)" - ! - ! ************************************************************************** - - function catprogn2wesn(N_cat, cat_progn) - - implicit none - - integer, intent(in) :: N_cat - type(cat_progn_type), dimension(N_cat), intent(in) :: cat_progn - - real, dimension(N_snow,N_cat) :: catprogn2wesn - - ! local variables - - integer :: i - - ! -------------------------------- - - do i=1,N_snow - - catprogn2wesn(i,:) = cat_progn(:)%wesn(i) - - end do - - end function catprogn2wesn - - ! *********************************************************************** - - function catprogn2htsn(N_cat, cat_progn) - - implicit none - - integer, intent(in) :: N_cat - type(cat_progn_type), dimension(N_cat), intent(in) :: cat_progn - - real, dimension(N_snow,N_cat) :: catprogn2htsn - - ! local variables - - integer :: i - - ! -------------------------------- - - do i=1,N_snow - - catprogn2htsn(i,:) = cat_progn(:)%htsn(i) - - end do - - end function catprogn2htsn - - ! *********************************************************************** - - function catprogn2sndz(N_cat, cat_progn) - - implicit none - - integer, intent(in) :: N_cat - type(cat_progn_type), dimension(N_cat), intent(in) :: cat_progn - - real, dimension(N_snow,N_cat) :: catprogn2sndz - - ! local variables - - integer :: i - - ! -------------------------------- - - do i=1,N_snow - - catprogn2sndz(i,:) = cat_progn(:)%sndz(i) - - end do - - end function catprogn2sndz - - ! *********************************************************************** - - function catprogn2ghtcnt(N_cat, cat_progn) - - implicit none - - integer, intent(in) :: N_cat - type(cat_progn_type), dimension(N_cat), intent(in) :: cat_progn - - real, dimension(N_gt,N_cat) :: catprogn2ghtcnt - - ! local variables - - integer :: i - - ! -------------------------------- - - do i=1,N_gt - - catprogn2ghtcnt(i,:) = cat_progn(:)%ght(i) - - end do - - end function catprogn2ghtcnt - - ! *********************************************************************** - - function cat_diagS_max( scalar, cat_diagS ) - - implicit none - - type(cat_diagS_type) :: cat_diagS_max - type(cat_diagS_type), intent(in) :: cat_diagS - - real, intent(in) :: scalar - - integer :: i ! local - - cat_diagS_max%ar1 = max(scalar, cat_diagS%ar1) - cat_diagS_max%ar2 = max(scalar, cat_diagS%ar2) - - cat_diagS_max%asnow = max(scalar, cat_diagS%asnow) - - cat_diagS_max%sfmc = max(scalar, cat_diagS%sfmc) - cat_diagS_max%rzmc = max(scalar, cat_diagS%rzmc) - cat_diagS_max%prmc = max(scalar, cat_diagS%prmc) - - cat_diagS_max%tsurf = max(scalar, cat_diagS%tsurf) - - do i=1,N_gt - cat_diagS_max%tp(i) = max(scalar, cat_diagS%tp(i)) - end do - - do i=1,N_snow - cat_diagS_max%tpsn(i) = max(scalar, cat_diagS%tpsn(i)) - end do - - end function cat_diagS_max - -end module catch_types - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -#if 0 - -! driver routines for testing - -program test_catch_types - - ! use module catch_types - - implicit none - - type(cat_diagS_type) :: cat_diagS_1, cat_diagS_2 - - cat_diagS_1 = 1. - cat_diagS_2 = 2. - - write (*,*) cat_diagS_1 - write (*,*) cat_diagS_2 - - cat_diagS_2 = cat_diagS_1 + cat_diagS_2 - - write (*,*) cat_diagS_1 - write (*,*) cat_diagS_2 - -end program test_catch_types - -#endif - -! ========================== EOF ================================== diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/enkf_types.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/enkf_types.F90 deleted file mode 100644 index 566c75ef..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/enkf_types.F90 +++ /dev/null @@ -1,228 +0,0 @@ - -module enkf_types - - ! definition of types for the EnKF - ! - ! reichle, 19 Jul 2005 - ! - ! added new field to obs_param_type for adaptive filtering - ! - reichle, 15 Dec 2006 - ! - ! revised "obs_param_type" for SMOS angles and downscaling ("FOV") - ! - reichle, 13 Jun 2011 - ! - ! added "%bias_*" fields for obs bias estimation - ! - reichle+draper, 28 Aug 2013 - ! - ! added "%coarsen_pert" to obs_param_type - ! - reichle, 6 Dec 2013 - ! - ! reichle, 31 Jan 2014: added "%time" to "obs_type" - ! - ! reichle, 8 Jun 2017: added "%flistpath" and "%flistname" to "obs_param_type" - ! - ! reichle,28 Feb 2024: added "%maskpath" and "%maskname" to "obs_param_type" - ! - ! ------------------------------------------------------------------- - - implicit none - - save - - ! everything is private by default unless made public - - private - - public :: obs_type - public :: obs_param_type - public :: write_obs_param - - public :: N_obs_ang_max - - ! ------------------------------------------------------------------------- - ! - ! N_obs_ang_max = max # obs angles permitted per obs type in in nml file - - integer, parameter :: N_obs_ang_max = 7 - - ! ----------------------------------------------------------------------- - - ! obs_type is basic element of vector "Observations" (length N_obs), - ! which contains all observations of all types that are available - ! at a given update time - - ! added innov information for adaptive filtering - reichle, 14 Dec 2006 - ! added OminusA information for adaptive filtering - reichle, 1 Feb 2007 - ! added "varname" field to "obs_param_type" - reichle 14 Jun 2011 - ! major revisions to "obs_type" fields - reichle 16 Jun 2011 - ! added "units" field to "obs_param_type" - reichle 22 Nov 2011 - - type :: obs_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - logical :: assim ! .T. if obs is assimilated (ie., used in state update), - ! .F. if only "get_innov" or only used for obs bias update - integer :: species ! identifier for type of observation - integer :: tilenum ! number of tile within (full) domain - integer :: DUMMYGAP ! fill gap so that MPI STRUCT works with "-align" compiler flag - real*8 :: time ! time of obs (J2000 seconds w/ 'TT12' epoch; see date_time_util.F90) - real :: lon ! longitude of obs - real :: lat ! latitude of obs - real :: obs ! observed value - real :: obsvar ! obs error var - real :: fcst ! "forecast": value of obs pred before EnKF update (ens mean) - real :: fcstvar ! forecast error var (in obs space), a.k.a. HPHt - real :: ana ! "analysis": value of obs pred after EnKF update (ens mean) - real :: anavar ! analysis error var (in obs space), a.k.a. HAHt - - end type obs_type - - ! ---------------------------------------------------------------------- - ! - ! vector obs_param contains information about each species of observations - - type :: obs_param_type - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! WARNING: When modifying this derived type make sure that the corresponding - ! MPI STRUCTURE in module CLSM_ENSDRV_MPI is also updated, as are - ! any subroutines or operators defined herein - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - character(40) :: descr ! description - integer :: species ! identifier for type of measurement - - integer :: orbit ! type of (half-)orbit - ! 0 = n/a [eg., in situ obs] - ! 1 = ascending - ! 2 = descending - ! 3 = ascending or descending - ! 4 = geostationary - - integer :: pol ! polarization - ! 0 = n/a [eg., multi-pol. retrieval] - ! 1 = horizontal - ! 2 = vertical - ! 3 = ... - ! [add 3rd/4th Stokes, HH, HV, VH, VV] - - integer :: N_ang ! # satellite viewing angles in species (radiance obs only) - - real, & - dimension(N_obs_ang_max) :: ang ! vector of satellite viewing angles - - real :: freq ! frequency [Hz] - - real :: FOV ! field-of-view *radius* - ! if FOV==0. equate obs footprint w/ tile - ! for details see LDASsa_DEFAULT_inputs ensupd.nml - character(40) :: FOV_units ! FOV units ('km' or 'deg') - - logical :: assim ! assimilate yes/no? (see also "obs_type") - logical :: scale ! scale yes/no? - logical :: getinnov ! compute innovs? (.T. if assim==.T.) - - integer :: RTM_ID ! ID of radiative transfer model - - integer :: bias_Npar ! number of bias states tracked per day - integer :: bias_trel ! e-folding time scale of obs bias memory [s] - integer :: bias_tcut ! cutoff time for confident obs bias est [s] - - real :: nodata ! no-data-value - - character(40) :: varname ! equivalent model variable name (Obs_pred) - character(40) :: units ! units (eg., 'K' or 'm3/m3') - - character(200) :: path ! path to measurements file - character(80) :: name ! name identifier for measurements - character(200) :: maskpath ! path to obs mask file - character(80) :: maskname ! filename for obs mask - character(200) :: scalepath ! path to file with scaling parameters - character(80) :: scalename ! filename for scaling parameters - character(200) :: flistpath ! path to file with list of obs file names - character(80) :: flistname ! name of file with list of obs file names - - real :: errstd ! default obs error std - - real :: std_normal_max ! see pert_param_type - logical :: zeromean ! see pert_param_type - logical :: coarsen_pert ! see pert_param_type ("%coarsen") - real :: xcorr ! see pert_param_type - real :: ycorr ! see pert_param_type - - integer :: adapt ! identifier for adaptive filtering - - end type obs_param_type - - ! ---------------------------------------------------------------------- - -contains - - subroutine write_obs_param(unitnumber, N_obs_param, obs_param) - - implicit none - - integer, intent(in) :: unitnumber - integer, intent(in) :: N_obs_param - - type(obs_param_type), dimension(N_obs_param), intent(in) :: obs_param - - ! local variables - - integer :: i - - ! -------------------------------------------------------------------- - - write (unitnumber,*) N_obs_param - - do i=1,N_obs_param - - write (unitnumber, '(42A)') "'" // trim(obs_param(i)%descr) // "'" - write (unitnumber, *) obs_param(i)%species - write (unitnumber, *) obs_param(i)%orbit - write (unitnumber, *) obs_param(i)%pol - write (unitnumber, *) obs_param(i)%N_ang - - write (unitnumber, *) obs_param(i)%ang(1:obs_param(i)%N_ang) - - write (unitnumber, *) obs_param(i)%freq - write (unitnumber, *) obs_param(i)%FOV - write (unitnumber, '(42A)') "'" // trim(obs_param(i)%FOV_units) // "'" - write (unitnumber, *) obs_param(i)%assim - write (unitnumber, *) obs_param(i)%scale - write (unitnumber, *) obs_param(i)%getinnov - write (unitnumber, *) obs_param(i)%RTM_ID - write (unitnumber, *) obs_param(i)%bias_Npar - write (unitnumber, *) obs_param(i)%bias_trel - write (unitnumber, *) obs_param(i)%bias_tcut - write (unitnumber, *) obs_param(i)%nodata - write (unitnumber, '(42A)') "'" // trim(obs_param(i)%varname) // "'" - write (unitnumber, '(42A)') "'" // trim(obs_param(i)%units) // "'" - write (unitnumber,'(202A)') "'" // trim(obs_param(i)%path) // "'" - write (unitnumber, '(82A)') "'" // trim(obs_param(i)%name) // "'" - write (unitnumber,'(202A)') "'" // trim(obs_param(i)%maskpath) // "'" - write (unitnumber, '(82A)') "'" // trim(obs_param(i)%maskname) // "'" - write (unitnumber,'(202A)') "'" // trim(obs_param(i)%scalepath) // "'" - write (unitnumber, '(82A)') "'" // trim(obs_param(i)%scalename) // "'" - write (unitnumber,'(202A)') "'" // trim(obs_param(i)%flistpath) // "'" - write (unitnumber, '(82A)') "'" // trim(obs_param(i)%flistname) // "'" - write (unitnumber, *) obs_param(i)%errstd - write (unitnumber, *) obs_param(i)%std_normal_max - write (unitnumber, *) obs_param(i)%zeromean - write (unitnumber, *) obs_param(i)%coarsen_pert - write (unitnumber, *) obs_param(i)%xcorr - write (unitnumber, *) obs_param(i)%ycorr - write (unitnumber, *) obs_param(i)%adapt - - end do - - end subroutine write_obs_param - -end module enkf_types - -! ================== EOF =============================================== diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/my_lu_decomp.f b/src/Components/GEOSldas_GridComp/LDAS_Shared/my_lu_decomp.f deleted file mode 100644 index 191eff98..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/my_lu_decomp.f +++ /dev/null @@ -1,140 +0,0 @@ -c -c routines adapted from Numerical Recipes -c -c reichle, 20 Apr 01 -c -c -c *********************************************************************** -c -c ------- documentation from C function --------- -c -c LU decomposition after Numerical Recipes -c -c Given a matrix a[1..n][1..n], this routine replaces it by the -c LU decomposition of a rowwise permutation of itself. a and n are -c inputs. a is output, arranged as in equation (2.3.14) (see book). -c indx[1..n] is an output vector that records the row permutation -c effected by the partial pivoting; This routine is used in combination -c with lubksb to solve linear equations or invert a matrix. -c -c edited 20 Apr 01, reichle -c -c - eliminated d (for computation of determinant) -c - eliminated np (can use automatic arrays nowadays...) -c -c edited 03 Jun 02, reichle -c -c - eliminated parameter NMAX, using dynamic allocation -c -c ----------------------------------------------------- -c - SUBROUTINE ludcmp(a,n,indx) - INTEGER n,indx(n) - REAL a(n,n),TINY - PARAMETER (TINY=1.0e-20) - INTEGER i,imax,j,k - REAL aamax,dum,sum,vv(n) - do 12 i=1,n - aamax=0. - do 11 j=1,n - if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) - 11 continue - if (aamax.eq.0.) pause 'singular matrix in ludcmp' - vv(i)=1./aamax - 12 continue - do 19 j=1,n - do 14 i=1,j-1 - sum=a(i,j) - do 13 k=1,i-1 - sum=sum-a(i,k)*a(k,j) - 13 continue - a(i,j)=sum - 14 continue - aamax=0. - do 16 i=j,n - sum=a(i,j) - do 15 k=1,j-1 - sum=sum-a(i,k)*a(k,j) - 15 continue - a(i,j)=sum - dum=vv(i)*abs(sum) - if (dum.ge.aamax) then - imax=i - aamax=dum - endif - 16 continue - if (j.ne.imax)then - do 17 k=1,n - dum=a(imax,k) - a(imax,k)=a(j,k) - a(j,k)=dum - 17 continue - vv(imax)=vv(j) - endif - indx(j)=imax - if(a(j,j).eq.0.)a(j,j)=TINY - if(j.ne.n)then - dum=1./a(j,j) - do 18 i=j+1,n - a(i,j)=a(i,j)*dum - 18 continue - endif - 19 continue - return - END - - -c *********************************************************************** -c -c ------- documentation from C function --------- -c -c LU backsubstitution after Numerical Recipes -c -c Solves the set of n linear equations A X = B. Here a[1..n][1..n] is -c input, not as the matrix A but rather as its LU decomposition, -c determined by the routine ludcmp. indx[1..n] is input as the permutation -c vector returned by ludcmp. b[1..n] is input as the right-hand side -c vector B, and returns the solution vector X. a,n, and indx ar not -c modified by this routine and can be left in place for successive calls -c with different right-hand sides b. This routine takes into account -c the possibility that b will begin with many zero elements, so it is -c efficient for use in matrix inversion. -c -c edited 20 Apr 01, reichle -c -c - eliminated np (can use automatic arrays nowadays...) -c -c ----------------------------------------------------- -c - SUBROUTINE lubksb(a,n,indx,b) - INTEGER n,indx(n) - REAL a(n,n),b(n) - INTEGER i,ii,j,ll - REAL sum - ii=0 - do 12 i=1,n - ll=indx(i) - sum=b(ll) - b(ll)=b(i) - if (ii.ne.0)then - do 11 j=ii,i-1 - sum=sum-a(i,j)*b(j) - 11 continue - else if (sum.ne.0.) then - ii=i - endif - b(i)=sum - 12 continue - do 14 i=n,1,-1 - sum=b(i) - do 13 j=i+1,n - sum=sum-a(i,j)*b(j) - 13 continue - b(i)=sum/a(i,i) - 14 continue - return - END -c -c -c ********** EOF ****************************************************** - diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/my_matrix_functions.F90 b/src/Components/GEOSldas_GridComp/LDAS_Shared/my_matrix_functions.F90 deleted file mode 100644 index d459a9cf..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/my_matrix_functions.F90 +++ /dev/null @@ -1,1269 +0,0 @@ - -! this file contains a collection of matrix operation subroutines -! -! reichle, 1 May 01 -! reichle, 18 Apr 06 - renamed subroutine sort() - -module my_matrix_functions - - implicit none - - private - - public :: row_variance - public :: row_std - !public :: adjust_mean - !public :: matrix_std - public :: unique_rows_3col - !public :: unique_rows_2col - -contains - - ! Changed algorithm to compute (co)variance in subroutines row_covariance() and - ! row_variance(). Original subroutines commented out below. - ! wjiang + reichle, 25 Nov 2020 - - subroutine row_covariance( M, N, A, B, covar ) - ! compute covariance of each row of two M-by-N matrices A and B - implicit none - integer, intent(in) :: M, N - real, intent(in), dimension(M,N) :: A - real, intent(in), dimension(M,N) :: B - real, intent(out), dimension(M) :: covar - ! locals - integer :: i, j - real :: mean_a, mean_b - ! ------------------------------------------------------------- - do i=1,M - mean_a = sum(A(i,:))/N - mean_b = sum(B(i,:))/N - covar(i) = 0. - do j=1,N - covar(i) = covar(i) + (A(i,j)-mean_a)*(B(i,j)-mean_b) - end do - end do - covar = covar/(N-1) - end subroutine row_covariance - - ! ********************************************************************** - - subroutine row_variance( M, N, A, var, mean ) - ! compute variance of each row of an M-by-N matrix A - ! optionally output mean values - implicit none - integer, intent(in) :: M, N - real, intent(in), dimension(M,N) :: A - real, intent(out), dimension(M) :: var - real, intent(out), dimension(M), optional :: mean - ! locals - integer :: i, j - real, dimension(M) :: mean_tmp - ! ------------------------------------------------------------- - do i=1,M - mean_tmp(i) = sum(A(i,:))/N - var(i) = 0 - do j=1,N - var(i) = var(i) + (A(i,j)-mean_tmp(i))**2 - end do - end do - var = var/(N-1) - if (present(mean)) mean = mean_tmp - end subroutine row_variance - - ! ********************************************************************** - -#if 0 - ! The following is a version of subroutine matrix_std() that is - ! consistent with the revised algorithm for (co)variance computation. - ! This subroutine is not used. - ! Note that land_pert.F90 contains another (commented-out) version. - ! wjiang + reichle, 25 Nov 2020 - - subroutine matrix_std( N_row, N_col, A, std ) - ! compute std of all elements of N_row by N_col matrix A - implicit none - integer, intent(in) :: N_row, N_col - real, intent(inout), dimension(N_row,N_col) :: A - real, intent(out) :: std - ! ---------------------------- - ! locals - integer :: N - real :: mean - ! ------------------------------------------------------------ - N = N_row*N_col - ! compute sample std - mean = sum(A)/N - std = sqrt(sum((A-mean)*(A-mean))/(N-1)) - end subroutine matrix_std - -#endif - -!! subroutine row_covariance( M, N, A, B, covar ) -!! -!! ! compute covariance of each row of two M-by-N matrices A and B -!! -!! implicit none -!! -!! integer, intent(in) :: M, N -!! -!! real, intent(in), dimension(M,N) :: A -!! -!! real, intent(in), dimension(M,N) :: B -!! -!! real, intent(out), dimension(M) :: covar -!! -!! ! locals -!! -!! integer :: i, j -!! -!! real :: x2, N_real, N_real_minus_one -!! -!! ! ------------------------------------------------------------- -!! -!! N_real = real(N) -!! -!! N_real_minus_one = real(N-1) -!! -!! do i=1,M -!! -!! x2 = 0.0 -!! do j=1,N -!! x2 = x2 + A(i,j)*B(i,j) -!! end do -!! -!! covar(i) = ( x2 - (sum(A(i,:))*sum(B(i,:)))/N_real )/N_real_minus_one -!! -!! end do -!! -!! end subroutine row_covariance -!! -!! -!! ! ------------------------------------------------------------------- -!! -!! subroutine row_variance( M, N, A, var, mean ) -!! -!! ! compute variance of each row of an M-by-N matrix A -!! -!! ! reichle, 16 Jun 2011: added optional output of mean -!! -!! implicit none -!! -!! integer, intent(in) :: M, N -!! -!! real, intent(in), dimension(M,N) :: A -!! -!! real, intent(out), dimension(M) :: var -!! -!! real, intent(out), dimension(M), optional :: mean -!! -!! ! locals -!! -!! integer :: i, j -!! -!! real :: x2, N_real, N_real_minus_one -!! -!! real, dimension(M) :: xm -!! -!! ! ------------------------------------------------------------- -!! -!! N_real = real(N) -!! -!! N_real_minus_one = real(N-1) -!! -!! do i=1,M -!! -!! x2 = 0.0 -!! do j=1,N -!! x2 = x2 + A(i,j)*A(i,j) -!! end do -!! -!! xm(i) = sum(A(i,:)) -!! -!! var(i) = ( x2 - (xm(i)**2)/N_real )/N_real_minus_one -!! -!! end do -!! -!! ! deal with possible round-off errors -!! ! reichle, 24 Sep 2004 -!! -!! var = max(var,0.) -!! -!! if (present(mean)) mean = xm/N_real -!! -!! end subroutine row_variance - - ! ********************************************************************** - - subroutine row_std( M, N, A, std, mean ) - - ! compute standard deviation of each row of an M-by-N matrix A - - ! reichle, 2 May 2013: added optional output of mean - - implicit none - - integer, intent(in) :: M, N - - real, intent(in), dimension(M,N) :: A - - real, intent(out), dimension(M) :: std - - real, intent(out), dimension(M), optional :: mean - - if (present(mean)) then - - call row_variance( M, N, A, std, mean ) - - else - - call row_variance( M, N, A, std ) - - end if - - std = sqrt(std) - - end subroutine row_std - - ! ********************************************************************** - - subroutine row_third_moment( M, N, A, third_moment ) - - ! compute third moment of each row of an M-by-N matrix A - - ! third_moment = 1/N * sum_{i=1}^N (x_i - mean(x))**3 - - implicit none - - integer, intent(in) :: M, N - - real, intent(in), dimension(M,N) :: A - - real, intent(out), dimension(M) :: third_moment - - ! locals - - integer :: i, j - - real :: x3, mx, N_real - - ! ------------------------------------------------------------- - - N_real = real(N) - - do i=1,M - - mx = sum(A(i,:))/N_real - - x3 = 0.0 - do j=1,N - x3 = x3 + (A(i,j)-mx)**3 - end do - - third_moment(i) = x3/N_real - - end do - - end subroutine row_third_moment - - - ! ********************************************************************** - -#if 0 - - ! This subroutine was commented out because it is not currently needed but - ! contains a call to the obsolete "nr_sort()". If needed again, replace the - ! call to "nr_sort()" with call to MAPL sort routine. - ! - reichle, 25 Aug 2014 - - subroutine five_number_summary( M, N, A, five_numbers ) - - ! get five number summary (median, lower and upper quartiles, min and max) - ! of each row of an M-by-N data matrix A - ! - ! inputs: - ! M : number of rows of data = number of different data types - ! N : number of columns of data = number of ensemble members - ! A : M-by-N matrix, left unchanged by this function - ! - ! outputs: - ! five_numbers : M-by-5 matrix containing statistical summary: - ! column 1: min - ! column 2: lower quartile - ! column 3: median - ! column 4: upper quartile - ! column 5: max - ! - ! Type: f90 - ! Author: Rolf Reichle - ! Date: 2 May 2001 - - implicit none - - integer, intent(in) :: M, N - - real, intent(in), dimension(M,N) :: A - - real, intent(out), dimension(M,5) :: five_numbers - - ! ---------------------------- - - ! locals - - integer i,d - - real, dimension(N) :: tmpvec - - do i=1,M - - ! put i-th row of data into tmpvec - - tmpvec = A(i,:) - - ! sort tmpvec in ascending order - - call nr_sort( N, tmpvec ) - - ! get min, max, median and quartiles - - ! min and max - - five_numbers(i,1) = tmpvec(1) ! min - - five_numbers(i,5) = tmpvec(N) ! max - - ! median - - if (mod(N,2) == 0) then - five_numbers(i,3) = .5*(tmpvec(N/2)+tmpvec(N/2+1)) - else - five_numbers(i,3) = tmpvec(N/2+1) - end if - - ! quartiles - ! (follows Robert Johnson, "Elementary Statistics", PWS-Kent, p69, 1988) - - if (mod(N,4) == 0) then - - d = N/4 - - five_numbers(i,2) = .5*(tmpvec(d)+tmpvec(d+1)) ! lower - - five_numbers(i,4) = .5*(tmpvec(N-d)+tmpvec(N-d+1)) ! upper - - else - - d = N/4+1 - - five_numbers(i,2) = tmpvec(d) ! lower - - five_numbers(i,4) = tmpvec(N-d) ! upper - - end if - - end do - - end subroutine five_number_summary - -#endif - - ! ------------------------------------------------------------------ - -#if 0 - subroutine adjust_mean( N_row, N_col, A, M ) - - ! adjust N_row by N_col matrix A such that - ! mean over columns for each row is given by the - ! corresponding element in vector M of length N_row - ! - ! vector of mean values M is optional input, if not present - ! zero mean is assumed - - implicit none - - integer, intent(in) :: N_row, N_col - - real, intent(inout), dimension(N_row,N_col) :: A - - real, intent(in), optional, dimension(N_row) :: M - - ! ---------------------------- - - ! locals - - integer i - - real, dimension(N_row) :: correction - - ! ------------------------------------------------------------ - - if (present(M)) then - correction = M - sum(A,2)/real(N_col) - else - correction = - sum(A,2)/real(N_col) - end if - - do i=1,N_col - A(:,i) = A(:,i) + correction - end do - - end subroutine adjust_mean -#endif - - ! ------------------------------------------------------------------ - -#if 0 - ! This subroutine is not used. - ! Note that land_pert.F90 contains another (commented-out) version. - ! wjiang + reichle, 25 Nov 2020 - - subroutine adjust_std( N_row, N_col, A, std ) - - ! adjust N_row by N_col matrix A such that (sample) standard deviation - ! of all elements is exactly equal to std - ! - ! std is optional input, if not present std=1 is assumed - - implicit none - - integer, intent(in) :: N_row, N_col - - real, intent(inout), dimension(N_row,N_col) :: A - - real, intent(in), optional :: std - - ! ---------------------------- - - ! locals - - integer :: i, j - - real :: correction, sample_std - - ! ------------------------------------------------------------ - - ! compute sample std - - call matrix_std( N_row, N_col, A, sample_std ) - - if (present(std)) then - correction = std/sample_std - else - correction = 1./sample_std - end if - - do i=1,N_row - do j=1,N_col - A(i,j) = correction*A(i,j) - end do - end do - - end subroutine adjust_std -#endif - - ! ------------------------------------------------------------------ - -!! subroutine matrix_std( N_row, N_col, A, std ) -!! -!! ! compute std of all elements of N_row by N_col matrix A -!! -!! implicit none -!! -!! integer, intent(in) :: N_row, N_col -!! -!! real, intent(inout), dimension(N_row,N_col) :: A -!! -!! real, intent(out) :: std -!! -!! ! ---------------------------- -!! -!! ! locals -!! -!! integer :: i, j -!! -!! real :: x2, m, N_real, N_real_minus_one -!! -!! ! ------------------------------------------------------------ -!! -!! N_real = real(N_row)*real(N_col) -!! -!! N_real_minus_one = N_real - 1. -!! -!! ! compute sample std -!! -!! x2 = 0.0 -!! m = 0.0 -!! -!! do i=1,N_row -!! do j=1,N_col -!! m = m + A(i,j) -!! x2 = x2 + A(i,j)*A(i,j) -!! end do -!! end do -!! -!! std = sqrt( ( x2 - m**2/N_real )/N_real_minus_one ) -!! -!! end subroutine matrix_std - - - ! **************************************************************** - - subroutine unique_rows_2col( N_rows, A, N_unique_rows, ind_A2U ) - - ! Identify unique rows in 2-column matrix A (N_rows-by-2). Unique rows - ! are returned in the first (N_unique_rows) of matrix A. Also returned - ! is the index vector from the original row indices of A to the - ! unique rows stored in the returned A (upon return, only the first - ! N_unique_rows of A are meaningful). - ! - ! uses nr_indexx.f - ! - ! reichle, 14 Jun 2012 - ! reichle, 25 Oct 2012: fixed case N_rows=0 upon input - ! - ! -------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_rows - - real, dimension(N_rows,2), intent(inout) :: A - - integer, intent(out) :: N_unique_rows - - integer, dimension(N_rows), intent(out) :: ind_A2U - - ! local variables - - real, parameter :: tol_frac = 1.e-5 - - integer :: i, iunique, istart, iend, N_tmp - - real :: tol1, tol2 - - integer, dimension(N_rows) :: indx, indx2 - - ! -------------------------------------------------------------------- - - if (N_rows==0) then - - N_unique_rows = 0 - - return ! nothing else left to do - - end if - - ! ------------------------------------- - ! - ! tolerances for check of (in)equality of real numbers - - tol1 = tol_frac * sum(abs(A(:,1))) / real(N_rows) - tol2 = tol_frac * sum(abs(A(:,2))) / real(N_rows) - - ! ------------------------------------- - ! - ! sort A according to *first* column - - call nr_indexx(N_rows, A(:,1), indx) - - ! apply sort - - A = A(indx, :) - - !write (*,*) 'after first column sort' - !do j=1,N_rows - ! write (*,*) A(j,:) - !end do - - ! ------------------------------------- - ! - ! for each block of identical entries in sorted A(:,1), sort according - ! to *second* column - - istart = 1 ! start counter for block of identical entries in sorted A(:,1) - - do i=1,(N_rows-1) - - ! compare pairs of subsequent elements in first column - - if ( (abs(A(i,1)-A(i+1,1))>tol1) .or. (i==(N_rows-1)) ) then - - ! reached new block [ie, A(i,1)/=A(i+1,1)] or - ! reached final pair of elements - - iend = i - - ! special treatment for final pair of elements: - ! if elements are identical, include final row in block to be sorted, - ! ignore otherwise (no need to sort final row if distinct from others) - - if ( (abs(A(i,1)-A(i+1,1))1) then ! sort only if more than one element in block - - call nr_indexx(N_tmp, A(istart:iend,2), indx2(1:N_tmp)) - - ! apply sort - - A( istart:iend,:) = A( indx2(1:N_tmp)+istart-1,:) - indx(istart:iend ) = indx(indx2(1:N_tmp)+istart-1 ) - - !write (*,*) 'after second column sort' - !write (*,*) i, N_tmp - !do j=1,N_rows - ! write (*,*) A(j,:) - !end do - - end if - - ! re-init - - istart = i+1 - - end if - - end do - - ! ------------------------------------- - ! - ! eliminate identical rows - - iunique = 1 - - do i=1,(N_rows-1) - - ! record mapping from original row indices to unique rows - - ind_A2U(indx(i)) = iunique - - ! special treatment for last pair of elements - - if ( (i==(N_rows-1)) .and. & - (abs(A(i,1)-A(i+1,1))tol1) .or. & - (abs(A(i,2)-A(i+1,2))>tol2) ) then - - ! found "new" row, pull forward - - iunique = iunique+1 - - A(iunique,:) = A(i+1,:) - - end if - - end do - - N_unique_rows = iunique - - end subroutine unique_rows_2col - - ! **************************************************************** - - subroutine unique_rows_3col( N_rows, A, N_unique_rows, ind_A2U ) - - ! Identify unique rows in 3-column matrix A (N_rows-by-3). Unique rows - ! are returned in the first (N_unique_rows) of matrix A. Also returned - ! is the index vector from the original row indices of A to the - ! unique rows stored in the returned A (upon return, only the first - ! N_unique_rows of A are meaningful). - ! - ! uses subroutine unique_rows_2col() - ! - ! equivalent MATLAB code {Version: 7.14.0.739 (R2012a)}: - ! - ! [ A_unique, ind_tmp, ind_A2U ] = unique( A_orig, 'rows'); - ! - ! reichle, 31 Mar 2015 - ! - ! -------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: N_rows - - real, dimension(N_rows,3), intent(inout) :: A - - integer, intent(out) :: N_unique_rows - - integer, dimension(N_rows), intent(out) :: ind_A2U - - ! local variables - - integer :: N_step1, N_step2 - - integer, dimension(N_rows) :: ind_A2U_step1, ind_A2U_step2 - - real, dimension(N_rows,2) :: A_step1, A_step2 - - ! -------------------------------------------------------------------- - - if (N_rows==0) then - - N_unique_rows = 0 - - return ! nothing else left to do - - end if - - ! Step 1: - ! determine unique rows of submatrix A(:,1:2) - - A_step1 = A(:,1:2) - - call unique_rows_2col( N_rows, A_step1, N_step1, ind_A2U_step1 ) - - ! Step 2: - ! assemble temporary 2-column matrix with indicator of unique - ! rows of A(:,1:2) in column 1 and A(:,3) in column 2 - - A_step2(:,1) = real( ind_A2U_step1 ) - A_step2(:,2) = A(:,3) - - call unique_rows_2col( N_rows, A_step2, N_step2, ind_A2U_step2 ) - - ! Step 3: - ! finalize - - N_unique_rows = N_step2 - - ind_A2U = ind_A2U_step2 - - A(1:N_step2,1:2) = A_step1(nint(A_step2(1:N_step2,1)),:) - A(1:N_step2, 3) = A_step2( 1:N_step2 ,2) - - end subroutine unique_rows_3col - - ! ***************************************** - -end module my_matrix_functions - -! ************************************************************************ - -! driver programs for testing - -#if 0 - -program test_adjust_std - - use my_matrix_functions - - implicit none - - integer, parameter :: M=3, N=30 - - integer :: i, j - - real, dimension(M,N) :: A - - real :: std - - call random_number( A ) - - call matrix_std( M, N, A, std) - write (*,*) std - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - - call adjust_std(M,N,A,9.999) - - call matrix_std( M, N, A, std) - write (*,*) std - - write (*,*) - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - - call adjust_std(M,N,A) - - call matrix_std( M, N, A, std) - write (*,*) std - - write (*,*) - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - -end program test_adjust_std - -#endif - -! --------------------------------------- - -#if 0 - -program test_adjust_mean - - use my_matrix_functions - - implicit none - - integer, parameter :: M=3, N=10 - - integer :: i, j - - real, dimension(M,N) :: A - - real, dimension(M) :: mean_values - - call random_number( A ) - - call random_number(mean_values) - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - - do i=1,M - - write (*,'(30(e13.5))') mean_values(i) - - end do - - call adjust_mean(M,N,A,mean_values) - - write (*,*) - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - - call adjust_mean(M,N,A) - - write (*,*) - - do i=1,M - - write (*,'(30(e13.5))') (A(i,j), j=1,N) - - end do - - -end program test_adjust_mean - -#endif - -! driver routine for testing - -#if 0 - -program test_row_variance - - use my_matrix_functions - - implicit none - - integer, parameter :: M=3, N=10 - - integer :: i, j - - real, dimension(M,N) :: A - - real, dimension(M) :: var - - call random_number( A ) - - - do i=1,M - - write (*,'(30(e12.5))') (A(i,j), j=1,N) - - end do - - call row_variance(M,N,A,var) - - write (*,*) - - do i=1,M - - write (*,'(1(e12.5))') var(i) - - end do - - -end program test_row_variance - -#endif - -! driver routine for testing - -#if 0 - -program test_row_covariance - - use my_matrix_functions - - implicit none - - integer, parameter :: M=5, N=10 - - integer :: i, j - - real, dimension(M,N) :: A, B - - real, dimension(M) :: covar - - call random_number( A ) - call random_number( B ) - - write (*,*) 'A=[' - - do i=1,M - - write (*,'(30(e12.5))') (A(i,j), j=1,N) - - end do - - write (*,*) ']' - - write (*,*) - - write (*,*) 'B=[' - - do i=1,M - - write (*,'(30(e12.5))') (B(i,j), j=1,N) - - end do - - write (*,*) ']' - - call row_covariance(M,N,A,B,covar) - - write (*,*) - - do i=1,M - - write (*,'(1(e12.5))') covar(i) - - end do - - -end program test_row_covariance - -#endif - - -#if 0 - -program test_five_number_summary - - use my_matrix_functions - - implicit none - - integer :: i,j - - integer, parameter :: N_data = 10, N_ens = 30 - - real, dimension(N_data,N_ens) :: my_data - - real, dimension(N_data,5) :: five_numbers - - call random_number(my_data) - - do i=1,N_data - - write (*,'(30(e12.5))') (my_data(i,j), j=1,N_ens) - - end do - - call five_number_summary(N_data, N_ens, my_data, five_numbers) - - write (*,*) size(five_numbers) - - do i=1,N_data - - write (*,'(5(e12.5))') (five_numbers(i,j), j=1,5) - - end do - - -end program test_five_number_summary - -#endif - - -#if 0 - -program test_unique_rows - - use my_matrix_functions, ONLY: unique_rows_2col - implicit none - - integer, parameter :: N_rows = 55 ! 6 - integer, parameter :: N_cols = 2 - - real, dimension(N_rows,N_cols) :: A, A_orig - - integer :: N_unique_rows, i, j - - integer, dimension(N_rows) :: ind_A2U - - ! --------------------------------------------- - - A(1,:) = (/ 1, 2 /) - A(2,:) = (/ 2, 2 /) - A(3,:) = (/ 3, 2 /) - A(4,:) = (/ 1, 2 /) - A(5,:) = (/ 2, 2 /) - A(6,:) = (/ 1, 2 /) - - if (N_rows==55) then - - A( 1,:) = (/ 0.20, 32.5 /) - A( 2,:) = (/ 1.41, 37.5 /) - A( 3,:) = (/ 1.41, 42.5 /) - A( 4,:) = (/ 1.41, 47.5 /) - A( 5,:) = (/ 1.41, 52.5 /) - A( 6,:) = (/ 1.41, 57.5 /) - A( 7,:) = (/ 1.41, 32.5 /) - A( 8,:) = (/ 1.41, 37.5 /) - A( 9,:) = (/ 1.41, 42.5 /) - A(10,:) = (/ 1.41, 47.5 /) - A(11,:) = (/ 1.41, 52.5 /) - A(12,:) = (/ 1.41, 57.5 /) - A(13,:) = (/ 1.41, 32.5 /) - A(14,:) = (/ 1.41, 37.5 /) - A(15,:) = (/ 1.41, 42.5 /) - A(16,:) = (/ 1.41, 47.5 /) - A(17,:) = (/ 1.41, 52.5 /) - A(18,:) = (/ 1.41, 57.5 /) - A(19,:) = (/ 1.41, 32.5 /) - A(20,:) = (/ 1.41, 37.5 /) - A(21,:) = (/ 23.00, 42.5 /) - A(22,:) = (/ 1.41, 47.5 /) - A(23,:) = (/ 1.41, 52.5 /) - A(24,:) = (/ 1.41, 57.5 /) - A(25,:) = (/ 18.00, 32.5 /) - A(26,:) = (/ 18.00, 42.5 /) - A(27,:) = (/ 18.00, 52.5 /) - A(28,:) = (/ 18.00, 32.5 /) - A(29,:) = (/ 18.00, 42.5 /) - A(30,:) = (/ 18.00, 52.5 /) - A(31,:) = (/ 6.70, 32.5 /) - A(32,:) = (/ 6.70, 37.5 /) - A(33,:) = (/ 6.70, 42.5 /) - A(34,:) = (/ 6.70, 47.5 /) - A(35,:) = (/ 6.70, 52.5 /) - A(36,:) = (/ 6.70, 57.5 /) - A(37,:) = (/ 6.70, 32.5 /) - A(38,:) = (/ 6.70, 37.5 /) - A(39,:) = (/ 6.70, 42.5 /) - A(40,:) = (/ 6.70, 47.5 /) - A(41,:) = (/ 6.70, 52.5 /) - A(42,:) = (/ 6.70, 57.5 /) - A(43,:) = (/ 6.70, 32.5 /) - A(44,:) = (/ 6.70, 37.5 /) - A(45,:) = (/ 6.70, 42.5 /) - A(46,:) = (/ 6.70, 47.5 /) - A(47,:) = (/ 6.70, 52.5 /) - A(48,:) = (/ 6.70, 57.5 /) - A(49,:) = (/ 6.70, 32.5 /) - A(50,:) = (/ 6.70, 37.5 /) - A(51,:) = (/ 6.70, 42.5 /) - A(52,:) = (/ 6.70, 47.5 /) - A(53,:) = (/ 6.70, 52.5 /) - A(54,:) = (/ 6.70, 57.5 /) - A(55,:) = (/ 87.00, 57.5 /) - - - end if - - ! ------------------------------------------------ - - A_orig = A - - do i=1,N_rows - write (*,*) A(i,:) - end do - - call unique_rows_2col( N_rows, A, N_unique_rows, ind_A2U) - - write (*,*) N_unique_rows - do i=1,N_unique_rows - write (*,*) A(i,:) - end do - do i=1,N_rows - write (*,*) A_orig(i,:), ind_A2U(i) - end do - -end program test_unique_rows - -#endif - - -#if 0 - -program test_unique_rows_3col - - ! find unique rows in 3-column matrix - ! - ! - reichle, 31 Mar 2015 - - use my_matrix_functions, ONLY: unique_rows_3col - - implicit none - - integer, parameter :: N_rows = 55 !9 - integer, parameter :: N_cols = 3 - - integer :: N_unique_rows, i - - real, dimension(N_rows,N_cols) :: A, A_orig - - logical, dimension(N_rows,N_cols) :: final_check - - integer, dimension(N_rows) :: ind_A2U - - ! --------------------------------------------- - - A(1,:) = (/ 1.5, 7.5, 4.5 /) - A(2,:) = (/ 2.5, 7.5, 6.5 /) - A(3,:) = (/ 3.5, 7.5, 4.5 /) - A(4,:) = (/ 1.5, 3.5, 6.5 /) - A(5,:) = (/ 2.5, 3.5, 6.5 /) - A(6,:) = (/ 3.5, 7.5, 4.5 /) - A(7,:) = (/ 1.5, 3.5, 6.5 /) - A(8,:) = (/ 2.5, 7.5, 6.5 /) - A(9,:) = (/ 3.5, 7.5, 6.5 /) - - if (N_rows==55) then - - A( 1,:) = (/ 0.20, 32.5, 0 /) - A( 2,:) = (/ 1.41, 37.5, 19 /) - A( 3,:) = (/ 1.41, 42.5, 19 /) - A( 4,:) = (/ 1.41, 47.5, 19 /) - A( 5,:) = (/ 1.41, 52.5, 0 /) - A( 6,:) = (/ 1.41, 57.5, 0 /) - A( 7,:) = (/ 1.41, 32.5, 0 /) - A( 8,:) = (/ 1.41, 37.5, 0 /) - A( 9,:) = (/ 1.41, 42.5, 0 /) - A(10,:) = (/ 1.41, 47.5, 0 /) - A(11,:) = (/ 1.41, 52.5, 0 /) - A(12,:) = (/ 1.41, 57.5, 0 /) - A(13,:) = (/ 1.41, 32.5, 0 /) - A(14,:) = (/ 1.41, 37.5, 0 /) - A(15,:) = (/ 1.41, 42.5, 0 /) - A(16,:) = (/ 1.41, 47.5, 0 /) - A(17,:) = (/ 1.41, 52.5, 0 /) - A(18,:) = (/ 1.41, 57.5, 0 /) - A(19,:) = (/ 1.41, 32.5, 0 /) - A(20,:) = (/ 1.41, 37.5, 0 /) - A(21,:) = (/ 23.00, 42.5, 0 /) - A(22,:) = (/ 1.41, 47.5, 0 /) - A(23,:) = (/ 1.41, 52.5, 0 /) - A(24,:) = (/ 1.41, 57.5, 0 /) - A(25,:) = (/ 18.00, 32.5, 0 /) - A(26,:) = (/ 18.00, 42.5, 0 /) - A(27,:) = (/ 18.00, 52.5, 0 /) - A(28,:) = (/ 18.00, 32.5, 0 /) - A(29,:) = (/ 18.00, 42.5, 0 /) - A(30,:) = (/ 18.00, 52.5, 0 /) - A(31,:) = (/ 6.70, 32.5, 3 /) - A(32,:) = (/ 6.70, 37.5, 3 /) - A(33,:) = (/ 6.70, 42.5, 3 /) - A(34,:) = (/ 6.70, 47.5, 0 /) - A(35,:) = (/ 6.70, 52.5, 3 /) - A(36,:) = (/ 6.70, 57.5, 3 /) - A(37,:) = (/ 6.70, 32.5, 3 /) - A(38,:) = (/ 6.70, 37.5, 3 /) - A(39,:) = (/ 6.70, 42.5, 3 /) - A(40,:) = (/ 6.70, 47.5, 3 /) - A(41,:) = (/ 6.70, 52.5, 3 /) - A(42,:) = (/ 6.70, 57.5, 3 /) - A(43,:) = (/ 6.70, 32.5, 0 /) - A(44,:) = (/ 6.70, 37.5, 0 /) - A(45,:) = (/ 6.70, 42.5, 0 /) - A(46,:) = (/ 6.70, 47.5, 0 /) - A(47,:) = (/ 6.70, 52.5, 0 /) - A(48,:) = (/ 6.70, 57.5, 0 /) - A(49,:) = (/ 6.70, 32.5, 0 /) - A(50,:) = (/ 6.70, 37.5, 0 /) - A(51,:) = (/ 6.70, 42.5, 0 /) - A(52,:) = (/ 6.70, 47.5, 0 /) - A(53,:) = (/ 6.70, 52.5, 0 /) - A(54,:) = (/ 6.70, 57.5, 0 /) - A(55,:) = (/ 87.00, 57.5, 0 /) - - end if - - ! ------------------------------------------------ - - A_orig = A - - do i=1,N_rows - write (*,*) A(i,:) - end do - - call unique_rows_3col( N_rows, A, N_unique_rows, ind_A2U ) - - write (*,*) - write (*,*) N_unique_rows - do i=1,N_unique_rows - write (*,*) A(i,:) ! Tb_FreqAngRTMid - end do - - write (*,*) - do i=1,N_rows - write (*,*) A_orig(i,:), ind_A2U(i) ! ind_Tbspecies2TbuniqFreqAngRTMid - end do - - ! final check - - final_check = ( A_orig == A(ind_A2U,:) ) - - write (*,*) - do i=1,N_rows - write (*,*) final_check(i,:) - end do - - write (*,*) - if (all(final_check)) then - - write (*,*) 'success' - - else - - write (*,*) 'ERROR - failed final check' - - end if - -end program test_unique_rows_3col - -#endif - -! ***** EOF ************************************************************** diff --git a/src/Components/GEOSldas_GridComp/LDAS_Shared/nr_indexx.f b/src/Components/GEOSldas_GridComp/LDAS_Shared/nr_indexx.f deleted file mode 100644 index e55ece24..00000000 --- a/src/Components/GEOSldas_GridComp/LDAS_Shared/nr_indexx.f +++ /dev/null @@ -1,87 +0,0 @@ - -c QUICKSORT algorithm for indexing adapted from Numerical Recipes -c -c Indexes an array arr(1:n), i.e., outputs the array indx(1:n) such -c that arr(indx(j)) is in ascending order for j = 1;2; : : :;N. -c The input quantities n and arr are not changed. - - SUBROUTINE nr_indexx(n,arr,indx) - INTEGER n,indx(n),M,NSTACK - REAL arr(n) - PARAMETER (M=7,NSTACK=50) - INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL a - do j=1,n - indx(j)=j - enddo - jstack=0 - l=1 - ir=n - 1 if(ir-l.lt.M)then - do j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do i=j-1,l,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) - enddo - i=l-1 - 2 indx(i+1)=indxt - enddo - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(l+1)))then - itemp=indx(l) - indx(l)=indx(l+1) - indx(l+1)=itemp - endif - i=l+1 - j=ir - indxt=indx(l+1) - a=arr(indxt) - 3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 - 4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 - 5 indx(l+1)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - END - -c ======================= EOF ======================================== From d0d26fa772a1175a7beae54950435ee28502b468 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 26 Mar 2024 12:58:45 -0400 Subject: [PATCH 06/10] updated documentation in prep for release v18.0.1 (README.md, CHANGELOG.md) --- README.md | 5 +++++ doc/CHANGELOG.md | 13 +++++++++++++ 2 files changed, 18 insertions(+) diff --git a/README.md b/README.md index 84ca1cf8..dd8f8812 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,11 @@ This document explains how to build, set up, and run the GEOS land modeling and data assimilation system (`GEOSldas`) on the most common systems used by GMAO. Additional steps are needed on other systems. +## Restructuring of GEOSldas repository + +On 26 March 2024, the GEOSldas repository was restructured and split into two repositories. The GEOSldas source code was moved from the present repository, the GEOSldas fixture, into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp). The present repository now imports the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) as an external repository. Note that in the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), the "Applications" directory `src/Applications/LDAS_App` moved to `src/Components/GEOSldas_GridComp/GEOSldas_App`. + + ## How to Build GEOSldas ### Step 1: Load the Build Modules diff --git a/doc/CHANGELOG.md b/doc/CHANGELOG.md index 5626d2ef..6977bce4 100644 --- a/doc/CHANGELOG.md +++ b/doc/CHANGELOG.md @@ -33,6 +33,19 @@ This README file contains the history of stable GEOSldas Releases in Git, follow Overview of Git Releases: ============================ +[v18.0.1](https://github.com/GEOS-ESM/GEOSldas/releases/tag/v18.0.1) - 2024-03-26 +------------------------------ + +- 0-diff vs. v18.0.0 + +- Notes: + - Essentially identical to v18.0.0 but in revised GEOSldas + [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) repository structure ([PR #748](https://github.com/GEOS-ESM/GEOSldas/pull/748), [PR #750](https://github.com/GEOS-ESM/GEOSldas/pull/750)). + +- Minor changes: + - Support for running "sbatch [FULL_PATH/]lenkf.j" from any directory ([PR #745](https://github.com/GEOS-ESM/GEOSldas/pull/745)). + + +------------------------------ [v18.0.0](https://github.com/GEOS-ESM/GEOSldas/releases/tag/v18.0.0) - 2024-03-22 ------------------------------ From f2a91ecba9db88fc39fcd7cb9a858f40de638224 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 26 Mar 2024 16:46:50 -0400 Subject: [PATCH 07/10] additional edits of documentation in prep for release v18.0.1 --- README.md | 4 +++- doc/CHANGELOG.md | 8 ++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index dd8f8812..277f4cb1 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,9 @@ This document explains how to build, set up, and run the GEOS land modeling and ## Restructuring of GEOSldas repository -On 26 March 2024, the GEOSldas repository was restructured and split into two repositories. The GEOSldas source code was moved from the present repository, the GEOSldas fixture, into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp). The present repository now imports the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) as an external repository. Note that in the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), the "Applications" directory `src/Applications/LDAS_App` moved to `src/Components/GEOSldas_GridComp/GEOSldas_App`. +On 26 March 2024, the GEOSldas repository was restructured and split into two repositories. The GEOSldas source code was moved from the GEOSldas fixture into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), which is now imported into the fixture as an external repository. + +Note that the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) includes the "Applications" directory [`./GEOSldas_App`](https://github.com/GEOS-ESM/GEOSldas_GridComp/tree/develop/GEOSldas_App). ## How to Build GEOSldas diff --git a/doc/CHANGELOG.md b/doc/CHANGELOG.md index 6977bce4..b77b0939 100644 --- a/doc/CHANGELOG.md +++ b/doc/CHANGELOG.md @@ -27,19 +27,19 @@ this period, LDASsa and GEOSldas development continued in parallel. In 2019, GEOS LDAS version control transferred from CVS to Git. +In March 2024, GEOSldas was split into two repositories, the GEOSldas fixture and the GEOSldas_GridComp. + This README file contains the history of stable GEOSldas Releases in Git, followed by older, CVS LDASsa tags and GEOSldas versions and change logs. Overview of Git Releases: ============================ -[v18.0.1](https://github.com/GEOS-ESM/GEOSldas/releases/tag/v18.0.1) - 2024-03-26 +[v18.0.1](https://github.com/GEOS-ESM/GEOSldas/releases/tag/v18.0.1) - 2024-03-27 ------------------------------ - 0-diff vs. v18.0.0 - -- Notes: - - Essentially identical to v18.0.0 but in revised GEOSldas + [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) repository structure ([PR #748](https://github.com/GEOS-ESM/GEOSldas/pull/748), [PR #750](https://github.com/GEOS-ESM/GEOSldas/pull/750)). +- Essentially identical to v18.0.0 except for revised repository structure after split into two repositories: [GEOSldas](https://github.com/GEOS-ESM/GEOSldas) and [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) ([PR #748](https://github.com/GEOS-ESM/GEOSldas/pull/748), [PR #750](https://github.com/GEOS-ESM/GEOSldas/pull/750)). - Minor changes: - Support for running "sbatch [FULL_PATH/]lenkf.j" from any directory ([PR #745](https://github.com/GEOS-ESM/GEOSldas/pull/745)). From 12d05f47a7f67ab3e4e664a5ec895239129b55a6 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 26 Mar 2024 16:52:52 -0400 Subject: [PATCH 08/10] more edits of documentation in prep for release v18.0.1 (README.md, CHANGELOG.md) --- README.md | 4 +--- doc/CHANGELOG.md | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 277f4cb1..46828ceb 100644 --- a/README.md +++ b/README.md @@ -4,9 +4,7 @@ This document explains how to build, set up, and run the GEOS land modeling and ## Restructuring of GEOSldas repository -On 26 March 2024, the GEOSldas repository was restructured and split into two repositories. The GEOSldas source code was moved from the GEOSldas fixture into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), which is now imported into the fixture as an external repository. - -Note that the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) includes the "Applications" directory [`./GEOSldas_App`](https://github.com/GEOS-ESM/GEOSldas_GridComp/tree/develop/GEOSldas_App). +On 26 March 2024, GEOSldas was restructured and split into two repositories. Specifically, the GEOSldas source code was moved from the GEOSldas fixture into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), which is now imported into the fixture as an external repository. Note that the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) includes the "Applications" directory [`./GEOSldas_App`](https://github.com/GEOS-ESM/GEOSldas_GridComp/tree/develop/GEOSldas_App). ## How to Build GEOSldas diff --git a/doc/CHANGELOG.md b/doc/CHANGELOG.md index b77b0939..f3a21972 100644 --- a/doc/CHANGELOG.md +++ b/doc/CHANGELOG.md @@ -38,7 +38,7 @@ Overview of Git Releases: [v18.0.1](https://github.com/GEOS-ESM/GEOSldas/releases/tag/v18.0.1) - 2024-03-27 ------------------------------ -- 0-diff vs. v18.0.0 +- 0-diff vs. v18.0.0. - Essentially identical to v18.0.0 except for revised repository structure after split into two repositories: [GEOSldas](https://github.com/GEOS-ESM/GEOSldas) and [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) ([PR #748](https://github.com/GEOS-ESM/GEOSldas/pull/748), [PR #750](https://github.com/GEOS-ESM/GEOSldas/pull/750)). - Minor changes: From ee6c49051e7c4f238eadd1fa038a0b7dee7b52ea Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 26 Mar 2024 17:30:00 -0400 Subject: [PATCH 09/10] additional change of documentation in prep for v18.0.1 (README.md) --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 46828ceb..0f31d7e7 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ This document explains how to build, set up, and run the GEOS land modeling and data assimilation system (`GEOSldas`) on the most common systems used by GMAO. Additional steps are needed on other systems. -## Restructuring of GEOSldas repository +## Note: GEOSldas Repository Structure Revised (March 2024) On 26 March 2024, GEOSldas was restructured and split into two repositories. Specifically, the GEOSldas source code was moved from the GEOSldas fixture into a new repository, the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp), which is now imported into the fixture as an external repository. Note that the [GEOSldas_GridComp](https://github.com/GEOS-ESM/GEOSldas_GridComp) includes the "Applications" directory [`./GEOSldas_App`](https://github.com/GEOS-ESM/GEOSldas_GridComp/tree/develop/GEOSldas_App). From df667c5d315f32241b3b2825952789d499cf1fad Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Tue, 26 Mar 2024 18:13:27 -0400 Subject: [PATCH 10/10] edited components.yaml in prep for release v18.0.1 --- components.yaml | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/components.yaml b/components.yaml index 35f02de8..245ced11 100644 --- a/components.yaml +++ b/components.yaml @@ -1,18 +1,15 @@ GEOSldas: fixture: true - develop: develop env: local: ./@env remote: ../ESMA_env.git tag: v4.23.0 - develop: main cmake: local: ./@cmake remote: ../ESMA_cmake.git tag: v3.41.0 - develop: develop ecbuild: local: ./@cmake/@ecbuild @@ -24,37 +21,32 @@ NCEP_Shared: remote: ../NCEP_Shared.git tag: v1.3.0 sparse: ./config/NCEP_Shared.sparse - develop: main GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git tag: v1.9.7 sparse: ./config/GMAO_Shared.sparse - develop: main GEOS_Util: local: ./src/Shared/@GMAO_Shared/@GEOS_Util remote: ../GEOS_Util.git tag: v2.0.7 sparse: ./config/GEOS_Util.sparse - develop: main MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git tag: v2.44.1 - develop: develop GEOSldas_GridComp: local: ./src/Components/@GEOSldas_GridComp remote: ../GEOSldas_GridComp.git - branch: develop - develop: develop + tag: v1.0.0 GEOSgcm_GridComp: local: ./src/Components/@GEOSldas_GridComp/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - branch: develop + tag: v2.5.2 sparse: ./config/GEOSgcm_GridComp_ldas.sparse - develop: develop +