From 843f23e394ed1d29c808bcec33ba51c53f8b459b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 25 Mar 2024 16:22:23 -0400 Subject: [PATCH 1/2] 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 2/2] 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 ========================================